Código: Selecionar todos
' Instalador automatizado de fontes do Windows
' Suporta fontes .otf e .ttf
' Retirado do fórum ITBR.ORG
' http://itbr.org
Option Explicit
Dim objShell, objFSO, wshShell
Dim strFontSourcePath, objFolder, objFont, objNameSpace, objFile
Set objShell = CreateObject("Shell.Application")
Set wshShell = CreateObject("WScript.Shell")
Set objFSO = createobject("Scripting.Filesystemobject")
' Informe o caminho das fontes
strFontSourcePath = "\\FILESERVER\SHARE\Fontes\"
If objFSO.FolderExists(strFontSourcePath) Then
If objFSO.FolderExists("C:\Users\") Then
' Inicia Windows 7/8
Set objNameSpace = objShell.Namespace(strFontSourcePath)
Set objFolder = objFSO.getFolder(strFontSourcePath)
For Each objFile In objFolder.files
If LCase(right(objFile,4)) = ".ttf" OR LCase(right(objFile,4)) = ".otf" Then
Set objFont = objNameSpace.ParseName(objFile.Name)
If objFSO.FileExists("C:\WINDOWS\Fonts\" & objFile.Name) = False Then
objFont.InvokeVerb("Install")
Set objFont = Nothing
Else
End If
End If
Next
Else
' Inicia Windows XP
Set objNameSpace = objShell.Namespace(strFontSourcePath)
Set objFolder = objFSO.getFolder(strFontSourcePath)
For Each objFile In objFolder.files
If LCase(right(objFile,4)) = ".ttf" OR LCase(right(objFile,4)) = ".otf" Then
Set objFont = objNameSpace.ParseName(objFile.Name)
If objFSO.FileExists("C:\WINDOWS\Fonts\" & objFile.Name) = False Then
objFSO.CopyFile strFontSourcePath & objFile.Name, "c:\WINDOWS\fonts\"
Set objFont = Nothing
Else
End If
End If
Next
End If
Else
Wscript.Echo "Não foi possível encontrar o diretório de fontes."
End IF