[VBS] Automatically Install Fonts

[Mike88]

HI,

Would it be possible to modify this VBScript so that it would automatically install all Fonts located in the same folder as the VBScript with the Font file extensions .fon, .pfm, .ttc, .ttf, .otf?

Const FONTS = &H14&Set objShell = CreateObject("Shell.Application")Set objFolder = objShell.Namespace(FONTS)objFolder.CopyHere "C:\Scripts\HandelGotD1.ttf"objFolder.CopyHere "C:\Scripts\HandelGotD2.fon"

Edited April 10, 2015 by Mike88

[gunsmokingman]

How are you naming the all the fonts?

[Mike88]

The naming of the font files will have all kinds of names.

The script should scan the folder where it was executed for the Font file extensions .fon, .pfm, .ttc, .ttf, .otf and then install this Fonts like the script above with "objFolder.CopyHere".

Edited April 9, 2015 by Mike88

[gunsmokingman]

I have only tested the filter and not the copy function. You will have to edit this to suit your needs.

Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")'-> Start Folder Where Script Is Located And List All Files  For Each i In Fso.GetFolder(".").Files '-> Filter Out The Files Change To Suit Your Needs   If LCase(Right(i.Name,3)) = "vbs" Then    FontCopy(i.Path)   End If    If LCase(Right(i.Name,3)) = "txt" Then    FontCopy(i.Path)   End If  Next '-> Copy The File To The Font Folder   Function FontCopy(F)    Const FONTS = &H14    Dim Shl :Set Shl = CreateObject("Shell.Application")    Dim Obj :Set Obj = Shl.Namespace(FONTS)    Obj.CopyHere F   End Function 

[Mike88]

The script works when i manually execute it but when it is being executed with a Batch file which is not located in the same folder as the VBScript then the VBScript won't work.

Edited April 10, 2015 by Mike88

[DosProbie]

The script works when i manually execute it but when it is being executed with a Batch file which is not located in the same folder as the VBScript then the VBScript won't work.

could be a Admin issue as well, so either add a admin script to the vbs or your batch and try it that way.

~DP

[Mike88]

I also run it on Windows XP with an Admin account and it didnt work with the Batch script.

[bphlpt]

To get more help in debugging this issue, you will probably need to provide a little more info, such as:

 

-- OS involved - I assumed Win7 x64, but you mentioned XP as well above, so...

-- Please post the VBScript as you ended up modifying it, and specify exactly where you place the script and the fonts you are trying to install.

-- Please post the batch script that you are using to call the font-install script, and specify exactly where it is located and when you are trying to run it - at OS install, at every OS boot, on demand, or what?

-- Anything else you can think of.

 

Cheers and Regards

[Mike88]

I really didn't change much at all. The script simply won't work when executing it via a Batch file which is located in another folder. And i tested it on Win7 x64 and WinXP x86.

 

Batch:

IF EXIST "New folder\Fonts Installer.vbs" START "" /WAIT "New folder\Fonts Installer.vbs"

VBScript:

Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")'-> Start Folder Where Script Is Located And List All Files  For Each i In Fso.GetFolder(".").Files'-> Filter Out The Files Change To Suit Your Needs   If LCase(Right(i.Name,3)) = "fon" Then    FontCopy(i.Path)   End If   If LCase(Right(i.Name,3)) = "otf" Then    FontCopy(i.Path)   End If   If LCase(Right(i.Name,3)) = "pfm" Then    FontCopy(i.Path)   End If   If LCase(Right(i.Name,3)) = "ttf" Then    FontCopy(i.Path)   End If  Next'-> Copy The File To The Font Folder   Function FontCopy(F)    Const FONTS = &H14&    Dim Shl :Set Shl = CreateObject("Shell.Application")    Dim Obj :Set Obj = Shl.Namespace(FONTS)    Obj.CopyHere F   End FunctionWScript.Quit

Edited April 10, 2015 by Mike88

[bphlpt]

-- Please post the VBScript as you ended up modifying it, and specify exactly where you place the script and the fonts you are trying to install.

-- Please post the batch script that you are using to call the font-install script, and specify exactly where it is located and when you are trying to run it - at OS install, at every OS boot, on demand, or what?

 

Not that I will necessarily be able to help directly, but It seems these things might be important.

 

And what does "not work" mean?  Anything at all happen?  Any error message?  Are the fonts moved and just not registered, or are they not moved at all?  If nothing happens, how do you know that the script was even called?  Have you tried adding "echo" statements to verify that the script is run?

 

Cheers and Regards

Edited April 10, 2015 by bphlpt

[Mike88]

Well i found a workaround for it, i completely forgot about the Batch START command /D which can set the Working Directory.

This Batch code is wokring: 

IF EXIST "New folder\Fonts Installer.vbs" START "" /D "New folder" /WAIT "New folder\Fonts Installer.vbs"

Edited April 10, 2015 by Mike88

[gunsmokingman]

You might want to try this script it uses 2 for each loops and only one If end if.

 

Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")'-> Array To Hold The File TypeDim i, j, v: v = Array("fon","otf","pfm","ttf")'-> Start Folder Where Script Is Located And List All Files   For Each i In Fso.GetFolder(".").Files    For Each j In v '-> Filter Out The Files Type From Array v    If LCase(Right(i.Name,3)) = j Then     FontCopy(i.Path)    End If    Next   Next '-> Copy The File To The Font Folder   Function FontCopy(F)    Const FONTS = &H14&        Dim Shl :Set Shl = CreateObject("Shell.Application")    Dim Obj :Set Obj = Shl.Namespace(FONTS)    Obj.CopyHere F   End Function 

[Mike88]

This one also works without a problem.

But what i noticed is, could the script not run into a conflict when using it on a Windows where the text is displayed from "Right to Left" instead of "Left to Right"?

Edited April 11, 2015 by Mike88

[gunsmokingman]

This one filter out the file type

Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")Dim i'-> Start Folder Where Script Is Located And List All Files   For Each i In Fso.GetFolder(".").Files '-> Filter Out The Files     If i.Type = "TrueType font file" Then     FontCopy(i.Path)   End If   Next '-> Copy The File To The Font Folder   Function FontCopy(F)    Const FONTS = &H14&        Dim Shl :Set Shl = CreateObject("Shell.Application")    Dim Obj :Set Obj = Shl.Namespace(FONTS)    Obj.CopyHere F   End Function  

[Mike88]

Well i think with this one we will get a Windows Language conflict.

Would this be helpful to make it work?

http://stackoverflow.com/questions/4200028/vbscript-list-all-pdf-files-in-folder-and-subfolders

http://stackoverflow.com/questions/12235993/scan-folder-and-list-only-image-files-with-vbscript

Edited April 11, 2015 by Mike88