VBA/VBS check if printer is installed

Posted on October 22, 2012 by thydzik

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

Posted on June 25, 2011 by thydzik

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…

Posted on August 6, 2010 by thydzik

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

Posted on December 14, 2007 by thydzik

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

Blog of Travis Hydzik

random snippets and information

Tag Archives: VBS

VBA/VBS check if printer is installed

Photoshop VBScript to automatically resize images

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

Rigid file manipulation functions for VBA/VBS