Software Inventory Excel VBA

Option Explicit
''original source from
'''http://www.mrexcel.com/forum/excel-questions/535773-list-softwares-installed-excel-using-visual-basic-applications.html
''updated by Ron E. Allen

Private sFileName As String
Private StrComputer As String

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31

Private Declare PtrSafe Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public sCompName As String
Public strDomain As String

Sub GetInstalledSoftware()
    'Dim sTitle As String
    Dim s As String
    Dim wsh As New WshShell

    'sTitle = "You are about to retrieve the software installed on your computer."
    'MsgBox sTitle
    
    StrComputer = GetCompName
    If StrComputer = vbNullString Then Exit Sub
    
    StrComputer = Trim(StrComputer)
    If StrComputer = "" Then StrComputer = "."
    sCompName = GetProbedID(StrComputer)
    
    If Len(sCompName) > 0 Then
        sFileName = wsh.SpecialFolders("Desktop") & "\" & sCompName & "_" & GetDTFileName() & "_Software.txt"  ''<<
        s = GetAddRemove(StrComputer)
        Call WriteFile(s, sFileName)
        Do
        DoEvents
        Loop Until Len(Dir(sFileName)) <> 0
        Call AddSheet
        
        Kill sFileName
    End If
    
    MsgBox "Edit lines out of this worksheet if necesary." & vbCr & vbCr & "Use the 'Email as attachment' button in the top-right of this form to send this workbook as an attachment", vbInformation + vbOKOnly, "Please send this information back"
    
End Sub

Private Function GetAddRemove(sComp) As String

  'Function credit to Torgeir Bakken
  Dim cnt, oReg, sBaseKey, iRC, aSubKeys
  Dim sCompName As String
  Const HKLM = &H80000002  'HKEY_LOCAL_MACHINE
  Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
              sComp & "/root/default:StdRegProv")
  sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
  iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)
  Dim sKey, sValue, sTmp, sVersion, sDateValue, sYr, sMth, sDay
  For Each sKey In aSubKeys
    iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, "DisplayName", sValue)
    If iRC <> 0 Then
      oReg.GetStringValue HKLM, sBaseKey & sKey, "QuietDisplayName", sValue
    End If
    If sValue <> "" Then
      iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
                                "DisplayVersion", sVersion)
      If sVersion <> "" Then
        ''sValue = sValue & vbTab & "Ver: " & sVersion
        sValue = sValue & vbTab & sVersion
      Else
        sValue = sValue & vbTab
      End If
      iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
                                "InstallDate", sDateValue)
      If sDateValue <> "" Then
        sYr = Left(sDateValue, 4)
        sMth = Mid(sDateValue, 5, 2)
        sDay = Right(sDateValue, 2)
        'some Registry entries have improper date format
        On Error Resume Next
        sDateValue = DateSerial(sYr, sMth, sDay)
        On Error GoTo 0
        If sDateValue <> "" Then
          ''sValue = sValue & vbTab & "Installed: " & sDateValue
          sValue = sValue & vbTab & sDateValue
        End If
      End If
      sTmp = sTmp & sValue & vbCrLf ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    cnt = cnt + 1
    End If
  Next
  sTmp = BubbleSort(sTmp)
  sTmp = Prefix(sTmp)   ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  
GetAddRemove = sTmp ''<
''  GetAddRemove = "INSTALLED SOFTWARE (" & cnt & ") - " & sCompName & _
''                 " - " & Now() & vbCrLf & vbCrLf & sTmp
End Function

Private Function Prefix(sTmp)
    Dim I, strDate, aTmp
    aTmp = Split(sTmp, vbCrLf)
    strDate = GetDTFileName()
    For I = 1 To UBound(aTmp)
        aTmp(I) = strDomain & vbTab & sCompName & vbTab & strDate & vbTab & aTmp(I)
    Next I
    Prefix = Join(aTmp, vbCrLf)
End Function

Private Function BubbleSort(sTmp) As String

  'cheapo bubble sort
  Dim aTmp, I, j, temp
  aTmp = Split(sTmp, vbCrLf)
  For I = UBound(aTmp) - 1 To 0 Step -1
    For j = 0 To I - 1
      If LCase(aTmp(j)) > LCase(aTmp(j + 1)) Then
        temp = aTmp(j + 1)
        aTmp(j + 1) = aTmp(j)
        aTmp(j) = temp
      End If
    Next
  Next
   
  BubbleSort = Join(aTmp, vbCrLf)
  
End Function

Private Function GetProbedID(sComp) As String

  Dim objWMIService, colItems, objItem
  On Error Resume Next
  Set objWMIService = GetObject("winmgmts:\\" & sComp & "\root\cimv2")
  
If Err.Number = 462 Then MsgBox Err.Description
  Set colItems = objWMIService.ExecQuery("Select SystemName from " & "Win32_NetworkAdapter", , 48)
  For Each objItem In colItems
    GetProbedID = objItem.SystemName
  Next
    
    Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem", , 48)  ''<<<<
    For Each objItem In colItems
        strDomain = objItem.Domain
        ''objItem.Manufacturer
        ''objItem.Model
    Next
End Function

Private Function GetDTFileName() As String

  Dim sNow, sMth, sDay, sYr, sHr, sMin, ap ''sSec
  sNow = Now
  sMth = Right("0" & Month(sNow), 2)
  sDay = Right("0" & Day(sNow), 2)
  sYr = Right("00" & Year(sNow), 4)
  sHr = Right("0" & Hour(sNow), 2)
  sMin = Right("0" & Minute(sNow), 2)
  If sHr > 11 Then ap = "p" Else ap = "a"
  GetDTFileName = sYr & "-" & sMth & "-" & sDay & "_" & sHr & sMin & ap
  
End Function

Private Function WriteFile(sData, sFileName) As Boolean

  Dim fso As FileSystemObject
  Dim OutFile, bWrite
  bWrite = True
  Set fso = CreateObject("Scripting.FileSystemObject")

    

  On Error Resume Next
  Set OutFile = fso.OpenTextFile(sFileName, 2, True)
  'Possibly need a prompt to close the file and one recursion attempt.
  If Err = 70 Then
    MsgBox "Could not write to file " & sFileName & ", results " & _
                 "not saved." & vbCrLf & vbCrLf & "This is probably " & _
                 "because the file is already open."
    bWrite = False
  ElseIf Err Then
    MsgBox Err & vbCrLf & Err.Description
    bWrite = False
  End If
  On Error GoTo 0
  If bWrite Then
    OutFile.WriteLine (sData)
    OutFile.Close
  End If
  Set fso = Nothing
  Set OutFile = Nothing
  WriteFile = bWrite
  
End Function

Private Sub AddSheet()

    Dim oWS As Worksheet
    Dim strShtName
    
    Dim objButton
    Dim objTarget As Range
    
    strShtName = GetDTFileName & "-" & Trim(Left(StrComputer, 31 - 17))
    
On Error Resume Next
    Set oWS = Worksheets(strShtName)
    If oWS Is Nothing Then Set oWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
On Error GoTo 0
    With oWS
        ''.Name = "Installed_Software"
        ''.Range("$A$1") = "Computer : " & StrComputer
        ''.Range("a1").Font.Bold = True
        ''.QueryTables.Add(Connection:="TEXT;" & sFileName, Destination:=oWS.Range("$A$2")).Refresh
        .Activate
        .Name = strShtName
        .Range("$A$1") = "Domain"
        .Range("$b$1") = "Computer : " & StrComputer
        .Range("$c$1") = "Run Date"
        .Range("$d$1") = "Software from Add/Remove"
        .Range("$e$1") = "Version"
        .Range("$f$1") = "Install Date"
        
        ''Add sendto button
        Set objTarget = .Range("$g$1")
        objTarget.ColumnWidth = 30
        objTarget.RowHeight = 30
        Set objButton = .Buttons.Add(objTarget.Left, objTarget.Top, objTarget.Width, objTarget.Height)
        With objButton
            .OnAction = "SendAsAttachment"
            .Caption = "Email As Attachment"
        End With
        
        
        .Range("1:1").Font.Bold = True
        .QueryTables.Add(Connection:="TEXT;" & sFileName, Destination:=oWS.Range("$A$2")).Refresh
        .Columns("A:G").AutoFit
    End With
    
    If ActiveWorkbook.Worksheets.Count > 1 Then
        If MsgBox("May the other sheets be deleted to clean up the workbook?", vbCritical + vbYesNo, "Cleanup workbook") = vbYes Then
            Dim I
            Application.DisplayAlerts = False
            For I = ActiveWorkbook.Worksheets.Count To 1 Step -1
                If ActiveWorkbook.Worksheets(I).Name <> oWS.Name And Not (oWS Is Nothing) Then ActiveWorkbook.Worksheets(I).Delete
            Next I
            Application.DisplayAlerts = True
        End If
    End If
End Sub


Private Function GetCompName() As String

    Dim lStrLen As Long
    Dim sString As String
    
    lStrLen = MAX_COMPUTERNAME_LENGTH + 1
    sString = Space(lStrLen)
    GetComputerName sString, lStrLen
    sString = Left(sString, lStrLen)
    GetCompName = sString
    
End Function


''-------------------------------------------------------------------
Const strSendTo = "Specificemail@sspecificDomain.com" ''Email to send info to

Sub SendAsAttachment()
'
' SendAsAttachment Macro
'

    If MsgBox("Does the workbook require editing to exclude any confidential items that should not be shared before sending?", vbExclamation + vbYesNoCancel, "Sendmail Preperation") <> vbNo Then
        MsgBox "Please edit the document to remove content to remain anonymous. Once complete, press the Sendmail button again to mail the document.", vbOKOnly + vbInformation, "Mailing cancelled"
        Exit Sub
    End If
        
        MsgBox "No subject or body to the email is required. Excel should open an email with the workbook attached." & vbCr & vbCr & "Please address it to " & strSendTo, vbOKOnly + vbInformation
    Application.Dialogs(xlDialogSendMail).Show _
        arg1:=strSendTo, _
        arg2:=GetInstalledSoftware.strDomain & "/" & GetInstalledSoftware.sCompName & " Installed software"
End Sub

'''

''----------------------------------------------------------------------------------