VBA/VBS check if printer is installed

Here is a quick code snippet to determine if a printer is installed on a Microsoft Windows system;

MsgBox printerExists("Microsoft XPS Document Writer")

Function printerExists(str)
    printerExists = False
    Dim objWMIService
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")

    Dim colPrinters
    Set colPrinters = objWMIService.ExecQuery("Select * From Win32_Printer")

    Dim objPrinter
    For Each objPrinter In colPrinters
        If objPrinter.Name = str Then
            printerExists = True
            Exit For
        End If
    Next
End Function

Photoshop VBScript to automatically resize images

Decided to learn Photoshop VBScripting, don’t know why I didn’t do this sooner, I now have scripts to automatically generate my blog thumbnails (as below), and add little Google Maps markers on them (see here).

A few constants to change in the script (edit with Notepad);

  • RESIZEWIDTH – thumbnail width
  • RESIZEHEIGHT – thumbnail height
  • IGNOREVERTICAL – should vertical (portrait) images be ignored (I like to do these manually as I crop them to landscape)
  • SUFFIX – thumbnail suffix

To run it, simply place the script in your image folder (make sure to take a backup) and execute the file.
auto-resize-images-v0.1.vbs

Public Const RESIZEWIDTH = 150
Public Const RESIZEHEIGHT = 113

Public Const IGNOREVERTICAL = True
Public Const SUFFIX = "-th"

Dim spath
spath = Mid(WScript.ScriptFullName, 1, InStrRev(WScript.ScriptFullName, "\", -1, vbBinaryCompare))

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Dim foldero
Set foldero = fso.GetFolder(spath)

Dim fileo
Dim sfile

For Each fileo In foldero.Files
    'only modify jpg files
    sfile = fileo.Name
    If InStrRev(sfile, ".jpg", -1, vbTextCompare) = Len(sfile) - 3 Then
        resize spath & sfile
    End If
Next

MsgBox "Complete."

Sub resize(sfilename)

    Set WshShell = WScript.CreateObject("WScript.Shell")
    Set colProcessList = GetObject("Winmgmts:").ExecQuery("Select * from Win32_Process")

    Dim found
    found = False

    For Each objProcess In colProcessList
        If StrComp(objProcess.Name, "photoshop.exe", vbTextCompare) = 0 Then
            found = True
            Exit For
        End If
    Next

    Dim appRef
    If found Then
        Set appRef = GetObject(, "Photoshop.Application")
    Else
        Set appRef = CreateObject("Photoshop.Application")
    End If

    Do While appRef.documents.Count
       appRef.activeDocument.Close 2 'dont' save
    Loop

    Dim originalRulerUnits
    originalRulerUnits = appRef.Preferences.RulerUnits
    appRef.Preferences.RulerUnits = 1 'pixels

    Dim docRef
    Set docRef = appRef.Open(sfilename)

    Dim modified
    modified = False

    If docRef.Width >= docRef.Height Then 'horizontal photo
            If docRef.Width <> RESIZEWIDTH Then 'proceed if not already resized
                docRef.ResizeImage RESIZEWIDTH 'preserves aspect ratio
                modified = True
            End If
    Else 'verticle photo
        If Not IGNOREVERTICAL Then 'proceed
            If docRef.Height <> RESIZEHEIGHT Then 'proceed if not already resized
                docRef.ResizeImage , RESIZEHEIGHT 'preserves aspect ratio
                modified = True
            End If
        End If
    End If

    If modified Then 'only save if the image was modified
        Dim jpgSaveOptions
        Set jpgSaveOptions = CreateObject("Photoshop.JPEGSaveOptions")
        jpgSaveOptions.Quality = 8

        'calculate the new file name
        Dim newfilename
        newfilename = Mid(sfilename, 1, Len(sfilename) - 4) & SUFFIX & ".jpg"

        docRef.SaveAs newfilename, jpgSaveOptions, True, 2 'for psLowercase
    End If

    docRef.Close 2 'dont' save

    appRef.Preferences.RulerUnits = originalRulerUnits

End Sub

eventquery.vbs – ERROR: Unable to execute the query for the…

If you received this error when trying to execute eventquery.vbs the cause is an overflow of events past 32,767 (the maximum capacity of a VB6 Integer). There is a very simple fix for this which is to change the data type from an Integer to a Long (which has a maximum capacity of 2,147,483,647).

In eventquery.vbs, scroll down to line 1700 and 1703 and change both CInt to CLng.
Before;

        If CInt(objLogs.Item(arrKeyName(intLoopCount))) > 0 Then
            strFilterLog = arrKeyName(intLoopCount)
            intRecordRangeFrom = 0
            intRecordRangeTo = CInt(objLogs.Item(arrKeyName(intLoopCount)))

After;

        If CLng(objLogs.Item(arrKeyName(intLoopCount))) > 0 Then
            strFilterLog = arrKeyName(intLoopCount)
            intRecordRangeFrom = 0
            intRecordRangeTo = CLng(objLogs.Item(arrKeyName(intLoopCount)))

Or download the already updated eventquery.vbs.

Rigid file manipulation functions for VBA/VBS

Ever since starting work I have been learning and using VBA/VBS to make life easier. I will start posting some of my generic functions as a source for others. They may not be written optimally, but they do work.

' Function: fileExist(sPathFile) returns True if a file exists
' Input: sPathFile - the file (including path) to determine if exists
' Output: fileExists - returns true if file exists
' Notes: network shared drives work as well.
Function fileExist(sPathFile) As Boolean
    On Error Resume Next
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    fileExist = fso.FileExists(sPathFile)
    Set fso = Nothing
End Function

' Function: renameFile(oldName, newName) renames a file, can also be used to move a file
' Inputs: oldName - file including path to be renamed
'         newName - file including path of the renamed or moved file
' Notes: renameFile checks if the file exists and the new path exists before renaming or moving
' Dependants: fileExists
Function renameFile(oldName, newName)
    On Error Resume Next
    If fileExist(oldName) And Dir(Left(newName, InStrRev(newName, "/")), vbDirectory) <> vbNullString Then
        Dim fso
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.MoveFile oldName, newName
        Set fso = Nothing
    End If
End Function

' Function: deleteFile(sPathFile) deletes a file
' Input: sPathFile - the file (including path) to be deleted i.e. "C:/a.txt"
' Notes: deleteFile checks if the file exists first before deleting
' Dependants: deleteFile
Function deleteFile(sPathFile)
    On Error Resume Next
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(sPathFile) Then fso.GetFile(sPathFile).Delete
    Set fso = Nothing
End Function

' Function: copyFile(fileName, copyName) copies a file
' Inputs: fileName - file to be copied, path and file required i.e. "C:/a.txt"
'         copyName - the copied file, path and file required i.e. "C:/b.txt"
' Notes: copyFile checks if fileName exists, as well as the copyName folder
'        if copyName is already present the file is deleted
' Dependants: fileExists, deleteFile
Function copyFile(fileName, copyName)
    On Error Resume Next
    If fileExist(fileName) And Dir(Left(copyName, InStrRev(copyName, "/")), vbDirectory) <> vbNullString Then
        Call deleteFile(copyName)
        Dim fso
        Dim aFile
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.copyFile fileName, copyName, True
        Set aFile = fso.GetFile(copyName)
        If aFile.Attributes And 1 Then
            aFile.Attributes = aFile.Attributes - 1
        End If
        Set fso = Nothing
        Set aFile = Nothing
    End If
End Function