VBScript: Enumerate Start Menu Shortcuts into XML

Here's a little script to dump a list of all shortcuts and their internal properties, which exist under the “All Users” profile, in Start Menu\Programs, as well as all sub-folders below that.  The output is basic raw XML.  Not much to it, but I had to crank this out for a special project I worked on a few weeks ago and thought I’d post it here.

'****************************************************************
' Filename..: enum_allusers_shortcuts.vbs
' Author....: skatterbrainz
' Date......: 02/03/2010
' Purpose...: enumerate shortcuts under all-users start menu (xml)
'****************************************************************
Dim objShell, allUsers, allStart, objFSO, oFolder, s

Set objShell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

allUsers = objShell.ExpandEnvironmentStrings("%AllUsersProfile%")
allStart = allUsers & "\Start Menu\Programs"

Set oFolder = objFSO.GetFolder(allStart)

wscript.echo "<shortcuts>"
For each s in oFolder.SubFolders
 ListShortcuts objFSO.GetFolder(allStart & "\" & s.Name)
Next
wscript.echo "</shortcuts>"

Sub ListShortcuts(objFolder)
 Dim objFile, filename
 For each objFile in objFolder.Files
  filename = objFile.Name
  If Right(Lcase(filename),4) = ".lnk" Then
   filepath = objFolder.Path & "\" & filename
   wscript.echo vbTab & "<shortcut>"
   ShortcutProps filepath
   wscript.echo vbTab & "</shortcut>"
  End If
 Next
End Sub

Sub ShortcutProps(scName)
 Dim objShortcut
 If objFSO.FileExists(scName) Then
  Set objShortcut = objShell.CreateShortcut(scName)
  WScript.Echo vbTab & vbTab & "<fullname>" & objShortcut.FullName & "</fullname>"
  WScript.Echo vbTab & vbTab & "<arguments>" & objShortcut.Arguments & "</arguments>"
  WScript.Echo vbTab & vbTab & "<workingpath>" & objShortcut.WorkingDirectory & "</workingpath>"
  WScript.Echo vbTab & vbTab & "<target>" & objShortcut.TargetPath & "</target>"
  WScript.Echo vbTab & vbTab & "<icon>" & objShortcut.IconLocation & "</icon>"
  WScript.Echo vbTab & vbTab & "<hotkey>" & objShortcut.Hotkey & "</hotkey>"
  WScript.Echo vbTab & vbTab & "<windowstyle>" & objShortcut.WindowStyle & "</windowstyle>"
  WScript.Echo vbTab & vbTab & "<comment>" & objShortcut.Description & "</comment>"
  Set objShortcut = Nothing
 Else
  wscript.echo "unable to find shortcut"
 End If
End Sub

Set oFolder  = Nothing
Set objFSO   = Nothing
Set objShell = Nothing

VBScript Enumerate Shortcuts

Enumerate shortcuts under all-users profile and report in XML format...

Option Explicit
Const strComputer = "."

Const rKey = "Software\Microsoft\Windows NT\CurrentVersion\ProfileList"
Const rVal = "ProfilesDirectory"
Const HKCU = &H80000001
Const HKLM = &H80000002

Dim objShell, objFSO, oReg, objRootFolder, psub, p
Dim objFolder, objLink, objFsub, linkpath, uid, objLnk

Set objShell = CreateObject("Wscript.Shell")
Set objFSO   = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
    strComputer & "\root\default:StdRegProv")

If err.Number <> 0 Then
    wscript.echo "error: computer is not accessible"
    wscript.Quit(1)
End If

oReg.GetExpandedStringValue HKLM, rKey, rVal, p
If VarType(p) = vbNull Then
    wscript.echo "error: registry key not found"
    wscript.Quit(1)
End If

Set objRootFolder = objFSO.GetFolder(p)

wscript.echo ""
wscript.echo ""
For each objFolder in objRootFolder.SubFolders
    uid = objFolder.Name
    psub = p & "\" & uid & "\desktop"
    If objFSO.FolderExists(psub) Then
        wscript.echo vbTab & ""
        Set objFsub = objFSO.GetFolder(psub)
        For each objLink in objFsub.Files
            If InStr(1, ".lnk .url", Lcase(Right(objLink.Name,4))) <> 0 Then
                wscript.echo vbTab & vbTab & ""
                linkpath = psub & "\" & objLink.Name
                Set objLnk = objShell.CreateShortcut(linkpath)
                Select Case Lcase(Right(linkpath,4))
                    Case ".lnk":
                        ClosedTag 3, "name", objLnk.Name
                        ClosedTag 3, "fullname", objLnk.FullName
                        ClosedTag 3, "arguments", objLnk.Arguments
                        ClosedTag 3, "working", objLnk.WorkingDirectory
                        ClosedTag 3, "target", objLnk.TargetPath
                        ClosedTag 3, "icon", objLnk.IconLocation
                        ClosedTag 3, "hokey", objLnk.Hotkey
                        ClosedTag 3, "windowstyle", objLnk.WindowStyle
                        ClosedTag 3, "description", objLnk.Description
                        ClosedTag 3, "type", "filesystem"
                    Case ".url":
                        ClosedTag 3, "name", objLnk.Name
                        ClosedTag 3, "fullname", objLnk.FullName
                        ClosedTag 3, "target", objLnk.TargetPath
                        ClosedTag 3, "type", "internet"
                End Select
                wscript.echo vbTab & vbTab & ""
            End If
        Next
        wscript.echo vbTab & ""
    End If
Next
wscript.echo ""

Sub ClosedTag(indent, label, val)
    Dim i, s : s = ""
    For i = 1 to indent
        s = s & vbTab
    Next
    If Trim(val) = "" Then
        s = s & "<" & label & ">_"
    Else
        s = s & "<" & label & ">" & val & ""
    End If
    wscript.echo s
End Sub

Set objFolder = Nothing
Set objFSO = Nothing
Set objShell = Nothing