Multiple font files installation and registration

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

---