Andy Andromeda
Andy Andromeda

Reputation: 65

AddFontResource / PrivateFontCollection doesn't make the font immediately available for use in my application

I'm trying to use a PrivateFontCollection for my application, so it can print a document with a specific font. note that i can not "install" the font as the Windows directory is admin protected.

The code I have works, in the sense that provided I close my application, and restart it, when i restart it, it will recognise that the font is there and can be used. But if I click the command button to install the font as a privatefontcollection, and then refresh my PrintDocument, it does not show it using the newly installed font. I have to close the app and open it, and then it does.

    Public Shared Function AddFontResource(ByVal lpFileName As String) As Integer
    End Function

    <DllImport("user32.dll")>
    Public Shared Function SendMessage(ByVal hWnd As Integer, ByVal Msg As UInteger, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
    End Function

    <DllImport("kernel32.dll", SetLastError:=True)>
    Shared Function WriteProfileString(ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Integer
    End Function

    <DllImport("user32.dll", SetLastError:=True)>
    Public Shared Function SendMessageTimeout(ByVal hWnd As IntPtr,
                                          ByVal msg As Integer,
                                          ByVal wParam As IntPtr,
                                          ByVal lParam As IntPtr,
                                          ByVal flags As SendMessageTimeoutFlags,
                                          ByVal timeout As Integer,
                                          ByRef result As IntPtr) As IntPtr
    End Function
    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
    Public Shared Function SendNotifyMessage(
     ByVal hWnd As IntPtr,
     ByVal msg As UInteger,
     ByVal wParam As UIntPtr,
     ByVal lParam As IntPtr
     ) As Boolean
    End Function

    <Flags()>
    Public Enum SendMessageTimeoutFlags
        SMTO_NORMAL = 0
        SMTO_BLOCK = 1
        SMTO_ABORTIFHUNG = 2
        SMTO_NOTIMEOUTIFNOTHUNG = 8
    End Enum
    Private Sub RibbonButton1_Click(sender As Object, e As EventArgs) Handles RibbonButton1.Click

        Try
            If IsFontInstalled("Open Sans ExtraBold") = False Then
                Dim Fonts_Source As String = Path.Combine(Application.StartupPath, "Resources\OpenSans-ExtraBold.ttf")
                Dim Fonts_Install As String = My.Computer.FileSystem.CombinePath(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), "OpenSans-ExtraBold.ttf")

                Dim Ret As Integer
                Dim Res As Integer
                Dim FontPath As String

                Const WM_FONTCHANGE As Integer = &H1D
                Const HWND_BROADCAST As Integer = &HFFFF

                FontPath = Fonts_Install.ToString

                Ret = AddFontResource(Fonts_Source.ToString)

                Res = SendMessageTimeout(HWND_BROADCAST, WM_FONTCHANGE, IntPtr.Zero, IntPtr.Zero,
                                         SendMessageTimeoutFlags.SMTO_ABORTIFHUNG Or
                                         SendMessageTimeoutFlags.SMTO_NOTIMEOUTIFNOTHUNG,
                                         5000, IntPtr.Zero)
                Ret = WriteProfileString("Fonts", Path.GetFileName(FontPath) & " (TrueType)", FontPath.ToString)

            End If
            
        Catch ex As Exception
            MsgBox("Error: " & ex.Message)
        End Try

    End Sub

This next subroutine is the one that draws the document. I have a function to check if the font is installed, and if its not then the an alternative font is used.

Dim TitleFont As New Font("Segoe UI Black", Font48Pt, FontStyle.Bold)
       If IsFontInstalled("Open Sans ExtraBold") = True Then TitleFont = New Font("Open Sans ExtraBold", Font48Pt)
       

       If Title <> "Everyday" Then
           'TITLE TEXT DRAWN
           Dim TitleRect As RectangleF = New RectangleF()
           TitleRect.Location = New Point(20, 25)
           TitleRect.Size = New Size(DrawWidth, CInt(e.Graphics.MeasureString(Title, TitleFont, DrawWidth, CenterAlignment).Height))
           e.Graphics.DrawString(Title, TitleFont, ForeColourBrush, TitleRect, CenterAlignment)
       End If

the function that checks if the font is installed.

Public Function IsFontInstalled(ByVal FontName As String) As Boolean
        Using TestFont As Font = New Font(FontName, 10)
            Return CBool(String.Compare(FontName, TestFont.Name, StringComparison.InvariantCultureIgnoreCase) = 0)
        End Using
    End Function

this function above could be the problem as it returns false. mind you if I close the app and restart it, then this same function will then detect the privatefontcollection and return true, and I can successfully print my document with my font.

I did try adding the install font subroutine, to the very start of my app. then raising a flag if a font was installed and then tried to call the Application.Restart() method, so that while the splash screen was up it could install the font, then immediately restart the app, which of course would then latch onto the installed font, but this method just left the app in a loop of opening and closing.

Upvotes: 1

Views: 263

Answers (0)

Related Questions