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

Base64/sexatrigesimal encoding/decoding in VBA/VB6/Visual Basic

Here is an implementation of Base 36 enconding/decoding functions is VB6.

'Convert positive integer to a base36 string.
Function base36encode(ByRef number As Long) As String

    Dim alphabet As String
    alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    If number = 0 Then
        base36encode = "0"
        Exit Function
    End If
    base36encode = vbNullString
    Do While number <> 0
        base36encode = Mid(alphabet, number Mod 36 + 1, 1) & base36encode
        number = number  36
    Loop
    
End Function

'Convert base36 string to positive integer.
Function base36decode(ByRef base36 As String) As Long

    Dim alphabet As String
    alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

    base36decode = InStr(1, alphabet, Right(base36, 1), vbTextCompare) - 1 'get the last character
    For i = Len(base36) - 1 To 1 Step -1
        base36decode = base36decode + 36 ^ (Len(base36) - i) * (InStr(1, alphabet, Mid(base36, i, 1), vbTextCompare) - 1)
    Next i
    
End Function