Installare font da VB/VBScript

Prende tutti i font in una cartella su un server e li installa sul client, se:
- non esistono sul client
- il file ha estensione .ttf o .otf

function GetOsName

 Dim objWMI, objItem, colItems
 Dim strComputer, VerBig, OSystem

 ' Here is where we interrogate the Operating System
 ' On Error Resume Next

 ' Get the computer name dot = this computer.
 strComputer = "."
 ' This is where WMI interrogates the operating system
 Set objWMI = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

 Set colItems = objWMI.ExecQuery("Select * from Win32_OperatingSystem",,48)

 ' Here we filter Version from the dozens of properties
 For Each objItem in colItems
  VerBig = Left(objItem.Version,3)
 Next

 ' Spot VerBig variable in previous section
 ' Note the output variable is called OSystem

 Select Case VerBig
  Case "6.2" OSystem = "8"
  Case "6.1" OSystem = "7"
  Case "6.0" OSystem = "Vista"
  Case "5.2" OSystem = "2003"
  Case "5.1" OSystem = "XP"
  Case "5.0" OSystem = "2000"
  Case "4.0" OSystem = "NT"
  'Case Else OSystem = "Unknown - probably Win 9x"
  case Else OSystem = ""
 End Select

 Set objWMI = nothing
 Set colItems = nothing

 GetOsName = OSystem

end function


function installaFont()

 ' http://www.bohack.com/2012/09/installing-fonts-on-windows-7-from-a-vbscript/

 const fileCopyOverwrite = true

 dim wShell
 dim clientDir, serverDir
 dim fs, fsoFolder, file
 dim wApp, appFolder, currentFile
 dim ext
 dim wFrom, wTo
 dim appClientFolder
 dim hoFattoQualcosa
 dim os
 dim s

 installaFont = false
 
 hoFattoQualcosa = false

 Set wShell = Wscript.CreateObject("Wscript.Shell")
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set wApp = CreateObject("Shell.Application")


 clientDir = wShell.SpecialFolders("Fonts")
 serverDir = "\\your\server\path\to\Fonts"


 Set appFolder = wApp.Namespace(serverDir)
 Set fsoFolder = fs.GetFolder(serverDir)

 os = GetOsName

 For each file In fsoFolder.Files
  ' -- INSTALLA SOLO I FONT MANCANTI
  If Not fs.FileExists(clientDir & "\" & file.Name) Then
   
   Set currentFile = appFolder.ParseName(file.name)
   ext = lcase(right(currentFile, 4))

   if ext = ".ttf" or ext = ".otf" then
    select case os
     case "7"
      currentFile.InvokeVerb("Install")
      hoFattoQualcosa = true

     case "XP"
      wFrom = serverDir & "\" & currentFile
      wTo = clientDir & "\" & currentFile
  
      fs.CopyFile wFrom, wTo, fileCopyOverwrite
      hoFattoQualcosa = true

     case else
      s = ""
      s = s & "Impossibile installare il font ''" & ucase(replace(file.name, ext, "")) & "'': "
      s = s & "sistema operativo ''" & os & "'' non supportato dall'installazione."

      msgbox s, vbInformation, titoloApp
      installaFont = false
      exit function

    end select
   end if
  End If
 Next


 if hoFattoQualcosa then
  select case os
   case "XP"
   ' -- APRE LA DIRECTORY DEI FONT, ALTRIMENTI NON SONO "VISTI" DALLE APPLICAZIONI:
   ' -- FACENDO COSI', FA UN "REFRESH"
   set appClientFolder = wApp.Namespace(clientDir).self
   appClientFolder.invokeVerb("open")
   set appClientFolder = nothing
 
  end select
 end if



 Set currentFile = Nothing
 set wShell = nothing
 Set appFolder = Nothing
 Set wApp =  Nothing
 Set fsoFolder = Nothing
 Set fs = Nothing

 installaFont = true

End function

Note:
- su Win7 basta richiamare il verbo "installa"
- su WinXP non c'è tale verbo, quindi copio il file a mano nella cartella di sistema e poi la apro, per "forzare" una sorta di refresh dei font, altrimenti le applicazioni (es: Office2010) non "vedono" i nuovi font



Farina del mio sacchetto, ma basato sullo script trovato qui.