1

我正在尝试为我的应用程序使用 PrivateFontCollection，以便它可以打印具有特定字体的文档。请注意，我无法“安装”字体，因为 Windows 目录受管理员保护。

我的代码可以工作，只要我关闭我的应用程序并重新启动它，当我重新启动它时，它会识别出字体在那里并且可以使用。但是，如果我单击命令按钮将字体安装为 privatefontcollection，然后刷新我的 PrintDocument，它不会使用新安装的字体显示它。我必须关闭应用程序并打开它，然后它就可以了。

    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

下一个子程序是绘制文档的子程序。我有一个功能来检查字体是否已安装，如果没有，则使用替代字体。

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

检查字体是否已安装的功能。

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

上面的这个函数可能是问题，因为它返回 false。请注意，如果我关闭应用程序并重新启动它，那么这个相同的函数将检测 privatefontcollection 并返回 true，我可以使用我的字体成功打印我的文档。

我确实尝试将安装字体子例程添加到我的应用程序的开头。然后如果安装了字体则引发一个标志，然后尝试调用 Application.Restart() 方法，以便在启动画面启动时它可以安装字体，然后立即重新启动应用程序，这当然会锁定到安装了字体，但这种方法只是让应用程序处于打开和关闭的循环中。

4

0 回答 0