[VB6] Registering Fonts Through VB

[sciguyryan]

Hi all,

I am shure I have seen this asked before so, I came up with a little function to do this. This is in two parts, the definitions used for the API calls and then the function its self.

' These are the definitions. Put these at the top of your form.
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _ 
    ByVal hwndOwner As Long, _ 
    ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _ 
    ByVal pidl As Long, _ 
    ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _ 
    ByVal hwnd As Long, _ 
    ByVal wMsg As Long, _ 
    ByVal wParam As Long, _ 
    lParam As Any) As Long
Private Declare Function AddFontResource Lib "gdi32.dll" Alias "AddFontResourceA" ( _ 
    ByVal lpFileName As String) As Long
 
Private Const CSIDL_FONTS = &H14
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
 
Private Type ITEMID 
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As ITEMID 
End Type
 
Private Function GetSpecialFolder(lngCSIDL As Long) As String
    Dim lngRet As Long
    Dim strPath As String
    Dim IDL As ITEMIDLIST
    lngRet = SHGetSpecialFolderLocation(100, lngCSIDL, IDL)
    If lngRet = 0 Then
        strPath = Space$(512)
        lngRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal strPath)
        GetSpecialFolder = Left$(strPath, InStr(strPath, Chr$(0)) - 1)
        Exit Function
    End If
    GetSpecialFolder = ""
End Function

' This is the function.
Private Function RegisterFont(strFontLocation As String) As Boolean
    Dim lngRet As Long
    Dim intLen As Integer
    Dim strFonts As String
    Dim strParts() As String
    If Dir$(strFontLocation) <> "" Then
        strFonts = GetSpecialFolder(CSIDL_FONTS) & "\"
        strParts = Split(strFontLocation, "\")
        intLen = UBound(strParts)
        FileCopy strFontLocation, strFonts & strParts(intLen)
        lngRet = AddFontResource(strFonts & strParts(intLen))
        If lngRet > 0 Then
            SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
            RegisterFont = True ' Success
         Else
             RegisterFont = False ' Error
         End If
    Else
        RegisterFont = False ' Error
        Exit Function
    End If
End Function

One warning, you must validate all inputs before you use this or it may reak the code and give an error.

Any problems, just post here


Edit: Added a BAS file (Attatched) to add more features. Add and remove fonts now supported also some checking has been preformed

Cheers,

RyanJ