W odpowiedzi na pytanie z firmy, która nie posiada  jeszcze oprogramowania do inwentaryzacji zamieszczamy skrypt do inwentaryzacji oprogramowania zainstalowanego na stacjach zarejestrowanych w AD. Wynik Inwnetaryzacji zapisywany jest w pliku Excel. Oczywiście skrypt ma wady których nie posiada aplikacja do inwentaryzacji:

- działa wolno (jednowątkowo)
- nie dokonuje powrotów do stacji, które były wyłączone podczas inwentaryzacji
- nie inwentaryzuje stacji, które są zabezpieczone firewalem
- skanuje wszystkie zainstalowane aplikacje co powoduje, zebranie bardzo dużej liczby zbędnych danych

Nie mniej jednak wynik takiej próbnej inwentaryzacji może dać wyobrażenie o wielkości zadania, które przed nami stoi.

Option Explicit 


WScript.interactive=False 
Dim EXCL ' Aplikacja Excel
Dim currentCell, oSheet 
Dim fileName 'Nazwa pliku xls, do którego ma byc zapisany rezultat
Dim Computers 'Tabela komputerów która będzie wypełniona danymi z AD
Dim strEntry1a,strEntry1b,strEntry2,strEntry3,strEntry4 
Dim strEntry5,arrSubkeys,intRet1,strSubkey,strValue1,strValue2,strValue3,strValue4 
Dim intValue1,intValue2,intValue3,intValue4,intValue5 
Dim SWBemlocator, strComputer,WMIService,objReg 


Set EXCL= WScript.CreateObject("Excel.Application") 'Tworzymy obiekt aplikacji Excel
Dim username 
Dim password 
Dim ldapString 


ldapString="LDAP://DC=hdfe,DC=com" 'Nazwa domeny
currentCell=1 
EXCL.Visible=True 'Jeśli praca systemu ma być widoczna nalezy właczyć visible=True, lub wyłączyć jeli skanowanie ma przebiegać szybciej
EXCL.Workbooks.Add 
Set oSheet=EXCL.Workbooks.Item(1) 


Sub writeExcel(valore,colonna) 
    EXCL.Cells(currentCell,colonna)=valore 
End Sub     
 
Sub fillArray(Computers) 
 
    Const ADS_SCOPE_SUBTREE = 2 
    Dim computerArray(), indice 
    Dim objConnection,objCommand,objRecordset 
    indice=0 
    ReDim computerArray(1) 
    Set objConnection = CreateObject("ADODB.Connection") 
    Set objCommand =   CreateObject("ADODB.Command") 
    objConnection.Provider = "ADsDSOObject" 
    objConnection.Open "Active Directory Provider" 
 
    Set objCommand.ActiveConnection = objConnection 
    objCommand.CommandText = _ 
        "Select Name from '" & ldapString & "' " _ 
        & "Where objectClass='computer'"   
    objCommand.Properties("Page Size") = 1000 
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE  
    Set objRecordset = objCommand.Execute 
    objRecordSet.MoveFirst 
 
    Do Until objRecordset.EOF 
        computerArray(indice)=objRecordSet.Fields("Name").Value 
        indice=indice+1 
        ReDim Preserve computerArray(indice) 
        objRecordset.MoveNext 
    Loop 
    ReDim preserve computerArray(UBound(computerArray)-1) 
    Computers=computerArray 
End Sub 
 
 
Call fillArray(Computers) 
 
If WScript.Arguments.Named.Exists("USERNAME") Then username=WScript.Arguments.Named("USERNAME") else username="" 
If WScript.Arguments.Named.Exists("PASSWORD") Then Password=WScript.Arguments.Named("PASSWORD") else password="" 
If WScript.Arguments.Named.Exists("FILE") Then Password=WScript.Arguments.Named("FILE") else fileName="c:\assestment.xls" 


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


strEntry1a = "DisplayName" 
strEntry1b = "QuietDisplayName" 
strEntry2 = "InstallDate" 
strEntry3 = "VersionMajor" 
strEntry4 = "VersionMinor" 
strEntry5 = "EstimatedSize" 
 
Set SWBemlocator = CreateObject("WbemScripting.SWBemlocator") 
For Each strComputer In Computers 
 
    EXCL.Workbooks.Item(1).Sheets.Add 
    oSheet.ActiveSheet.Name=strComputer 
    On Error Resume next 
     Set WMIService = SWBemlocator.ConnectServer(strComputer,"\root\default",UserName,Password) 
     Set objReg=WMIService.Get("StdRegProv") 
    objReg.EnumKey HKLM, strKey, arrSubkeys 
    For Each strSubkey In arrSubkeys 
      intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1a, strValue1) 
      If intRet1 <> 0 Then 
        objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1b, strValue1 
      End If 
      If strValue1 <> "" Then 
        call writeExcel(strValue1,1) 
      End If 
      objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2 
      If strValue2 <> "" Then 
        call writeExcel(strValue2,2) 
      End If 
      objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry3, intValue3 
      objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry4, intValue4 
      If intValue3 <> "" Then 
        call writeExcel(intValue3 & "." & intValue4,3) 
      End If 
      objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry5, intValue5 
      If intValue5 <> "" Then 
        Call writeExcel(Round(intValue5/1024, 3),5) 
      End If 
      if strvalue1<>"" then currentCell=currentCell+1 
    Next 
    currentCell=1  
Next 
oSheet.SaveAs(fileName) 
oSheet.Close   
EXCL.Quit 
Set EXCL=Nothing