The present sample shows how to install multiple font files with registration, the code is an adaptation from one of fafalone's snippet that displays multiple files properties.
Code:Private Declare Function SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp.IDataObject) As Long 'For Vista+ if you wanted: 'Public Declare Function SHCreateDataObject Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pdtInner As Any, riid As UUID, ppv As Any) As Long Private Declare Function SHMultiFileProperties Lib "shell32" (ByVal pdtobj As Long, ByVal dwFlags As Long) As Long Private Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long Private Declare Sub ILFree Lib "shell32" (ByVal pidl As Long) Sub InstallFontFiles() Dim pData As oleexp.IDataObject 'always explicitly type this with the parent Dim apidl() As Long Dim n As Long Dim i As Long Dim sFiles(0 To 1) As String sFiles(0) = "C:\Users\..\Barcode.ttf" sFiles(1) = "C:\Users\..\Sym15.ttf" ReDim apidl(UBound(sFiles)) If (UBound(sFiles) = 0) And (sFiles(0) = "") Then Exit Sub For i = 0 To UBound(sFiles) apidl(i) = ILCreateFromPathW(StrPtr(sFiles(i))) 'create a fully qualified pidl for each file Next i n = UBound(apidl) + 1 Call SHCreateFileDataObject(VarPtr(0), n, VarPtr(apidl(0)), ByVal 0&, pData) 'VarPtr(0) is always equal to the desktop's pidl Dim ShellExt As IShellExtInit, Menu As IContextMenu Dim c As CMINVOKECOMMANDINFO Set ShellExt = CreateObject("new:{1a184871-359e-4f67-aad9-5b9905d62232}") ' fontext ShellExt.Initialize 0, pData, 0 Set Menu = ShellExt c.cbSize = Len(c) Dim verb() As Byte verb = StrConv("Install", vbFromUnicode) c.lpVerb = VarPtr(verb(0)) Menu.InvokeCommand VarPtr(c) Set pData = Nothing For i = 0 To UBound(apidl) ILFree apidl(i) 'never forget to set your pidls free Next i End Sub




Reply With Quote