Question

我有一个工作代码可以安装字体但不是永久性的，并且无法在控制面板的字体列表中看到。那么如何以编程方式永久安装字体？

以下是我正在使用的代码：

If Not CustomFont.IsFontInstalled("Monotype Corsiva") = True Then
    Dim FontPath As String = My.Computer.FileSystem.SpecialDirectories.Temp & "\Monotype Corsiva.ttf"
    Dim Ret As Integer
    Dim Res As Integer
    Const WM_FONTCHANGE As Integer = &H1D
    Const HWND_BROADCAST As Integer = &HFFFF
    System.IO.File.WriteAllBytes(FontPath, My.Resources.Monotype_Corsiva)
    Ret = AddFontResource(FontPath)
    Res = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
    Ret = WriteProfileString("fonts", "Monotype Corsiva (TrueType)", "Monotype Corsiva.ttf")
    MsgBox("Font installed")
End If

这是模块：

Imports System.Drawing.Text
Imports System.Runtime.InteropServices
Module CustomFont
    <DllImport("gdi32")>
    Public Function AddFontResource(ByVal lpFileName As String) As Integer
    End Function
    <DllImport("user32.dll")>
    Public 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)>
    Public Function WriteProfileString(ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Integer
    End Function
    'PRIVATE FONT COLLECTION TO HOLD THE DYNAMIC FONT
    Private _pfc As PrivateFontCollection = Nothing
    Public ReadOnly Property GetInstance(ByVal Size As Single, ByVal style As FontStyle) As Font
        Get
            'IF THIS IS THE FIRST TIME GETTING AN INSTANCE
            'LOAD THE FONT FROM RESOURCES
            If _pfc Is Nothing Then LoadFont()

            'RETURN A NEW FONT OBJECT BASED ON THE SIZE AND STYLE PASSED IN
            Return New Font(_pfc.Families(0), Size, style) ',Style
        End Get
    End Property
    Private Sub LoadFont()
        Try
            'INIT THE FONT COLLECTION
            _pfc = New PrivateFontCollection
            'LOAD MEMORY POINTER FOR FONT RESOURCE
            Dim fontMemPointer As IntPtr = Marshal.AllocCoTaskMem(My.Resources.Monotype_Corsiva.Length)
            'COPY THE DATA TO THE MEMORY LOCATION
            Marshal.Copy(My.Resources.Monotype_Corsiva, 0, fontMemPointer, My.Resources.Monotype_Corsiva.Length)
            'LOAD THE MEMORY FONT INTO THE PRIVATE FONT COLLECTION
            _pfc.AddMemoryFont(fontMemPointer, My.Resources.Monotype_Corsiva.Length)
            'FREE UNSAFE MEMORY
            Marshal.FreeCoTaskMem(fontMemPointer)
        Catch ex As Exception
            'ERROR LOADING FONT. HANDLE EXCEPTION HERE
        End Try
    End Sub
    Public Function IsFontInstalled(ByVal font As String) As Boolean
        Dim FontCollection = New InstalledFontCollection
        Dim Result As Boolean = False
        For Each FontFamily In FontCollection.Families
            If FontFamily.Name = font Then
                Result = True
            End If
        Next
        Return Result
    End Function
End Module

那么可以永久安装字体吗？这段代码似乎安装了字体，但只是在当前会话中使用。如果重新启动设备，则该字体将不再可用。

我只想加快程序启动。

安装字体VB

0 个答案: