Cacher is the code snippet organizer for pro developers

Option Explicit

'---------------- USAGE -------------------------

Dim sComputer : sComputer = "."

'---------------- PROGRAM -------------------------

Dim sFileName : sFileName = sComputer & "_" & GetFilename() & ".txt"
Dim sData

'Return Add/Remove Program details
sData = GetAddRemove(sComputer)

'Write the details to a file and allow the user to open
If WriteFile(sData, sFileName) Then
    If MsgBox("Results saved to: " & sFileName & vbcrlf & vbcrlf & "Do you want to open the results file now?", 4 + 32) = 6 Then
        wScript.CreateObject("wScript.Shell").Run sFileName, 9
    End If
End If

'---------------- FUNCTIONS -------------------------

'Export list of installed programs from registry
Function GetAddRemove(sComputer)

    Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
    Const BASEKEY = "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\"

    Dim aSubKeys, sKey, iReg
    Dim sProduct, sVersion, sDate, sYear, sMonth, sDay
    Dim sExport, iCount
    
    Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sComputer & "/root/default:StdRegProv")
    iReg = oReg.EnumKey(HKLM, BASEKEY, aSubKeys)
    
    For Each sKey In aSubKeys
  
	'Store the product name 
        iReg = oReg.GetStringValue(HKLM, BASEKEY & sKey, "DisplayName", sProduct)
        If iReg <> 0 Then oReg.GetStringValue HKLM, BASEKEY & sKey, "QuietDisplayName", sProduct
        
	'Store the product version 
        If sProduct <> "" Then
            iReg = oReg.GetStringValue(HKLM, BASEKEY & sKey, "DisplayVersion", sVersion)
            If sVersion <> "" Then 
		sProduct = sProduct & vbTab & "Ver: " & sVersion
            Else
                sProduct = sProduct & vbTab
            End If

	    'Store the product install date
            iReg = oReg.GetStringValue(HKLM, BASEKEY & sKey, "InstallDate", sDate)
            If sDate <> "" Then
                sYear = Left(sDate, 4)
                sMonth = Mid(sDate, 5, 2)
                sDay = Right(sDate, 2)
                On Error Resume Next
                   sDate = DateSerial(sYear, sMonth, sDay)
                On Error GoTo 0
                    If sDate <> "" Then sProduct = sProduct & vbTab & "Installed: " & sDate
	    End If
            
            sExport = sExport & sProduct & vbcrlf
            iCount = iCount + 1
        End If
    Next
    
    sExport= BubbleSort(sExport)
    GetAddRemove = "INSTALLED SOFTWARE (" & iCount & ") - " & sComputer & " - " & Now() & vbcrlf & vbcrlf & sExport
End Function

'Sort the listed programs
Function BubbleSort(sInput)

    'Create array to store programs split by line break
    Dim aPrograms : aPrograms = Split(sInput, vbcrlf)
    Dim i, j, tmp
    
    For i = UBound(aPrograms) - 1 To 0 Step -1
        For j = 0 to i - 1
            If LCase(aPrograms(j)) > LCase(aPrograms(j+1)) Then
                tmp = aPrograms(j + 1)
                aPrograms(j + 1) = aPrograms(j)
                aPrograms(j) = tmp
            End if
        Next
    Next
    
    'Return merged array
    BubbleSort = Join(aPrograms, vbcrlf)
End Function

'Format the filename of the result file
Function GetFilename()
    
    'Set the variable to the current time
    Dim sNow : sNow = Now
    
    'Format the current time and return the value
    sNow = Replace(sNow,"/","")
    sNow = Replace(sNow," ","_")
    sNow = Replace(sNow,":","")
    GetFilename = sNow
End Function

'Write data to file
Function WriteFile(sData, sFileName)

    Dim bWrite : bWrite = True
    Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")

    'Attempt to create output file
    On Error Resume Next
    Dim oFile : Set oFile = FSO.OpenTextFile(sFileName, 2, True)
    
    If Err = 70 Then
	MsgBox ("Could not write to file " & sFileName & ", results " & "not saved.")
        bWrite = False
    ElseIf Err Then
	MsgBox (Err & vbcrlf & Err.description)
        bWrite = False
    End If
    
    On Error GoTo 0
    If bWrite Then
        oFile.WriteLine(sData)
        oFile.Close
    End If
    
    Set FSO = Nothing
    Set oFile = Nothing

    'Return success of writing to file
    WriteFile = bWrite
End Function