On Error Resume Next

' Declare contstants.
Const HKLM = &H80000002

' Declare variables.
strComputer = "."
strKeyPath  = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
strLogPath = "C:\output.log"

' Set objects
Set oDic = CreateObject("Scripting.Dictionary")

'Rem out the next 2 lines below
'Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
'    strComputer & "\root\default:StdRegProv")

'Add the next 7 lines below for 64bit registry
Set objCtx = CreateObject("WbemScripting.SWbemNamedValueSet")
      Set objLocator = CreateObject("Wbemscripting.SWbemLocator")

      ' Set the registry provider to the 64-bit registry provider
      objCtx.Add "__ProviderArchitecture", 64
      Set objServices = objLocator.ConnectServer("","root\default","","",,,,objCtx)
      Set oReg = objServices.Get("StdRegProv")
'MsgBox "Enumerating the subkeys of " & strKeyPath & " in the 64-bit registry..."

' Enumerate subkeys into an array.
oReg.EnumKey HKLM, strKeyPath, arrSubKeys

' Get data from each subkey.
For Each subkey In arrSubKeys

  subKeyPath = strKeyPath & "\" & subkey
  oReg.GetStringValue HKLM,subKeyPath,"DisplayName",strValue
  oReg.GetStringValue HKLM,subKeyPath,"UninstallString",strValue2

' Test for non-blank values: we want only non-blank values.
  If strValue <> "" Then
    If strValue2 <> "" Then

      ' Add data to dictionary.
      strValue2 = Replace(strValue2,"msiexec.exe /i","msiexec.exe /x")
      oDic.Add strValue, strValue2

    End If
  End If

Next

' Sort dictionary by key name (the program name).
Set oDic = SortDictionary(oDic, 1)

' Convert dictionary into arrays for processing.
ItemsArray = oDic.Items
KeysArray = oDic.Keys

' Create Log File
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set LogOutput = myFSO.OpenTextFile(strLogPath, 8, True)

' Size the array and step through each element.
intCount = oDic.Count
For i = 0 To intCount
  LogOutput.WriteLine("Program:   " & KeysArray(i))
  LogOutput.WriteLine("Uninstall: " & ItemsArray(i))
  LogOutput.WriteLine(" ")
Next

LogOutput.Close

' Declare function to sort dictionary.
Function SortDictionary(objDict, intSort)
  ' Description:
  '   Sorts a dictionary by either key or item
  ' Parameters:
  '   objDict - the dictionary to sort
  '   intSort - the field to sort (1=key, 2=item)
  ' Returns:
  '   A dictionary sorted by intSort

    ' declare constants
    Const dictKey  = 1
    Const dictItem = 2

    ' declare our variables
    Dim strDict()
    Dim objKey
    Dim strKey,strItem
    Dim X,Y,Z

    ' get the dictionary count
    Z = objDict.Count

    ' we need more than one item to warrant sorting
    If Z > 1 Then
      ' create an array to store dictionary information
      ReDim strDict(Z,2)
      X = 0
      ' populate the string array
      For Each objKey In objDict
          strDict(X,dictKey)  = CStr(objKey)
          strDict(X,dictItem) = CStr(objDict(objKey))
          X = X + 1
      Next

      ' perform a a shell sort of the string array
      For X = 0 To (Z - 2)
        For Y = X To (Z - 1)
          If StrComp(strDict(X,intSort),strDict(Y,intSort),vbTextCompare) > 0 Then
              strKey  = strDict(X,dictKey)
              strItem = strDict(X,dictItem)
              strDict(X,dictKey)  = strDict(Y,dictKey)
              strDict(X,dictItem) = strDict(Y,dictItem)
              strDict(Y,dictKey)  = strKey
              strDict(Y,dictItem) = strItem
          End If
        Next
      Next

      ' erase the contents of the dictionary object
      objDict.RemoveAll

      ' repopulate the dictionary with the sorted information
      For X = 0 To (Z - 1)
        objDict.Add strDict(X,dictKey), strDict(X,dictItem)
      Next

    End If

End Function