1 Attachment(s)
[VB6] Registering Fonts Through VB
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.
VB Code:
' 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
VB Code:
' 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
Re: [VB6] Registering Fonts Through VB
Hi trying to register a font which is going to be used by my application and the user.
I have my script exactly doing the same as you have mentioned.
The problem I am facing is that when ever I register a font, though it can be seen along with list of other fonts, it can not be activated by choosing manually by the user. But my application can access the font and use it appropriately. The only way the user can use the registered font is by restarting the computer. This is not the case when manually place the font at windows/fonts folder.
Can some one help me understand what is going wrong and help me fix my problem. Your help is greatly appreciated. Thanks.