Results 1 to 32 of 32

Thread: Private Font and GDI+

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Private Font and GDI+

    Below is my code to attempt to use a private otf font with GDI+

    It does not work.

    Any ideas?

    Code:
    Option Explicit
    
    
    Dim gdiplusToken As Long
    
    Dim stat As Long
    
    Dim graphics As Long
    Dim privateFontCollection As Long
    Dim fontFamilyPrivate As Long
    Dim fontPrivate As Long
    
    
    Private Sub Form_Load()
    
        Form1.Caption = "GDI+ (Use Private Font)"
        Form1.Width = Screen.TwipsPerPixelX * 600
        Form1.Height = Screen.TwipsPerPixelY * 465
        Form1.BackColor = &H8000000F
        Form1.ScaleMode = vbPixels
        
        Picture1.Appearance = 0
        Picture1.Left = 16
        Picture1.Top = 16
        Picture1.Height = 366
        Picture1.Width = 552
        'Picture1.Font = "courier new"
        Picture1.AutoRedraw = True
        Picture1.ScaleMode = vbPixels
        
        Command1.Width = Picture1.Width
        Command1.Height = 25
        Command1.Left = Picture1.Left
        Command1.Top = Picture1.Top + Picture1.Height + 10
        Command1.Caption = "Use Private Font"
    
        ' Initialize Windows GDI+
        Dim GdiplusStartupInput As GdiplusStartupInput
        GdiplusStartupInput.GdiplusVersion = 1
        GdiplusStartupInput.DebugEventCallback = 0
        GdiplusStartupInput.SuppressBackgroundThread = False
        GdiplusStartupInput.SuppressExternalCodecs = False
        Dim status As GpStatus
        status = GdiplusStartup(gdiplusToken, GdiplusStartupInput, 0)
        If status <> Ok Then
            MsgBox "Error loading GDI+!", vbCritical
            Call GdiplusShutdown(gdiplusToken)
        End If
    
    End Sub
    
    
    Private Sub Form_Unload(Cancel As Integer)
    
        ' Clean up resources used by Windows GDI+
        Call GdiplusShutdown(gdiplusToken)
        
    End Sub
    
    
    Private Sub Command1_Click()
        stat = GdipCreateFromHDC(Picture1.hdc, graphics)
        Call GdipSample
        stat = GdipDeleteGraphics(graphics)
    End Sub
    
    
    Private Sub GdipSample()
    
        'Picture1.Cls
        stat = GdipGraphicsClear(graphics, &HFFFFFFFF)                  'clear to white
        
        stat = GdipNewPrivateFontCollection(privateFontCollection)
        Debug.Print "GdipNewPrivateFontCollection = " & stat
    
        stat = GdipPrivateAddFontFile(privateFontCollection, StrPtr(App.path & "\PetalumaScript.otf"))
        Debug.Print "GdipPrivateAddFontFile = " & stat
        
        stat = GdipCreateFontFamilyFromName(StrPtr(App.path & "\PetalumaScript.otf"), privateFontCollection, fontFamilyPrivate)
        Debug.Print "GdipCreateFontFamilyFromName = " & stat
        
        stat = GdipCreateFont(fontFamilyPrivate, 48, FontStyle.FontStyleRegular, UnitPixel, fontPrivate)
        Debug.Print "GdipCreateFontFamilyFromName = " & stat
        
    
    
        Dim blackBrush As Long
        stat = GdipCreateSolidFill(&HFF000000, blackBrush)
        Dim rctf As RECTF
        stat = GdipDrawString(graphics, StrPtr("Private Font String"), -1, fontPrivate, rctf, 0, blackBrush)
        Debug.Print "GdipDrawString = " & stat
     
       
        
        Picture1.Refresh
    
    End Sub

  2. #2

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    So I guess the first question is...
    Why does this line
    Code:
    stat = GdipPrivateAddFontFile(privateFontCollection, StrPtr(App.path & "\PetalumaScript.otf"))
    return a "File Not Found" error when I've definitely put that otf file in the app folder?

  3. #3
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,916

    Re: Private Font and GDI+

    How is the function declared? Is it actually a Long or did you declare the path argument as String?

  4. #4

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    This is the declare I am using
    Code:
    Public Declare Function GdipPrivateAddFontFile Lib "gdiplus" (ByVal fontCollection As Long, ByVal filename As String) As GpStatus

  5. #5
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,916

    Re: Private Font and GDI+

    Yup that's the problem-- you're passing a Long to a String.

    Change the declare to ByVal filename As Long.

  6. #6
    PowerPoster
    Join Date
    Nov 2017
    Posts
    3,205

    Re: Private Font and GDI+

    If the filename is a string, why are you passing StrPtr(filename) in the call?

  7. #7
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,230

    Re: Private Font and GDI+

    Check out this GdipPreparePrivateFont helper function implementation. You can use it like this:

    Code:
            GdipPreparePrivateFont LocateFile(PathCombine(App.Path, "External\fa-regular-400.ttf")), m_oFont.Size, m_hFontAwesomeRegular, m_hFontAwesomeColRegular
            GdipPreparePrivateFont LocateFile(PathCombine(App.Path, "External\fa-solid-900.ttf")), m_oFont.Size, m_hFontAwesomeSolid, m_hFontAwesomeColSolid
    You can cache the font collection (m_hFontAwesomeColRegular and m_hFontAwesomeColSolid in code above) in a static variables and reuse these in all instances of your class/user-control so the font file is loaded once to reduce redundancy/memory usage.

    You can destroy the font (m_hFontAwesomeRegular and m_hFontAwesomeSolid in code above) with regular GdipDeleteFont API call as these don't unload the font files actually but are placeholders for size and other font properties requested.

    cheers,
    </wqw>

  8. #8

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    OK thanks wqweto
    I will try to understand, and play with what you suggested this evening.

    So the problem is GdipPrivateAddFontFile is not receiving the correct path to the otf file?

  9. #9
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,916

    Re: Private Font and GDI+

    I don't know if that's your *only* problem but yes that's why you're getting file not found from GdipPrivateAddFontFile; the declare needs to be As Long instead of As String.

  10. #10

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    OK so I fixed the declare but same error (FileNotFound)

    I tried something different.
    I copied Arial.ttf from my fonts folder and placed copy into app folder and everything works.

    So it looks like problem is that otf not supported?
    I'm sure I read somewhere that it was.

  11. #11
    PowerPoster
    Join Date
    Nov 2017
    Posts
    3,205

    Re: Private Font and GDI+

    https://stackoverflow.com/questions/...on-addfontfile

    Comments seem to indicate the File Not Found error is also thrown when the filetype is unsupported, which apparently can happen with otf files. I didn't read through the whole thread, and it is a C# related thread, but maybe there's stuff in there that might help you out.

  12. #12
    Addicted Member -Franky-'s Avatar
    Join Date
    Dec 2022
    Location
    Bremen Germany
    Posts
    250

    Re: Private Font and GDI+

    According to the table at the bottom of the page, 2 OTF font types are supported. https://learn.microsoft.com/en-us/wi...collection-use

  13. #13

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    OK so using these two declares
    Code:
    Public Declare Function GdipNewPrivateFontCollection Lib "gdiplus" _
                    (fontCollection As Long) As GpStatus
    Public Declare Function GdipPrivateAddFontFile Lib "gdiplus" _
                    (ByVal fontCollection As Long, ByVal filename As Long) As GpStatus
    with wqweto's code from post #7
    Code:
    Private Sub Command1_Click()
       stat = GdipCreateFromHDC(Picture1.hdc, graphics)
       Call GdipPreparePrivateFont
       stat = GdipDeleteGraphics(graphics)
    End Sub
    
    Private Sub GdipPreparePrivateFont()
    
       'Picture1.Cls
       stat = GdipGraphicsClear(graphics, &HFFFFFFFF)                  'clear to white
        
        
       '-----------------------------------------------------------------------------------
       ' wqweto code
        
       Dim hNewFontCol  As Long
       Dim hFamily      As Long
       Dim lNumFamilies As Long
       Dim hNewFont     As Long
        
       stat = GdipNewPrivateFontCollection(hNewFontCol)
       Debug.Print stat
        
       stat = GdipPrivateAddFontFile(hNewFontCol, StrPtr(App.path & "\PetalumaScript.otf"))
       Debug.Print stat
       '-----------------------------------------------------------------------------------
        
        
       Picture1.Refresh
    
    End Sub
    I get the following result in the immediate window
    Code:
    0 
    10    [File Not Found]
    
    However, using
    Code:
       stat = GdipPrivateAddFontFile(hNewFontCol, StrPtr(App.path & "\Arial.ttf"))
    works!!!

    Some background:

    I am trying to use above code on a Windows7 Professionial machine with Administrator Lock on Fonts Folder
    (hence trying to use PRIVATE font files).

    I know the font file PetalumaScript.otf is OK, because I can use the same font file with GDI+ and all works OK
    on a Windows10 Professional machine also with Administrator Lock
    (The font file is placed in the System Fonts Folder on this Windows10 machine
    because Windows10 seems to allow regular user to install fonts in this folder).

    Any more ideas with this current approach?

    Any other ideas as to how to use otf font file on Windows7 machine where font can't be installed in System Fonts Folder?
    Last edited by mms_; Apr 20th, 2024 at 10:09 PM.

  14. #14
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    5,916

    Re: Private Font and GDI+

    Use one of the online OTF to TTF converters then use TTF?

  15. #15
    Addicted Member -Franky-'s Avatar
    Join Date
    Dec 2022
    Location
    Bremen Germany
    Posts
    250

    Re: Private Font and GDI+

    FontForge should also be able to convert OTF to TTF. https://fontforge.org/en-US/

  16. #16

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    Is someone able to confirm that otf font files cannot be used?

    I find it strange that GDI+ can use this file correctly if placed in system fonts folder, but not somewhere else.

    What about using AddFontResourceEx api?
    If that is a possibility I would need some sample code.

  17. #17

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    It is quite clear from the Microsoft documentation that -Franky- linked in post #12 that otf font files are supported.
    I don't want to give up on this.

  18. #18
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,230

    Re: Private Font and GDI+

    Quote Originally Posted by mms_ View Post
    It is quite clear from the Microsoft documentation that -Franky- linked in post #12 that otf font files are supported.
    I don't want to give up on this.
    I can successfully load Petaluma.otf, PetalumaScript.otf and PetalumaText.otf with GdipPreparePrivateFont here on Win11.

    Btw, there are other useful helpers in that module e.g. GdipPrepareFont uses GdipCreateFontFromDC to convert StdFont objects to GDI+ font handles easily in 5 lines of code.

    cheers,
    </wqw>

  19. #19

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    OK thanks for taking the time to test wqweto
    Just to confirm... those 3 fonts only reside in app folder, and not in System Fonts folder on your machine?

    Are you saying that, because it works for you in Windows11, same code must work for me on my Windows7 machine?

    And as an aside, do glyphs from Petaluma.otf display correctly using the private font method? (it uses non-standard codepoints)

    Btw, there are other useful helpers in that module e.g. GdipPrepareFont uses GdipCreateFontFromDC to convert StdFont objects to GDI+ font handles easily in 5 lines of code.
    I will wait until I confirm that GdipNewPrivateFontCollection does not work with otf files on Windows7, before starting with this.
    But thanks for giving me some new hope.

  20. #20
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,230

    Re: Private Font and GDI+

    Not working on Win7, just tested with this:

    Code:
    '--- Form1
    Option Explicit
    
    '--- for GdipCreateFont
    Private Const UnitPoint                     As Long = 3
    
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    '--- gdi+
    Private Declare Function GdiplusStartup Lib "gdiplus" (hToken As Long, pInputBuf As Any, Optional ByVal pOutputBuf As Long = 0) As Long
    Private Declare Function GdipNewPrivateFontCollection Lib "gdiplus" (hFontCollection As Long) As Long
    Private Declare Function GdipPrivateAddFontFile Lib "gdiplus" (ByVal hFontCollection As Long, ByVal lpFileName As Long) As Long
    Private Declare Function GdipGetFontCollectionFamilyList Lib "gdiplus" (ByVal hFontCollection As Long, ByVal lNumSought As Long, aFamilies As Any, lNumFound As Long) As Long
    Private Declare Function GdipCreateFont Lib "gdiplus" (ByVal hFontFamily As Long, ByVal emSize As Single, ByVal lStyle As Long, ByVal lUnit As Long, hFont As Long) As Long
    Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal hFont As Long) As Long
    Private Declare Function GdipDeletePrivateFontCollection Lib "gdiplus" (hFontCollection As Long) As Long
    Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, hGraphics As Long) As Long
    Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long
    Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal hFormatAttributes As Long, ByVal nLanguage As Integer, hStringFormat As Long) As Long
    Private Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal hStringFormat As Long) As Long
    Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal hStringFormat As Long, ByVal eAlign As StringAlignment) As Long
    Private Declare Function GdipSetStringFormatLineAlign Lib "gdiplus" (ByVal hStringFormat As Long, ByVal eAlign As StringAlignment) As Long
    Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal lColor As Long, hBrush As Long) As Long
    Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal hBrush As Long) As Long
    Private Declare Function GdipDrawString Lib "gdiplus" (ByVal hGraphics As Long, ByVal lStrPtr As Long, ByVal lLength As Long, ByVal hFont As Long, uRect As RECTF, ByVal hStringFormat As Long, ByVal hBrush As Long) As Long
    
    Private Enum StringAlignment
       StringAlignmentNear = 0
       StringAlignmentCenter = 1
       StringAlignmentFar = 2
    End Enum
    
    Private Type RECTF
       Left                 As Single
       Top                  As Single
       Right                As Single
       Bottom               As Single
    End Type
    
    Private m_hFontPetaluma     As Long
    Private m_hFontColPetaluma  As Long
    
    Private Sub Form_Initialize()
        Dim aInput(0 To 3)  As Long
        
        If GetModuleHandle("gdiplus") = 0 Then
            aInput(0) = 1
            Call GdiplusStartup(0, aInput(0))
        End If
        GdipPreparePrivateFont App.Path & "\PetalumaScript.otf", 12, m_hFontPetaluma, m_hFontColPetaluma
        If m_hFontPetaluma = 0 Then
            MsgBox "Cannot load " & App.Path & "\PetalumaScript.otf", vbCritical
        End If
    End Sub
    
    Private Sub Form_Click()
        Dim hGraphics       As Long
        Dim hStringFormat   As Long
        Dim hBrush          As Long
        Dim sText           As String
        Dim uRect           As RECTF
        
        If GdipCreateFromHDC(hDC, hGraphics) <> 0 Then
            GoTo QH
        End If
        If GdipCreateStringFormat(0, 0, hStringFormat) <> 0 Then
            GoTo QH
        End If
        If GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter) <> 0 Then
            GoTo QH
        End If
        If GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter) <> 0 Then
            GoTo QH
        End If
        If GdipCreateSolidFill(&HFFFF0000, hBrush) <> 0 Then
            GoTo QH
        End If
        sText = "This is a test"
        uRect.Right = ScaleWidth / Screen.TwipsPerPixelX
        uRect.Bottom = ScaleHeight / Screen.TwipsPerPixelY
        If GdipDrawString(hGraphics, StrPtr(sText), -1, m_hFontPetaluma, uRect, hStringFormat, hBrush) <> 0 Then
            GoTo QH
        End If
    QH:
        If hBrush <> 0 Then
            Call GdipDeleteBrush(hBrush)
            hBrush = 0
        End If
        If hStringFormat <> 0 Then
            Call GdipDeleteStringFormat(hStringFormat)
            hStringFormat = 0
        End If
        If hGraphics <> 0 Then
            Call GdipDeleteGraphics(hGraphics)
            hGraphics = 0
        End If
    End Sub
    
    Public Function GdipPreparePrivateFont(sFileName As String, ByVal lFontSize As Long, hFont As Long, hFontCollection As Long) As Boolean
        Dim hNewFontCol     As Long
        Dim hFamily         As Long
        Dim lNumFamilies    As Long
        Dim hNewFont        As Long
        
        If hFontCollection = 0 Then
            If GdipNewPrivateFontCollection(hNewFontCol) <> 0 Then
                GoTo QH
            End If
            If GdipPrivateAddFontFile(hNewFontCol, StrPtr(sFileName)) <> 0 Then
                GoTo QH
            End If
        Else
            hNewFontCol = hFontCollection
        End If
        If GdipGetFontCollectionFamilyList(hNewFontCol, 1, hFamily, lNumFamilies) <> 0 Or lNumFamilies = 0 Then
            GoTo QH
        End If
        If GdipCreateFont(hFamily, lFontSize, 0, UnitPoint, hNewFont) <> 0 Then
            GoTo QH
        End If
        '--- commit
        If hFont <> 0 Then
            Call GdipDeleteFont(hFont)
        End If
        hFont = hNewFont
        hNewFont = 0
        If hFontCollection <> 0 And hFontCollection <> hNewFontCol Then
            Call GdipDeletePrivateFontCollection(hFontCollection)
        End If
        hFontCollection = hNewFontCol
        hNewFontCol = 0
        '--- success
        GdipPreparePrivateFont = True
    QH:
        If hNewFont <> 0 Then
            Call GdipDeleteFont(hNewFont)
            hNewFont = 0
        End If
        If hNewFontCol <> 0 And hFontCollection <> hNewFontCol Then
            Call GdipDeletePrivateFontCollection(hNewFontCol)
            hNewFontCol = 0
        End If
    End Function
    Compiled project and font: PetalumaTest.zip

    Apparently .otf fonts load correctly on Win8, Win10 and Win11 but fail on Win7.

    > Just to confirm... those 3 fonts only reside in app folder, and not in System Fonts folder on your machine?

    Yes.

    cheers,
    </wqw>

  21. #21

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    Thank you wqweto for going through all that trouble!!

    I can comfortably abandon the idea of using this approach on a Windows7 machine,
    knowing it truly will not work, and not that it does work, but I was doing something wrong.

    Btw, there are other useful helpers in that module e.g. GdipPrepareFont uses GdipCreateFontFromDC to convert StdFont objects to GDI+ font handles easily in 5 lines of code.
    Am I correct in assuming that using AddFontResourceEx along with what's contained in above, I should be able to get this working on Windows7?

  22. #22
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,289

    Re: Private Font and GDI+

    Quote Originally Posted by mms_ View Post
    It is quite clear from the Microsoft documentation that -Franky- linked in post #12 that otf font files are supported.
    In the table at the end of the page, it is clearly stated,
    that otf-support (for Adobe-Formats) does not work on Win7, only from Win8 onwards.

    Olaf

  23. #23

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    In the table at the end of the page, it is clearly stated,
    that otf-support (for Adobe-Formats) does not work on Win7, only from Win8 onwards.
    I guess I have to assume the fonts I want use the Adobe CFF format and not True Type format

    So two more possibilities then.
    1. Now that I have working code to use GDI+ Private Fonts from wqweto, try on-line otf to ttf convertor suggested by fafalone
    2. Try wqweto's suggestion to "convert StdFont objects to GDI+ font handles" and see if that will work

    I will start with 2. first

  24. #24
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,230

    Re: Private Font and GDI+

    No, 2. is not working under Win7, just tested with this:

    Code:
    '--- Form1
    Option Explicit
    
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    '--- gdi+
    Private Declare Function GdiplusStartup Lib "gdiplus" (hToken As Long, pInputBuf As Any, Optional ByVal pOutputBuf As Long = 0) As Long
    Private Declare Function GdipCreateFontFromDC Lib "gdiplus" (ByVal hDC As Long, hCreatedFont As Long) As Long
    Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal hFont As Long) As Long
    Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, hGraphics As Long) As Long
    Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long
    Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal hFormatAttributes As Long, ByVal nLanguage As Integer, hStringFormat As Long) As Long
    Private Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal hStringFormat As Long) As Long
    Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal hStringFormat As Long, ByVal eAlign As StringAlignment) As Long
    Private Declare Function GdipSetStringFormatLineAlign Lib "gdiplus" (ByVal hStringFormat As Long, ByVal eAlign As StringAlignment) As Long
    Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal lColor As Long, hBrush As Long) As Long
    Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal hBrush As Long) As Long
    Private Declare Function GdipDrawString Lib "gdiplus" (ByVal hGraphics As Long, ByVal lStrPtr As Long, ByVal lLength As Long, ByVal hFont As Long, uRect As RECTF, ByVal hStringFormat As Long, ByVal hBrush As Long) As Long
    
    Private Enum StringAlignment
       StringAlignmentNear = 0
       StringAlignmentCenter = 1
       StringAlignmentFar = 2
    End Enum
    
    Private Type RECTF
       Left                 As Single
       Top                  As Single
       Right                As Single
       Bottom               As Single
    End Type
    
    Private m_hFontPetaluma     As Long
    
    Private Sub Form_Initialize()
        Const STR_FONTNAME  As String = "Petaluma Script"
        Dim aInput(0 To 3)  As Long
        Dim oFont           As StdFont
        
        If GetModuleHandle("gdiplus") = 0 Then
            aInput(0) = 1
            Call GdiplusStartup(0, aInput(0))
        End If
        Set oFont = New StdFont
        oFont.Name = STR_FONTNAME
        oFont.Size = 12
        If oFont.Name <> STR_FONTNAME Then
            MsgBox "Missing font " & STR_FONTNAME, vbCritical
            Exit Sub
        End If
        GdipPrepareFont oFont, m_hFontPetaluma
        If m_hFontPetaluma = 0 Then
            MsgBox "Cannot load " & STR_FONTNAME, vbCritical
        End If
    End Sub
    
    Private Sub Form_Click()
        Dim hGraphics       As Long
        Dim hStringFormat   As Long
        Dim hBrush          As Long
        Dim sText           As String
        Dim uRect           As RECTF
        
        If GdipCreateFromHDC(hDC, hGraphics) <> 0 Then
            GoTo QH
        End If
        If GdipCreateStringFormat(0, 0, hStringFormat) <> 0 Then
            GoTo QH
        End If
        If GdipSetStringFormatAlign(hStringFormat, StringAlignmentCenter) <> 0 Then
            GoTo QH
        End If
        If GdipSetStringFormatLineAlign(hStringFormat, StringAlignmentCenter) <> 0 Then
            GoTo QH
        End If
        If GdipCreateSolidFill(&HFFFF0000, hBrush) <> 0 Then
            GoTo QH
        End If
        sText = "This is a test"
        uRect.Right = ScaleWidth / Screen.TwipsPerPixelX
        uRect.Bottom = ScaleHeight / Screen.TwipsPerPixelY
        If GdipDrawString(hGraphics, StrPtr(sText), -1, m_hFontPetaluma, uRect, hStringFormat, hBrush) <> 0 Then
            GoTo QH
        End If
    QH:
        If hBrush <> 0 Then
            Call GdipDeleteBrush(hBrush)
            hBrush = 0
        End If
        If hStringFormat <> 0 Then
            Call GdipDeleteStringFormat(hStringFormat)
            hStringFormat = 0
        End If
        If hGraphics <> 0 Then
            Call GdipDeleteGraphics(hGraphics)
            hGraphics = 0
        End If
    End Sub
    
    Public Function GdipPrepareFont(oFont As StdFont, hFont As Long) As Boolean
        Const FUNC_NAME     As String = "GdipPrepareFont"
        Dim hDC             As Long
        Dim pFont           As IFont
        Dim hPrevFont       As Long
        Dim hNewFont        As Long
        
        On Error GoTo EH
        Set pFont = oFont
        If pFont Is Nothing Then
            GoTo QH
        End If
        hDC = GetDC(0)
        If hDC = 0 Then
            GoTo QH
        End If
        hPrevFont = SelectObject(hDC, pFont.hFont)
        If hPrevFont = 0 Then
            GoTo QH
        End If
        If GdipCreateFontFromDC(hDC, hNewFont) <> 0 Then
            GoTo QH
        End If
        '--- commit
        If hFont <> 0 Then
            Call GdipDeleteFont(hFont)
        End If
        hFont = hNewFont
        hNewFont = 0
        '--- success
        GdipPrepareFont = True
    QH:
        If hNewFont <> 0 Then
            Call GdipDeleteFont(hNewFont)
            hNewFont = 0
        End If
        If hPrevFont <> 0 Then
            Call SelectObject(hDC, hPrevFont)
            hPrevFont = 0
        End If
        If hDC <> 0 Then
            Call ReleaseDC(0, hDC)
            hDC = 0
        End If
        Exit Function
    EH:
        Debug.Print Err.Description, FUNC_NAME
        Resume QH
    End Function
    It errors out with "Cannot load " & STR_FONTNAME

    Apparently GDI+ loads OS even provided fonts natively i.e. using it's own parsing code and .otf fonts are unsupported under Win7.

    The sample code above works in IDE here under Win11.

    cheers,
    </wqw>

  25. #25

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    I just tested this and it works
    Code:
     Dim res As Long
     res = InstallFont(App.path & "\PetalumaScript.otf")
     Text1.font.name = "PetalumaScript"
     Text1.font.size = 24
     Text1.Text = "My Test String"
    I was hoping I could take that font and load into GDI+

  26. #26

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    wqweto
    I will try your new code on my Win7 machine this evening (don't have access now)

  27. #27

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    wqweto
    Your "convert StdFont objects to GDI+ font handles" does not work on my Wib 7 set-up either... but I guess you knew that already
    I had to try for myself to be sure

    I'm confused however...
    you get "Cannot load Petaluma Script" error,
    I get "Missing Font Petaluma Script" error.
    Where was I supposed to place the font?

  28. #28
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,230

    Re: Private Font and GDI+

    > Where was I supposed to place the font?

    I usually drag&drop (or copy/paste) the .otf files to Control Panel->Fonts folder. I guess you could right click->Install font files in Explorer too.

    cheers,
    </wqw>

  29. #29

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    But point is, if user doesn't have access to System Fonts Folder (because of Administrator restrictions),
    he would put into a Private Fonts folder.
    For sake of testing, I was placing in app.path folder.

    With your code, I see no way to set the path.
    So when I run your code, it truly can't find the file I believe.
    Last edited by mms_; Apr 24th, 2024 at 07:09 AM.

  30. #30
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,230

    Re: Private Font and GDI+

    There are two helpers: GdipPrepareFont and GdipPreparePrivateFont. First one "converts" an StdFont object to GDI+ hFont, second one loads a font file directly and returns GDI+ hFont.

    For GdipPrepareFont parameter you'll need the font to be accessible to StdFont -- generally GDI fonts. I'm not sure you can use AddFontResource[Ex] to load a private font file for the process and have it available for usage as StdFont (might be possible, never done it).

    Your error message means that If oFont.Name <> STR_FONTNAME Then check is failing, most likely STR_FONTNAME is not available for usage as StdFont.

    Anyway, the sample above tests with Petaluma fonts installed in Control Panel->Fonts and is failing under Win7 so whether AddFontResource[Ex] works or not actually does not matter in this case.

    cheers,
    </wqw>

  31. #31

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    ok thanks

    So to test, I can just simply add 1 line, namely AddFontResource[Ex] to the start of Form_Initialize() in your code in post #24 ?

    I will test this evening on Win7 when I have access to computer

  32. #32

    Thread Starter
    Fanatic Member
    Join Date
    Nov 2018
    Posts
    658

    Re: Private Font and GDI+

    I can confirm that executing

    res = AddFontResourceEx(App.path & "\PetalumaScript.otf", FR_PRIVATE, 0&)

    directly before a call to wqweto's helper function GdipPrepareFont changes nothing,
    the otf font is not available for use with GDI+

    I will move on to possibility 1. convert file as suggested by fafalone (I will try on weekend)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width