Solved

Need to remove popup windows when running vb script

Posted on 2011-09-13
10
791 Views
Last Modified: 2012-05-12
I am using the following code below to add fonts.  It works fine except for two problems... it will give a message if the font is already installed and it will pop up a window showing that a font is being installed.

The window showing the font being installed just goes away (you don't have to click on it) so I'm thinking if it was hidden, that would work.  The window that pops up showing the fonts that are already installed requires that you click Yes or No so I'm thinking there needs to be a check to see if the font already exists in the C:\Windows\Font folder.  Any help would be greatly appreciated!
Option Explicit

Const FONTS = &H14&

Const ForAppending = 8

Dim fso
Dim objShell
Dim objFontFolder
Dim oShell
Dim objDictionary
Dim strSystemRootDir
Dim strFontDir
Dim strTempDir
Dim f1
Dim doExist
Dim dontExist
Dim yesToAll
Dim noProgressDialog
Dim noUIIfError

' Initialize Global Objects

Set objShell = CreateObject("Shell.Application")
Set objFontFolder = objShell.Namespace(FONTS)
Set oShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set objDictionary = CreateObject("Scripting.Dictionary")


' Initialize Global Variables
strSystemRootDir = oShell.ExpandEnvironmentStrings("%systemroot%")
strFontDir = strSystemRootDir & "\fonts\"
strTempDir = oShell.ExpandEnvironmentStrings("%systemroot%") & "\temp"
objDictionary.CompareMode = vbTextCompare
noProgressDialog = 4
yesToAll = 16
noUIIfError = 1024

' Execute Main Sub-routine
Main

'===================================================================

Public Sub Main()

'===================================================================
    Dim pwd
    Dim rootFontInstallFolder
    Dim param
    
    Set f1 = fso.createTextFile(strTempDir & "\installed_fonts.txt", ForAppending)
    pwd = fso.GetAbsolutePathName(".")
    
    ' Default to the current folder
    rootFontInstallFolder = pwd
    
    If Wscript.Arguments.Count = 1 Then
        param = Wscript.Arguments(0)
        If fso.FolderExists(param) Then
            rootFontInstallFolder = param
        End If
    End If
    
    doExist = 0
    
    dontExist = 0
    
    CollectFonts
    
    InstallFonts rootFontInstallFolder ' insert path here to font folder
    
    'wscript.echo doExist & " fonts already installed." & vbcrlf & dontExist & " new fonts installed."
    
End Sub



'===================================================================

Public Sub CollectFonts()

'===================================================================

    Dim fontFolderPath
    Dim fontFolder
    Dim fileName
    Dim fileExtension
    Dim filePath
    Dim oFile
    Dim firstFileName
    Dim firstFilePath
    Dim objItem
    
    firstFilePath = objFontFolder.Items.Item(0).Path
    firstFileName = objFontFolder.Items.Item(0).Name
    fontFolderPath = Replace(firstFilePath, "\" & firstFileName, "")
    Set fontFolder = fso.getFolder(fontFolderPath)
    
    
    For Each oFile In fontFolder.Files
        filePath = oFile.Path
        fileName = LCase(oFile.Name)
        fileExtension = LCase(fso.GetExtensionName(filePath))
        
        If fileExtension = "ttf" Or _
            fileExtension = "otf" Or _
            fileExtension = "pfm" Or _
            fileExtension = "fon" Then
            If Not objDictionary.Exists(fileName) Then
                objDictionary.Add fileName, fileName
            End If
        End If
    Next
    
    For Each objItem In objDictionary
        f1.writeline objDictionary.Item(objItem)
    Next

End Sub



'===================================================================

Public Sub InstallFonts(ByVal folder)

'===================================================================
    Dim fontInstallFolder
    
    Dim fileExtension
    Dim fileName
    Dim file
    Dim subFolder
    
    Set fontInstallFolder = fso.getFolder(folder)
    
    
    For Each file In fontInstallFolder.Files
        fileExtension = LCase(fso.GetExtensionName(file))
        fileName = LCase(fso.GetFileName(file))
        
        If fileExtension = "ttf" Or _
            fileExtension = "otf" Or _
            fileExtension = "pfm" Or _
            fileExtension = "fon" Then
            
            'check if Font is Already installed. If not, Install
            If objDictionary.Exists(fileName) Then
                'wscript.echo fileName & " already exists in " & strFontDir
                doExist = doExist + 1
            Else
                'wscript.echo fso.GetAbsolutePathName(File) & " doesn't exists in " & strFontDir
                objFontFolder.CopyHere file.Path, noProgressDialog + yesToAll + noUIIfError
                dontExist = dontExist + 1
            End If
        End If
    Next
    ' This recurses through subfolders and installs fonts in them
    For Each subFolder In fontInstallFolder.subFolders
        InstallFonts subFolder
    Next
End Sub

Open in new window

0
Comment
Question by:bpl5000
  • 5
  • 5
10 Comments
 
LVL 65

Expert Comment

by:RobSampson
ID: 36533634
You might like to try changing these:
noProgressDialog = 4
yesToAll = 16
noUIIfError = 1024

to this:
noProgressDialog = &H4&
yesToAll = &H10&
noUIIfError = &H400&

but I suspect there's a bug in it that doesn't obey the options.

Regards,

Rob.
0
 
LVL 5

Author Comment

by:bpl5000
ID: 36536034
Ok, thanks, but what I'm more concerned about is that the code is trying to install fonts that are already installed.  It does seem to be checking the font against objDictionary, but I'm not sure what objDictionary is?  Seems like a check should be done to see if the file exists in C:\windows\fonts and I don't see that being done.
0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 36539516
It is checking for the file name with this bit:
            'check if Font is Already installed. If not, Install
            If objDictionary.Exists(fileName) Then
                'wscript.echo fileName & " already exists in " & strFontDir
                doExist = doExist + 1
            Else
                'wscript.echo fso.GetAbsolutePathName(File) & " doesn't exists in " & strFontDir
                objFontFolder.CopyHere file.Path, noProgressDialog + yesToAll + noUIIfError
                dontExist = dontExist + 1
            End If

Open in new window


For further testing, uncomment the wscript.echo lines there and see if the file is shown as already existing.

I have seen however, that some fonts can have a different file name, but the same font name, which can cause problems.  If you still have issues, I'll have to see if it's possible to check the "font name" first.

Regards,

Rob.
0
 
LVL 5

Author Comment

by:bpl5000
ID: 36539861
But I don't think that objDictionary has anything to do with the fonts located in c:\windows\fonts.  It seems to me that the code adds your fonts to objDictionary...

objDictionary.Add fileName, fileName

It seems to me that it is only checking to see if you are trying to add the same font twice and not checking to see if your font is already in c:\windows\fonts".  Unless I'm misunderstanding the code.
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 36539933
No, that's not the case.

First the script sets objFontFolder to the FONTS folder, which is usually %windir%\FONTS and then it calls the CollectFonts Sub.

The CollectFonts sub procedure iterates through each file in the FONTS folder, and adds the file name to the objDictionary object.  Once that sub has finished, objDictionary contains the file names of each font file in the FONTS folder.

The script then calls InstallFonts, which reads through each file in the *source* rootFontInstallFolder path (which is either passed as a script argument or is referenced from the current directory where the script is, if no argument is passed).  As each file in that source path is checked, it checks whether that filename is present in the objDictionary object, and if not, it copies the font file.

Regards,

Rob.
0
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 
LVL 5

Author Comment

by:bpl5000
ID: 36540127
Oh okay, now I understand!  I guess I should put in code that creates a file with the names of the fonts in objDictionary to see why they are not showing a match for duplicate fonts.
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 36540248
Yeah, as I said though, sometimes if fonts get updated, it is actually the same *font name*, but a different *file name*, so even though the code determines the *file* doesn't exist, Windows Fonts still says the *font name* already exists.  I will do some digging around to see if we can pull the font name from the file before attempting to install it.

Rob.
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 36542260
OK, I've looked around for AGES trying to find something in VBScript that could do it, but it's not capable of reading binary files in an easy to use manner.  There's some C code here:
http://www.codeproject.com/KB/GDI/fontnamefromfile.aspx

but it's not what I was looking for.  There's also some PERL code that can read the names, but I don't want to use PERL.  I then resorted to command line utilities that might display the name in a usable format.  Microsoft's TTFDump wasn't good enough output, so I decided not to use that.  The best I could find was a tool called TTDump from WinTTX package of tools here:
http://sourceforge.net/projects/fonttools/
http://fonttools.sourceforge.net/winttx.zip

What TTDump.exe does is dump the TTF information to an XML file (although why it puts a TTX extension on it I don't know).

Anyway, using this tool, I can dump the entire font file information to the TTX file, rename it to XML (just because that's a more logical extension), and then read that to find this element:
<namerecord nameID="4" platformID="3" platEncID="1" langID="0x409">

which represents the US name for the Windows font file.

So, here's my knock up of how that can work.  Currently if you run
cscript.exe ShowFontNames.vbs

it will just output the names of each font file in your font source folder.

If this approach appeals to you, I can expand on that tomorrow to then read the installed font names from the registry, and also cross reference this with the source list, and see if we can avoid any "Font already exists" errors.

Regards,

Rob.
' This required winttx to be downloaded from
' http://sourceforge.net/projects/fonttools/
' or
' http://fonttools.sourceforge.net/winttx.zip
' and that the path to ttdump.exe is specified in this script.

strTTDump = "C:\Temp\winttx\ttdump.exe"
strFontsSource = "C:\Temp\winttx\fonts"

strSearchString = "<namerecord nameID=""4"" platformID=""3"" platEncID=""1"" langID=""0x409"">"

Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFontsSource).Files
	strFontPath = objFile.Path
	strTTXPath = Left(strFontPath, Len(strFontPath) - 4) & ".ttx"
	strXMLPath = Left(strFontPath, Len(strFontPath) - 4) & ".xml"
	If Right(LCase(strFontPath), 4) <> ".ttx" And Right(LCase(strFontPath), 4) <> ".xml" Then
		If objFSO.FileExists(strXMLPath) = False Then
			If objFSO.FileExists(strTTXPath) = True Then objFSO.DeleteFile strTTXPath, True
			strCommand = objFSO.GetFile(strTTDump).ShortPath & " " & objFile.ShortPath
			objShell.Run strCommand, 0, True
			If objFSO.FileExists(strTTXPath) = True Then
				objFSO.MoveFile strTTXPath, strXMLPath
			Else
				WScript.Echo "Failed to dump information for " & strFontPath
			End If
		End If
		If objFSO.FileExists(strXMLPath) = True Then
			Set objXML = objFSO.OpenTextFile(strXMLPath, 1, False)
			strFontName = ""
			While Not objXML.AtEndOfStream
				strLine = Trim(objXML.ReadLine)
				If strLine = strSearchString Then
					strFontName = Trim(objXML.ReadLine)
					If strFontName <> "" Then
						WScript.Echo objFile.Name & " has the font name of " & strFontName
					Else
						WScript.Echo "Could not find the font name for " & objFile.Name
					End If
				End If
			Wend
			objXML.Close
		End If
	End If
Next

WScript.Echo "Finished"

Open in new window

0
 
LVL 5

Author Comment

by:bpl5000
ID: 36552841
I appreciate the work you have done and I'm sure that would work well.  I have tired launching the original vbs file twice on some workstations and it doesn't try to install existing fonts (which of course is a good thing).  On my test vm, it does try to install existing fonts.  Not sure what's up with that.  I have also run into a problem on some workstations where it seems to copy the files, but not install the fonts.  Not sure why that happens.  I found this code by just searching the web and lots of sites had vbs code for installing fonts, but all seemed to be the same code.  I wish there was vbs code for installing fonts that was a little less glitchy.

I noticed code for VB6 and VB.net that have a function called AddFontResource.  With this function, maybe I can just install the font without any glitchy problems.  I think I will now try a vb6/vb.net solution.
0
 
LVL 5

Author Comment

by:bpl5000
ID: 36589112
I think I found the reason for the flakiness of the original script that I posted.  This line...

rootFontInstallFolder = pwd

Should be...

rootFontInstallFolder = pwd & "\"

Once I made this change, it seemed to fix the glitchy problems I was having.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

I met Paul Devereux (@pdevereux) today when I responded to his tweet asking “Anybody know how to automate adding files from disk to a folder in #outlook  ?”.  I replied back and told Paul that using automation, in this case scripting, to add files t…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
Internet Business Fax to Email Made Easy - With eFax Corporate (http://www.enterprise.efax.com), you'll receive a dedicated online fax number, which is used the same way as a typical analog fax number. You'll receive secure faxes in your email, fr…
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now