[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 438
  • Last Modified:

Install font in VB5

How can I install a new  font using VB5?

What are the return values I get when:
    1. Font installed successfully
    2. Font is already installed on the system
    3. Font file does not exist (or incorrect file name given)
    4. Font could not be installed successfully

Note: I want this to be done using API (AddFontResource).

Thank you.
0
dalia
Asked:
dalia
1 Solution
 
daliaAuthor Commented:
Edited text of question
0
 
yowkeeCommented:
dialia,

  Following is the code to add font in Win95. First, you must copy the font file to C:\<windows directory>\fonts, then the funtion will call AddFontResource to add the specified font. If there is no error, write info to registry for permenant install and broadcast message to inform new font installation.

  The API AddFontResource will return 0 while error. For getting the error number, we must call GetLastError after AddFontResource to obtain the win32 error code. Following example will use FormatMessage to show the error message(and it should include the error list in your question.)

  Hope this helps. :)

------ ' Code in Form
Declare Function GetLastError Lib "kernel32" () As Long

Private Declare Function PostMessage Lib "user32" _
       Alias "PostMessageA" (ByVal hWnd As Long, ByVal _
       wMsg As Long, ByVal wParam As Long, ByVal _
       lParam As Long) As Long

Private Declare Function AddFontResource Lib "gdi32" _
       Alias "AddFontResourceA" (ByVal lpFilename As _
       String) As Long

Private Declare Function CreateScalableFontResource _
       Lib "gdi32" Alias "CreateScalableFontResourceA" _
       (ByVal fHidden As Long, ByVal lpszResourceFile _
       As String, ByVal lpszFontFile As String, ByVal _
       lpszCurrentPath As String) As Long

Private Declare Function RemoveFontResource Lib _
       "gdi32" Alias "RemoveFontResourceA" (ByVal _
       lpFilename As String) As Long

Private Declare Function GetWindowsDirectory Lib _
       "kernel32" Alias "GetWindowsDirectoryA" (ByVal _
       lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function GetSystemDirectory Lib _
       "kernel32" Alias "GetWindowsDirectoryA" (ByVal _
       lpBuffer As String, ByVal nSize As Long) As Long
       

Private Declare Function RegSetValueEx Lib _
       "advapi32.dll" Alias "RegSetValueExA" (ByVal _
       hKey As Long, ByVal lpValueName As String, _
       ByVal Reserved As Long, ByVal dwType As Long, _
       lpData As Any, ByVal cbData As Long) As Long

Private Declare Function RegOpenKey Lib _
       "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey _
       As Long, ByVal lpSubKey As String, phkResult _
       As Long) As Long

Private Declare Function RegCloseKey Lib _
       "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegDeleteValue Lib _
       "advapi32.dll" Alias "RegDeleteValueA" (ByVal _
       hKey As Long, ByVal lpValueName As String) As Long

Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
Private Const MAX_PATH = 260
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1 ' Unicode null terminated string

Private Sub Add32Font(Filename As String)

    Dim lResult As Long
    Dim strFontPath As String, strFontname As String
    Dim hKey As Long
    '     'This is the font name and path
    strFontPath = Space$(MAX_PATH)
    strFontname = Filename

        'Win95 - Call and get the path to the
        '\windows\fonts directory
        lResult = GetWindowsDirectory(strFontPath, _
        MAX_PATH)

        If lResult <> 0 Then Mid$(strFontPath, _
               lResult + 1) = "\fonts\"
               strFontPath = RTrim$(strFontPath)
        End If

        'This Actually adds the font to the system's available
        'fonts for this windows session
        lResult = AddFontResource(strFontPath + strFontname)
        If lResult = 0 Then
            MsgBox "Error Occured When Calling AddFontResource" + vbNewLine + _
                   GetLastErrorStr(GetLastError)
            Exit Sub
        End If
       
         'Write the registry value to permanently install the
         'font
        lResult = RegOpenKey(HKEY_LOCAL_MACHINE, _
        "software\microsoft\windows\currentversion\" & _
        "fonts", hKey)
        lResult = RegSetValueEx(hKey, "Proscape Font " & strFontname & _
        " (TrueType)", 0, REG_SZ, ByVal strFontname, _
        Len(strFontname))
        lResult = RegCloseKey(hKey)
        'This call broadcasts a message to let all top-level
        'windows know that a font change has occured so they
        'can reload their font list
        lResult = PostMessage(HWND_BROADCAST, WM_FONTCHANGE, _
        0, 0)
        MsgBox "Font Added!"

End Sub


--------' Code in module (For FormatMessage)
Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
                            (ByVal dwFlags As Long, lpSource As Any, _
                            ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
                            ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
 
Public Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Public Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Public Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Public Const FORMAT_MESSAGE_FROM_STRING = &H400
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Public Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Public Const LANG_USER_DEFAULT = &H400&
 

Function GetLastErrorStr(dwErrCode As Long) As String
' Rtns system error string associated w/ the given error code.
' Err.LastDllError (not GetLastError!!) must be used to fill the dwErrCode param

  ' Let VB alloc the buffer. If FORMAT_MESSAGE_ALLOCATE_BUFFER
  ' was used, the lpBuffer param (sMsgBuf) would have to be a long pointer
  ' to the buffer & would then have to be freed when we're done.
  ' 256 chars is the maximun length for a resource string (+ 1 for the null char)
  Static sMsgBuf As String * 257, dwLen As Long

  ' Fills sMsgBuf w/ the system error string & rtns it's length;
  ' FORMAT_MESSAGE_IGNORE_INSERTS must be used as there are
  ' many system error strings that contain inserts (replacable parameters);
  ' There are also a few random length multi-line error strings,
  ' FORMAT_MESSAGE_MAX_WIDTH_MASK rtns them as one line
  dwLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _
                                      Or FORMAT_MESSAGE_IGNORE_INSERTS _
                                      Or FORMAT_MESSAGE_MAX_WIDTH_MASK, ByVal 0&, _
                                      dwErrCode, LANG_USER_DEFAULT, _
                                      ByVal sMsgBuf, 256&, 0&)

  If dwLen Then
    GetLastErrorStr = Left$(sMsgBuf, dwLen)
  Else
    GetLastErrorStr = "Unknown error."
  End If
-----------


End Function

0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Tackle projects and never again get stuck behind a technical roadblock.
Join Now