Solved

Install font in VB5

Posted on 1998-07-11
2
418 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
Comment Utility
Edited text of question
0
 
LVL 4

Accepted Solution

by:
yowkee earned 100 total points
Comment Utility
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

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

763 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