Solved

Install font in VB5

Posted on 1998-07-11
2
419 Views
Last Modified: 2013-12-03
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
Comment
Question by:dalia
2 Comments
 

Author Comment

by:dalia
ID: 1465493
Edited text of question
0
 
LVL 4

Accepted Solution

by:
yowkee earned 100 total points
ID: 1465494
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Paint/Redraw window while dragging 16 68
Modifying Conditional Format from VBA code 3 49
Problem to With line 4 42
VB 6 error 5 in windows 10 but not in XP 7 44
Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

920 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now