List of Softwares installed in excel using vba

[sanits591]

Hi,
I am searching for the VBA codes in excel, which shall generate a list in excel file (same excel file in which the code is pasted) of Softwares installed in the computer with a button click.

I have found one of the VBA script which is doing the same but in txt file which then needs to be imported in excel.

I need the code in excel file itself, which shall generate the list of S/W installed in the same excel file.

Request to assist me in reslolving this.

Anticipatory thanks!

Option Explicit
Dim sTitle
sTitle = "InstalledPrograms.vbs by Bill James"
Dim StrComputer
StrComputer = InputBox("Enter I.P. or name of computer to check for " & _
                       "installed software (leave blank to check " & _
                       "local system)." & vbCrLf & vbCrLf & "Remote " & _
                       "checking only from NT type OS to NT type OS " & _
                       "with same Admin level UID & PW", sTitle)
If IsEmpty(StrComputer) Then WScript.Quit
StrComputer = Trim(StrComputer)
If StrComputer = "" Then StrComputer = "."
'Wscript.Echo GetAddRemove(strComputer)
Dim sCompName: sCompName = GetProbedID(StrComputer)
Dim sFileName
sFileName = sCompName & "_" & GetDTFileName() & "_Software.txt"
Dim s: s = GetAddRemove(StrComputer)
If WriteFile(s, sFileName) Then
  'optional prompt for display
  If MsgBox("Finished processing.  Results saved to " & sFileName & _
            vbCrLf & vbCrLf & "Do you want to view the results now?", _
            4 + 32, sTitle) = 6 Then
    WScript.CreateObject("WScript.Shell").Run sFileName, 9
  End If
End If
Function GetAddRemove(sComp)
  'Function credit to Torgeir Bakken
  Dim cnt, oReg, sBaseKey, iRC, aSubKeys
  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
      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
        End If
      End If
      sTmp = sTmp & sValue & vbCrLf
    cnt = cnt + 1
    End If
  Next
  sTmp = BubbleSort(sTmp)
  GetAddRemove = "INSTALLED SOFTWARE (" & cnt & ") - " & sCompName & _
                 " - " & Now() & vbCrLf & vbCrLf & sTmp
End Function
Function BubbleSort(sTmp)
  '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
Function GetProbedID(sComp)
  Dim objWMIService, colItems, objItem
  Set objWMIService = GetObject("winmgmts:\\" & sComp & "\root\cimv2")
  Set colItems = objWMIService.ExecQuery("Select SystemName from " & _
                                         "Win32_NetworkAdapter", , 48)
  For Each objItem In colItems
    GetProbedID = objItem.SystemName
  Next
End Function
Function GetDTFileName()
  Dim sNow, sMth, sDay, sYr, sHr, sMin, 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)
  sSec = Right("0" & Second(sNow), 2)
  GetDTFileName = sMth & sDay & sYr & "_" & sHr & sMin & sSec
End Function
Function WriteFile(sData, sFileName)
  Dim fso, 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
    WScript.Echo "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
    WScript.Echo 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

 

[sanits591]

Many many thanks!!! i changed the drive to something else it worked. Great!!! Probably c is restricted to generate any file using vb codes without permission from vista.

 

[Jaafar Tribak]

My bad I should have used the system temp folder instead of the C Drive as follows :

  sFileName = Environ("temp") & sCompName & "_" & GetDTFileName() & "_Software.txt"

Anyway, I am glad you got this working in the end.

 

[baha17]

First of all thank you very much for the code.
It works for me if I run from my-document with windows xp.however,it gives 76 file was not found error if i run it from windows 7. any way to run with win 7?
once again,that was an awsome code thanks.

Baha

 

[baha17]

Hi,
I did not see the last post from Jaafar.

sFileName = Environ("temp") & sCompName & "_" & GetDTFileName() & "_Software.txt"

works fine for Windows7
Thanks