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

'''

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

Comments

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Revit area plans adding new types and references (Gross and rentable)

Revit Python in Visual Studio Revit Stubs 2022 for Python Revit Intellisense