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.
