SysInfo.hta - use vbscript in an hta file to obtain system information

See blog post here.

Use 'Allow less secure apps' if you see this error!

---------------------------

ERROR -2147220975: The message could not be sent to the SMTP server. The transport error code was 0x80040217. The server response was not available

--------------------------

Change the three variables in SysInfo2.hta as required. By default you will be prompted each time for all three values. I suggest setting esend and edest so that you only have to type in your gmail password when you want to send a report.

' --------- EMAIL VARIABLES - must be set for your own acccount -------------

' leave password as "" if you want to always specify the password yourself for security

esend = "" 'e.g.  "xxxxxxx@gmail.com" must be gmail account - you must set 'less secure apps' on the Google account or else get ERROR -2147220975

epwd = "" 'gmail account password - can leave blank as ""

edest = "" 'default destination email account - change or leave blank - you will always be prompted

e.g.

esend = "steves_unsecure_gmail@gmail.com"

epwd = ""

edest = "steves_email@gmail.com"

EXAMPLE OUTPUT (ABBREVIATED)

 Also list Printers, Software, Hotfixes, PCI IDs, EventLog Errors and Drivers (may take several minutes) 

System Information for MYDELL

Click on the Serial Number below for information and drivers for your system at www.rm.com

Your system serial number is unknown

Date: 01/08/2011 23:54:24

Operating System

Microsoft Windows 7 Ultimate - Service Pack 1 (version=6.1.7601) 

SKU=Ultimate Edition (Ultimate Edition)

Service Pack=v1.0

Architecture=64-bit

Install Date=08/12/2009 20:08:46

Serial Number=00426-292-4770575-853777

Total Visible Memory=3,070MB

Free Physical Memory=1,035.9MB

Total Virtual Memory=6,139MB

Free Virtual Memory=3,370MB

Windows Directory=C:\Windows

System Drive=C:

User=Dave

Last Boot Up Time=01/08/2011 17:42:53

Mainboard

Product=0RY0

Version=ÿÿÿ

Serial Number=..CN736047AT

Manufacturer=Dell Inc.

BIOS

Version=DELL - 42302e31

Description=Phoenix - AwardBIOS v6.00PG

SMBIOS Version=1.0.15

Manufacturer=Dell Inc.

Release Date=20/06/2008

Chassis

Serial Number=3ZWZB7L

Type=Desktop

Version=OEM

Manufacturer=Dell Inc.

System

Serial Number=3ZWZB7L

Product=Inspiron 530

Manufacturer=Dell Inc.

GUID (Windows format)=4C4C4544-005A-5710-805A-B999F46634A

GUID (Wire format for PXE)=44454C4C5A001057805A99C04F46634A

CPU Core 1

CPU value=Pentium(R) Dual-Core CPU E5300 @ 2.60GHz

Current speed=2600MHz

Max Clock speed=2593MHz

CPU Socket=Socket 775

Type=Intel64 Family 6 Model 23 Stepping 10

Physical Hard Disk Drives

Hard Disk 0 ST3250820AS ATA Device 250.0GB (IDE) [Sno=5QE5BA65 Firmware=3.ADG] (3 Partitions)

Hard Disk 1 Kingston DataTraveler G2 USB Device 4.0GB (USB) [Firmware=PMAP] (1 Partition)

Hard Disk 2 Alcor Flash Disk USB Device 518.2MB (USB) [Firmware=8.07] (2 Partitions)

Logical Hard Disk Volumes

C: HDD DRIVE_C 239.2GB Free Space=22.0GB

D: HDD DRIVE_D 10.7GB Free Space=203.0MB

E: MSSS_Media3 517.9MB Free Space=515.9MB

J: Kingston 4.0GB Free Space=4.0GB

Optical Drives

HL-DT-ST DVD+-RW GSA-H73N ATA Device [Firmware=B103]

Tape Drives

No tape drives found

Memory

Total Memory slots=4

Empty Memory slots=0

Used Memory slots=4

Total Memory=3072MB

512MB (Pno=M3 78T6553EZS-CE6 SNo=792DBFCA)

1024MB (Pno=1GBULURTYJBA SNo=454C5356)

512MB (Pno=M3 78T6553EZS-CE6 SNo=792DBFD0)

1024MB (Pno=1GBULURTYJBA SNo=674C5356)

Network Adapters

Intel(R) 82562V-2 10/100 Network Connection (100 Mb/s) MAC=001D097A54A0

MAC Address 00:1D:09:7A:54:C0 is using IPAddress: 192.168.1.3 Subnet: 255.255.255.0

Audio

Microsoft High Definition Audio Device

Video

NVIDIA GeForce 8400 GS - (256MB)

Monitor 1

Model Name=SyncMaster

Serial Number=HS2Q800346

Mfr ID=SAM

Device ID=02E2

Mfr Date=9/2008

EDID Version=1.3

Native Resolution=1440 x 900 (obtained from monitor EDID information)

Screen size=428mm x 255mm (20 inch screen)

Problem Devices or Drivers

ERROR 52: PROBLEM DEVICE - REASON UNKNOWN Avnex Virtual Audio Device 

ROOT\MEDIA\0000

Printer Drivers

Canon Inkjet i550 B&W (DEFAULT PRINTER)

Microsoft XPS Document Writer

Fax

CutePDF Writer

Canon Inkjet i550

Installed Third Party Drivers

The following drivers are not 'In-Box' Windows drivers:

Virtual CloneDrive    v.5.4.3.5   08/08/2009

UNSIGNED ROOT\SCSIADAPTER\0000

Avnex Virtual Audio Device    v.1.0.0.1   22/06/2009

UNSIGNED ROOT\MEDIA\0000

NVIDIA GeForce 8400 GS    v.8.17.12.7533   20/05/2011

Signed PCI\VEN_10DE&DEV_0422&SUBSYS_0F1F105B&REV_A1\4&13B87A31&0&0008

Installed In-Box Drivers

The following drivers are 'In Box' Windows drivers:

USB Mass Storage Device    v.6.1.7601.17577   21/06/2006

Signed USB\VID_0930&PID_6545\001D92A85D0AB960234F0123

USB Root Hub    v.6.1.7601.17586   21/06/2006

Signed USB\ROOT_HUB20\4&4E48F5B&0

Intel(R) ICH9 Family USB2 Enhanced Host Controller - 293A    v.6.1.7601.17586   21/06/2006

PCI Device IDs

8086_2930_1028_020D Intel(R) ICH9 Family SMBus Controller - 2930

8086_293C_1028_020D Intel(R) ICH9 Family USB2 Enhanced Host Controller - 293C

8086_2934_1028_020D Intel(R) ICH9 Family USB Universal Host Controller - 2934

Installed Software

Windows 7 USB/DVD Download Tool (Microsoft Corporation) v1.0.30

Windows Live Essentials (Microsoft Corporation) v15.4.3502.0922

Microsoft Visual Studio 2010 ADO.NET Entity Framework Tools (Microsoft Corporation) v10.0.30319

Microsoft Visual C++ 2008 Redistributable - x86 9.0.30729.4974 (Microsoft Corporation) v9.0.30729.4974

Windows Live Writer (Microsoft Corporation) v15.4.3502.0922

NVIDIA PhysX (NVIDIA Corporation) v9.09.0814

Hotfixes 

KB982861 Update

982861 Update

KB971033 Update

KB958559 Update

KB917607 Update

KB2305420 Security Update

Startup Programs

Google Update "C:\Users\Administrator\AppData\Local\Google\Update\GoogleUpdate.exe" /c

..........From Location: HKU\S-1-5-21-1533419936-2843846854-521529397-500\SOFTWARE\Microsoft\Windows\CurrentVersion\Run

System Event Log Errors in the Last Week

EventCode=4107 Source=Microsoft-Windows-CAPI2 Time=01/08/2011 23:51:51

Failed extract of third-party root list from auto update cab at: with error: A required certificate is not within its validity period when verifying against the current system clock or the timestamp in the signed file. .

EventCode=6008 Source=EventLog Time=26/07/2011 07:35:29

The previous system shutdown at 23:58:09 on ‎25/‎07/‎2011 was unexpected.

--------------------------------------------------------------------------------

Collect System Information from Remote Computer

Note: You will need Administrator rights to access another computer (with a password set). 

Firewall on target computer may block access unless Windows Management Instrumentation (WMI) for Vista or Remote Administration for XP is allowed as an exception. 

Printer And File Sharing may need to be enabled on target computer. 

 Also list Printers, Software, Hotfixes, PCI IDs, EventLog Errors and Drivers (may take several minutes) User Name  User Password  Domain  Computer Name  

CODE

The entire sysinfo.hta (old version) file is shown below  (an icon file SysInfo.ico can also be present in the same folder)):

<html>

<head>

<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">

<title>System Information v1.2g</title>

<SCRIPT LANGUAGE="VBScript">

<!--

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

'System Info - by Steve Si

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

' Used constants

Const wbemFlagReturnImmediately = &h10

Const wbemFlagForwardOnly       = &h20

Const HKEY_LOCAL_MACHINE        = &H80000002

Const HKLM=&H80000002 'HKEY_LOCAL_MACHINE

Const HKCU=&H80000001 'HKEY_CURRENT_USER

Const REG_SZ=1

Const REG_EXPAND_SZ=2

Const REG_BINARY=3

Const REG_DWORD=4

Const REG_MULTI_SZ=7

Const HKCU_IE_PROXY = "Software\Microsoft\Windows\CurrentVersion\Internet Settings"

' Global variables

Dim objWMIService

Dim SearchString, MyWO, YourSN, MySN, MyGetInfo , YourGetInfo, strComputer

Dim strDomain, strUser, strPassword, OSNum, OSName

Dim ExtraList

Dim arrMonitorInfo()

Dim objSWbemLocator, objSWbemServices

Dim YourComputerName,MyComputerName

Dim CallID, EmailDest, LastSend, CurrentUser

Dim http

ExtraList = False 'don't list s/w etc by default

Set oReg=GetObject("winmgmts:!root/default:StdRegProv") 'local registry

Set  http = CreateObject( "MSXML2.XMLHTTP") 'http for sending email data

' -------------------------------- EMAIL SUBROUTINES -----------------------------------------

Sub SendEmail(HTML,WONUM,CNAME)

Dim Subject

Dim DefEmailDest

Dim x

on Error Resume Next

if HTML = "" then 

MsgBox "No information has been gathered yet!",0,"Nothing to Send!"

Exit Sub

End If

If LastSend = HTML then

MsgBox "This information has already been emailed - to send it again please press F5", 0,"Message already sent"

Else

DefEmailDest = ""

If EmailDest = "" then EmailDest = DefEmailDest

If CallID = "" then CallID = "CallID"

If HTML = "" Then

MsgBox "No information has been collected yet!"

Else

prmpt = "Enter Call Number" & vbcrlf & vbcrlf & "For reference purposes only." &_

vbCrLf & "These details are not automatically logged against a call number."

CallID = InputBox (prmpt,"Email to Support",CallID)

If CallID <> "" then

EmailDest = InputBox("Enter Destination Email address" & vbcrlf & vbcrlf & "Note: Must end in xx.com","Send to:",EmailDest)

EmailDest=tolower(EmailDest)

If EmailDest <> "" and ( instr(1,EmailDest,"@xx.com") > 1 OR instr(1,EmailDest,"@in.xx.com") > 1  )then

UserComments = GetUserInput

If UserComments <> "999XXX" then

x = Msgbox("Send to " & EmailDest & " now? ",1+256,CurrentUser) 'OKCancel + default button 2

If x = vbOK then

Subject = "SysInfo " & "Call ref: " & CallID

Subject = Subject & " - SN:" & WONUM & " - " & CName

Call SendHTMLEmail(Subject,UserComments & HTML,EmailDest)

LastSend=HTML

End If

End If

Else

MsgBox("Email address must end in @xx.com or @in.xx.com")

End If

End If

End If

End If

End Sub

'*******************

Sub SendHTMLEmail(Subject,HTMLBody,AddTo)

on Error Resume Next

domain = "http://www.xxx.net/cgi-bin/xxx"

afrom="SysInfo@xx.com"

x = httpPOST(domain, AddTo, afrom, Subject, HTMLBody) 'send email data to web page server

If instr(1,ucase(x),"SUCCESS") > 0 then 

msgbox "Email was sent to " & AddTo

Else

IEProxy = GetValue(HKCU,HKCU_IE_PROXY,"ProxyServer",REG_SZ) 

If IEProxy=vbnul then IEPROXY=""

If IsNul(IEProxy) then IEPROXY=""

If IEProxy="" then IEPROXY=" (no IE proxy set)" else IEPROXY=" - Proxy=" & IEPROXY

msgbox "Email could not be sent " & IEPROXY , 48

End If

End Sub

'*********

Function GetUserInput()

GetUserInput = ""

b = 1

While b < 99 'loop until we set b to 99 i = 1

Line = 1

Str = ""

htmlstr = "<br><br><b>Comments: </b><br>"

While Line < 99 'loop until we set Line to 99

prmpt = "Add your name and comments - Line " & Line

x = inputbox("Enter next line" & vbcrlf & "or click cancel to insert a blank line or if finished." & vbcrlf & vbcrlf & str,prmpt)

if x = "" then

ans = msgbox("Enter a blank line here (No=Finished)?",vbQuestion + vbYesNo,"Blank line here or Finished?")

if ans = vbNo then Line=99

str = str & vbCrLf

htmlstr = htmlstr & "<br>"

Else

str = str & x & vbCrLf

htmlstr = htmlstr & x & "<br>"

i = i + 1

End If

Wend

GetUserInput = htmlstr

butprmpt = "  Yes=OK to Send    No=Start Again        Cancel=Abort"

x = Msgbox("Comment correct?" & vbcrlf & vbcrlf & str & vbCrLf & vbCrLf & butprmpt,vbQuestion + vbYesNoCancel,"Check your comment is OK") 

If x = vbYes then Exit Function 'vbYes ?

If x = vbCancel then

GetUserInput = "999XXX"

Exit Function

End If

Wend

End Function

'*******

Public Function httpPOST(url, t, f, s, b)

on Error Resume Next

http.Open "POST", url, False

http.setRequestHeader  "Content-Type",  "application/x-www-form-urlencoded"

this = "to=" & escape(t) & "&from=" & escape(f) & "&subject=" & escape(s) & "&body=" & escape(b)

http.send this

httpPOST = http.responseText

End Function

'*****

Function GetHeader(url)

on Error Resume Next

http.open "GET",url,false

http.send

GetHeader=http.getAllResponseHeaders

End Function

'***

Function GetPage(url)

on Error Resume Next

http.open "GET",url,false

http.send

GetPage = http.responseText

End Function

'***

Public Function httpGET(url ) 

on Error Resume Next

http.Open "GET", url, False

http.send

httpGET = http.responseText

End Function

'****

Function GetValue(Key, SubKey, ValueName, KeyType)

Dim Ret

On Error Resume Next

Select Case KeyType

Case REG_SZ

oReg.GetStringValue Key, SubKey, ValueName, Value

Ret = Value

Case REG_EXPAND_SZ

oReg.GetExpandedStringValue Key, SubKey, ValueName, Value

Ret = Value

Case REG_BINARY

oReg.GetBinaryValue Key, SubKey, ValueName, Value

Ret = Value

Case REG_DWORD

oReg.GetDWORDValue Key, SubKey, ValueName, Value

Ret = Value

Case REG_MULTI_SZ

oReg.GetMultiStringValue Key, SubKey, ValueName, Value

Ret = Value

End Select

GetValue = Ret

End Function

 ' _____________________________ ***** End Email code *******

Function GetStartup(strComputer)

'List programs that run at Startup on a computer

x=""

Set colStartupCommands = objSWbemServices.ExecQuery ("SELECT * FROM Win32_StartupCommand")

For Each objStartupCommand in colStartupCommands

Name = trim(objStartupCommand.Name)

if Name <> "" and ucase(Name) <> "DESKTOP" then

x=x &  "<br><b>" & objStartupCommand.Name & "</b> "

x=x &  objStartupCommand.Command

x=x &  "<br>..........From Location: " & objStartupCommand.Location

'x=x &  " Description: " & objStartupCommand.Description

'x=x &  " SettingID: " & objStartupCommand.SettingID

'x=x &  " User: " & objStartupCommand.User

End If

Next

GetStartup="<br><b>Startup Programs</b>" & x & "<br>"

End Function

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

Function GetPrinters(strComputer)

On Error Resume Next

'List user printers

Set colInstalledPrinters =  objSWbemServices.ExecQuery ("Select * from Win32_Printer" )

For Each objPrinter in colInstalledPrinters

'get default printer separately into y so can list it first

if objPrinter.Default=True then y =  "<br>" & objPrinter.Name &  " <b> (DEFAULT PRINTER)</b>"  else   x = x &  "<br>" & objPrinter.Name 

Next

y = y & x

if ltrim(trim(y)) = "" then y = "<br>No printer drivers installed"

GetPrinters = "<br><b>Printer Drivers</b>" & y & "<br>"

End Function

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

Function EventErrors(strComputer)

Const CONVERT_TO_LOCAL_TIME = True

'List a weeks worth of Event errors

On Error Resume Next

Set dtmConvertedDate = CreateObject("WbemScripting.SWbemDateTime")

Set dtmStartDate = CreateObject("WbemScripting.SWbemDateTime")

Set dtmEndDate = CreateObject("WbemScripting.SWbemDateTime")

DateToCheck = CDate(Now)

dtmStartDate.SetVarDate DateToCheck -7, CONVERT_TO_LOCAL_TIME

dtmEndDate.SetVarDate DateToCheck, CONVERT_TO_LOCAL_TIME

Set colEvents = objSWbemServices.ExecQuery ("Select * from Win32_NTLogEvent Where TimeWritten >= '" & dtmStartDate & "' AND EventType=1") 

For Each objItem in colEvents

    x = x & "<br><font color=red>EventCode=" & objItem.EventCode 

    dtmConvertedDate.Value = objItem.TimeWritten

    dtmDate = dtmConvertedDate.GetVarDate

x = x & " Source=" & objItem.SourceName & " Time=" & dtmDate

    x = x & "</font><br>" & objItem.Message

Next

if x = "" AND OSNum > 17 then x = "<br>No errors found"

if x = "" AND OSNum < 18 then x = "<br>Cannot request event errors for " & OSName & " systems"

EventErrors = "<br><b>System Event Log Errors in the Last Week</b>" & x & "<br>"

End Function

' ---

Function FirstEventErrors(strComputer)

'List first 20 System Event Errors

On Error Resume Next

Set dtmConvertedDate = CreateObject("WbemScripting.SWbemDateTime")

Set colLoggedEvents = objSWbemServices.ExecQuery  ("SELECT * FROM Win32_NTLogEvent WHERE Logfile = 'System'")

intRecordNum = 0

x = ""

For Each objItem in colLoggedEvents

If objItem.EventType = 1 and intRecordNum < 20 Then

x = x & "<br><font color=red>EventCode=" & objItem.EventCode 

dtmConvertedDate.Value = objItem.TimeWritten

dtmDate = dtmConvertedDate.GetVarDate

x = x & " Source=" & objItem.SourceName & " Time=" & dtmDate

x = x & "</font><br>" & objItem.Message 

intRecordNum = intRecordNum +1

End If

Next

if x = "" AND OSNum > 17 then x = "<br>No errors found"

if x = "" AND OSNum < 18 then x = "<br>Cannot request event errors for " & OSName & " systems"

EventErrors = "<br><b>System Event Log Errors</b>" & x & "<br>"

End Function

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

Function ListPCI(strComputer)

'List the PCI IDs in this system

On error resume next

Set colItems = objSWbemServices.ExecQuery("Select * from Win32_PnPEntity",,48)

strMsg = "<br><b>PCI Device IDs</b><br>"

For Each objItem in colItems

if mid(objitem.DeviceID,1,7)="PCI\VEN" then

            strPCIID = formatPCIID(objItem.DeviceID)

            'strPCIID = objItem.DeviceID

            strPCIOUTPUT =  strPCIID & " " & objItem.Name 

            strMsg=strMsg &  strPCIOUTPUT  & "<br>"

end if

Next

ListPCI=strMsg

End Function

'******************************************************

'* Function to convert WMI PDI IDs to standard format *

'******************************************************

Function formatPCIID(strWMIPCIID)

        formatPCIID = Mid(strWMIPCIID, 8, 5) & Mid(strWMIPCIID, 17, 5) & "_" & Mid(strWMIPCIID, 34, 4) & "_" & Mid(strWMIPCIID, 30, 4) & " "

if instr(1,formatPCIID,"_") = 1 then formatPCIID=Mid(formatPCIID,2)

End Function

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

Function ListServerSW(strComputer)

On error resume next

'List installed software from the registry 

  Set objSWbemServicesX = objSWbemLocator.ConnectServer(strComputer, "root\default", strUser, strPassword, "MS_409", "ntlmdomain:" + strDomain)

  Set objReg = objSWbemServicesX.Get ("StdRegProv")

  Const strBaseKey =  "SOFTWARE\Research Machines\Installation\Products\"

  objReg.EnumKey HKLM, strBaseKey, arrSubKeys

  For Each strSubKey In arrSubKeys

x=1 'set to 1 if all sections wanted or comment out and use tests above

    If x > 0 then

strVValue=""

strDValue=""

strIValue=""

strSubKey1=""

objReg.GetStringValue HKLM, strBaseKey & strSubKey, "Version", strVValue

objReg.GetStringValue HKLM, strBaseKey & strSubKey, "Install Date", strDValue

'main subkeys do not have an 'Install' parameter

if  strVValue <> "" then 'remove x from xcolor if red wanted for display

strM =  strM  & "<font xcolor=red>" & strSubKey & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp" & " Version=" & strVValue & "&nbsp;&nbsp;&nbsp Install Date=" & strDValue & "<br></font>"

'uncomment  line below if details wanted

objReg.EnumKey HKLM, strBaseKey & strSubKey & "\", arrSubKeys1

For each strSubKey1 in arrSubKeys1

strVValue=""

strDValue=""

objReg.GetStringValue HKLM, strBaseKey  & strSubKey   & "\" & strSubKey1 & "\", "ProductVersion", strVValue

objReg.GetStringValue HKLM, strBaseKey  & strSubKey   & "\" & strSubKey1 & "\", "Path", strDValue

If IsNull(strVvalue) then strVvalue=""

V=""

D=""

If strVvalue<>"N/A" then V="&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp Version=" & strVValue

If strDvalue<>"N/A" then D="&nbsp;&nbsp;&nbsp Path=" & strDValue

If strVValue <> "" Then strM =  strM & "&nbsp;&nbsp; " &  strSubKey1 & V & D & "<br>"

Next

End if

End If

  Next

  Set objSWbemServicesX = nothing

If ltrim(trim(strM)) <> "" then 

 strMsg = StrMsg  & strM

 strMsg1 = "<b>Installed RM Software</b><br>"

 ListServerSW=strMsg1 & strMsg 

Else

 ListServerSW=""

End if

End Function

'======================================================================

Function ListHSP(strComputer)

On error resume next

HSP=0

HSPa=0

  Set objSWbemServicesX = objSWbemLocator.ConnectServer(strComputer, "root\default", strUser, strPassword, "MS_409", "ntlmdomain:" + strDomain)

  Set objReg = objSWbemServicesX.Get ("StdRegProv")

  Const strBaseKey =  "SOFTWARE\Research Machines\Installation\Products\"

  objReg.EnumKey HKLM, strBaseKey, arrSubKeys

  For Each strSubKey In arrSubKeys

    x = Instr(1,ucase(strSubKey),"HARDWARE SUPPORT PACK ")

    If x > 0 then

  y = mid(strSubKey,x+22) 'get HSP number

      HSPa = Cint(y) 'as integer

      if HSPa > HSP then 

      HSP=HSPa

      strVValue=""

      strDValue=""

      objReg.GetStringValue HKLM, strBaseKey & strSubKey, "Version", strVValue

      objReg.GetStringValue HKLM, strBaseKey & strSubKey, "Install Date", strDValue 

      If (strVValue <> "") and (strDValue <> "") Then strM =  strSubKey & "&nbsp;&nbsp;&nbsp Version=" & strVValue & "&nbsp;&nbsp;&nbsp Install Date=" & strDValue & "<br>"

End If

End If 

  Next

  Set objSWbemServicesX = nothing

If ltrim(trim(strM)) <> "" then 

 strMsg = StrMsg  & strM

 strMsg1 = "<br><b>Latest Installed HSP is HSP" & HSP & "</b>"

 ListHSP=strMsg1 & strMsg 

Else

 ListHSP=""

End if

End Function

'=========================

Function ListSW(strComputer)

'List the software installed on the computer

On error resume next

Set colSoftware = objSWbemServices.ExecQuery("Select * from Win32_Product")

if colSoftware.Count = 0 then  'Server 2003 does not respond to Win32_Product

 strMsg = "<br><b>Installed Software and HotFixes</b><br>"

 If strComputer="." then

  strHost = "."

  Set objReg = GetObject("winmgmts://" & strHost & "/root/default:StdRegProv")

  Const strBaseKey =  "Software\Microsoft\Windows\CurrentVersion\Uninstall\"

  objReg.EnumKey HKLM, strBaseKey, arrSubKeys

  For Each strSubKey In arrSubKeys

    intRet = objReg.GetStringValue(HKLM, strBaseKey & strSubKey, "DisplayName", strValue)

    If intRet <> 0 Then intRet = objReg.GetStringValue(HKLM, strBaseKey & strSubKey, "QuietDisplayName", strValue) 

    If (strValue <> "") and (intRet = 0) Then strM = strM & strValue & "<br>"

  Next

  End If

  if strM="" then strMsg=StrMsg & "No or cannot retrieve installed software on this system"   else strMsg=StrMsg  & strM

Else

 strMsg = "<br><b>Installed Software</b>"

 For Each objSoftware in colSoftware

    SWMsg = SWMsg & "<br>" & objSoftware.Caption & " (" & objSoftware.Vendor  & ") v" & objSoftware.Version  

 Next

if SWMsg = "" then SWMsg = "No installed software found"

strMsg = strMsg & SWMsg

 'Now get hotfixes installed

 strMsg = strMsg & "<br><br><b>Hotfixes</b>" & vbCrLf 

 Set colQuickFixes = objSWbemServices.ExecQuery("Select * from Win32_QuickFixEngineering" )

 if colQuickFixes.Count = 0 then strMsg= StrMsg & "No or cannot retrieve installed software on this system"

  For Each objQuickFix in colQuickFixes

            if objQuickFix.Description <> "" then 

                        desc = objQuickFix.Description

                        if len(desc)>70 then desc = mid(desc,1,50) & "..."

                        HFXMsg = HFXMsg & "<br>" & objQuickFix.HotFixID & " " & desc 

            end if

  Next

End if

if ltrim(trim(HFXMsg)) = "" then HFXMsg = "<br>No HotFixes found"

ListSW=strMsg & HFXMsg & "<br>"

End Function

'======================================================================

Function GetOSVer()

dim shell, strOS, strVerKey, strVersion

On error resume next

Set dtmConvertedDate = CreateObject("WbemScripting.SWbemDateTime")

Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")

Set colOperatingSystems = objSWbemServices.ExecQuery ("Select * from Win32_OperatingSystem")

For Each objOperatingSystem in colOperatingSystems

    dtmConvertedDate.Value = objOperatingSystem.InstallDate

    dtmInstallDate = dtmConvertedDate.GetVarDate

    if dtmInstallDate="" then dtmInstallDate="(unknown)"

    Other = objOperatingSystem.OtherTypeDescription

    org = objOperatingSystem.Organization

    dtmConvertedDate.Value = objOperatingSystem.LastBootUpTime

    BootTime = dtmConvertedDate.GetVarDate

    x = x &  objOperatingSystem.Caption

    x = x &   " - " & objOperatingSystem.CSDVersion

    x = x &   " (version=" & objOperatingSystem.Version & ") "

OSNum = objOperatingSystem.OSType

OSName = OSType(objOperatingSystem.OSType)

    IF objOperatingSystem.OSType <> 18 then x = x & "<br>OS Type=" & OSName & " " & Other

    x = x & "<br>SKU=" & SKU(objOperatingSystem.OperatingSystemSKU) 'only for Vista+ OS's

    if objOperatingSystem.ServicePackMajorVersion > 0 then x = x & "<br>Service Pack=v" & objOperatingSystem.ServicePackMajorVersion & "." & objOperatingSystem.ServicePackMinorVersion

    x = x & "<br>Architecture=" & objOperatingSystem.OSArchitecture

   ' x = x & "<br>Product Type=" & objOperatingSystem.ProductType

    x = x & "<br>Install Date=" & dtmInstallDate 

    x = x & "<br>Serial Number=" & objOperatingSystem.SerialNumber

    x = x & "<br>Total Visible Memory=" & FormatNumber(objOperatingSystem.TotalVisibleMemorySize/1024,0) & "MB"

    x = x & "<br>Free Physical Memory=" & FormatNumber(objOperatingSystem.FreePhysicalMemory/1024,1) & "MB"

    x = x & "<br>Total Virtual Memory=" & FormatNumber(objOperatingSystem.TotalVirtualMemorySize/1024,0) & "MB"

    x = x & "<br>Free Virtual Memory=" & FormatNumber(objOperatingSystem.FreeVirtualMemory/1024,0) & "MB"

    x = x & "<br>Windows Directory=" & objOperatingSystem.WindowsDirectory

    x = x & "<br>System Drive=" & objOperatingSystem.SystemDrive

    if objOperatingSystem.Description <> "" then x = x & "<br>Description=" & objOperatingSystem.Description

    x = x & "<br>User=" & objOperatingSystem.RegisteredUser

CurrentUser = objOperatingSystem.RegisteredUser

    if org <> "" then x = x & "<br>Organisation=" & Org 

    If BootTime <> "" then  x = x & "<br>Last Boot Up Time=" & BootTime

 Next 

GetOSVer = "<br><b>Operating System</b><br>" & x & "<br>"

End Function

'---

Function OSType(n)

if n=0 then OSType="Unknown"

if n=1 then OSType="Non-Windows"

if n=14 then OSType="MSDOS"

if n=15 then OSType="Win3x"

if n=16 then OSType="Win95"

if n=17 then OSType="Win98"

if n=18 then OSType="WinNT/XP"

if n=19 then OSType="WinCE"

if n=21 then OSType="Netware"

if n=30 then OSType="SunOS"

if n=36 then OSType="Linux"

if n=42 then OSType="FreeBSD"

End Function

'---

Function SKU(n)

if n=0 then SKU="Undefined"

if n=1 then SKU="Ultimate Edition"

if n=2 then SKU="Home Basic Edition"

if n=3 then SKU="Home Basic Premium Edition"

if n=4 then SKU="Enterprise Edition"

if n=5 then SKU="Home Basic N Edition"

if n=6 then SKU="Business Edition"

if n=7 then SKU="Standard Server Edition"

if n=8 then SKU="Datacenter Server Edition"

if n=9 then SKU="Small Business Server Edition"

if n=10 then SKU="Enterprise Server Edition"

if n=11 then SKU="Starter Edition"

if n=12 then SKU="Datacenter Server Core Edition"

if n=13 then SKU="Standard Server Core Edition"

if n=14 then SKU="Enterprise Server Core Edition"

if n=15 then SKU="Enterprise Server Edition for Itanium-Based Systems"

if n=16 then SKU="Business N Edition"

if n=17 then SKU="Web Server Edition"

if n=18 then SKU="Cluster Server Edition"

if n=19 then SKU="Home Server Edition"

if n=20 then SKU="Storage Express Server Edition"

if n=21 then SKU="Storage Standard Server Edition"

if n=22 then SKU="Storage Workgroup Server Edition"

if n=23 then SKU="Storage Enterprise Server Edition"

if n=24 then SKU="Server For Small Business Edition"

if n=25 then SKU="Small Business Server Premium Edition"

if n>25 then SKU="Unknown"

SKU=SKU & " (" & SKU & ")"

End Function

'=======================================================================

Function GetComputerName( )

On Error Resume Next

Set colItems = objSWbemServices.ExecQuery( "Select * from Win32_ComputerSystem", , wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each objItem in colItems

GetComputerName = objItem.Name

Next

End Function

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

Function GetProblemDev(strComp)

'List Problem Devices in Device manager

On Error Resume Next

Set colItems = objSWbemServices.ExecQuery("Select * from Win32_PnPEntity " &_

 " WHERE ConfigManagerErrorCode <> 0 AND NOT PNPDeviceID like 'SW%{B7EAFDC0-A680-11D0-96D8-00AA0051E51D}%'" , , wbemFlagReturnImmediately + wbemFlagForwardOnly)

For Each objItem in colItems

strErrorReason = ""

Select Case objItem.ConfigManagerErrorCode

Case 1

strErrorReason = "DEVICE IS NOT CONFIGURED CORRECTLY"

Case 2

strErrorReason = "WINDOWS CANNOT LOAD THE DRIVER FOR THIS DEVICE"

Case 3

strErrorReason = "DEVICE ENABLED BUT NOT WORKING"

Case 4

strErrorReason = "DEVICE IS NOT WORKING - DRIVERS OR REGISTRY MAY BE CORRUPT"

Case 5

strErrorReason = "DRIVER FOR THIS DEVICE NEEDS A RESOURCE THAT WINDOWS CANNOT MANAGE"

Case 6

strErrorReason = "THE BOOT CONFIGURATION FOR THIS DEVICE CONFLICTS WITH OTHER DEVICES"

Case 7

strErrorReason = "CANNOT FILTER"

Case 8

strErrorReason = "THE DRIVER LOADER FOR THE DEVICE IS MISSING"

Case 9

strErrorReason = "DEVICE NOT WORKING AS CONTROLLING FIRMWARE REPORTS INCORRECT RESOURCE"

Case 10

strErrorReason = "THIS DEVICE CANNOT START"

Case 11

strErrorReason = "THIS DEVICE FAILED"      

Case 12

strErrorReason = "DEVICE CANNOT FIND ENOUGH FREE RESOURCE FOR IT TO USE"

Case 13

strErrorReason = "WINDOWS CANNOT VERIFY THIS DEVICES RESOURCES"   

Case 14

strErrorReason = "DEVICE CANNOT WORK PROPERLY UNTIL THE COMPUTER IS RESTARTED"

Case 15

strErrorReason = "DEVICE CANNOT WORK BECAUSE THERE IS A A RE-ENUMERATION PROBLEM"

Case 16

strErrorReason = "WINDOWS CANNOT IDENTIFY ALL THE RESOURCES THIS DEVICE USES"

Case 17

strErrorReason = "DEVICE IS ASKING FOR AN UNKNOWN RESOURCE TYPE"

Case 18

strErrorReason = "REINSTALL THE DRIVER FOR THIS DEVICE"   

Case 19

strErrorReason = "FAILURE USING THE VXD LOADER"    

Case 20

strErrorReason = "REGISTRY MIGHT BE CORRUPTED"           

Case 21

strErrorReason = "SYSTEM FAILURE: CHANGE THE DRIVER FOR THIS DEVICE"

Case 22

strErrorReason = "DEVICE IS DISABLED"

Case 23

strErrorReason = "SYSTEM FAILURE: CHANGE THE DRIVER FOR THIS DEVICE"

Case 24

strErrorReason = "DEVICE IS NOT PRESENT, NOT WORKING OR DRIVER IS NOT INSTALLED"

Case 25

strErrorReason = "WINDOWS IS STILL SETTING UP THIS DEVICE"

Case 26

strErrorReason = "WINDOWS IS STILL SETTING UP THIS DEVICE"            

Case 27

strErrorReason = "DEVICE DOES NOT HAVE A VALID LOG CONFIGURATION"

Case 28

strErrorReason = "DRIVERS FOR THIS DEVICE ARE NOT INSTALLED"  

Case 29

strErrorReason = "DEVICE IS DISABLED AS THE FIRMWARE DID NOT GIVE IT THE REQUIRED RESOURCE"

Case 30

strErrorReason = "DEVICE IS USING AN INTERRUPT REQUEST (IRQ) RESOURCE THAT ANOTHER DEVICE IS USING"

Case 31

strErrorReason = "DEVICE IS NOT WORKING AS WINDOWS CANNOT LOAD DRIVERS REQUIRED FOR IT"

Case Else

strErrorReason = "PROBLEM DEVICE - REASON UNKNOWN"

End Select

T =   "<br><b><font color=red>ERROR " & objItem.ConfigManagerErrorCode & ": " & strErrorReason & "</font></b> " & T

If strErrorReason <> "" Then 

T = T & " <font color=violet>" & objItem.Description  & "</font> "

T = T & "<br>" & objItem.DeviceID 

End If

S = S & T

Next

if S = "" then S = "<br>No problem devices found" & "<br>"

GetProblemDev = "<br><b>Problem Devices or Drivers</b>" & S & "<br>"

End Function

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

Function LogFile( x ) 

'Log results to a file

Dim objFS, objTestLog, objWMIService

On Error Resume Next

if x<>"" then

    MyFile = InputBox ("Enter Filename (xxx.htm)","Save " & MySN & " as File","D:\" & MySN & ".htm")

    if MyFile <> "" then

Set ObjFS = CreateObject("Scripting.FileSystemObject")

Set ObjTestLog = objFS.CreateTextFile(MyFile)

ObjTestLog.WriteLine x

Set ObjFS = Nothing

Set ObjTestLog = Nothing

If err.number <> vbEmpty then Msgbox "Error: Folder may not exist or you do not have write access permission (Error " & err.number & ")",48

    end if

end if

End Function

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

Function ListAccounts()

'List computers in a domain

On Error Resume Next

if strDomain="" then strDomain="WORKGROUP"

strDomain = inputbox ("Enter Domain name (e.g. WORKGROUP)","List Computers",strDomain)

if strDomain <> "" then

Set objDomain = GetObject("WinNT://" & strDomain ) 

objDomain.Filter = Array("computer") 

For Each Computer In objDomain 

y= y & "<Font color = fuchsia>" & Computer.Name  & "</Font> , "

Next

x = "<b>Computers in the domain: " & UCase(strDomain) & "</b><b><font color=red><br>"

AccountArea.InnerHtml = x & y & "</b></font>"

End if

End function

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

Function SetName()

'Get the info from a remote computer

On Error Resume Next

if Ausername.value <> "" and Adomain.value <> "" and AComputer.value <> "" then

  strUser = AUsername.value

  strDomain = Adomain.value

  strPassword = APAssword.value

  strComputer = AComputer.value

if strComputer <> "" then 

ExtraList = Checkbox2.checked

DataArea.InnerHtml = "Accessing remote computer " & UCase(strComputer) & " - please wait..."

If ExtraList Then MsgBox "Please be patient - this may take some time!"

x = GetWo()

if x = -2147024891 then x = "Computer was found but access was denied!"

if x = -2147023174 then x = "Computer not found in domain " & UCase(strDomain)

if x = -2147217308 then x = "User credentials cannot be used for local computer"

if x="OK" then x = GetInfo() else x = "Error accessing " & UCase(strComputer) & " - Error: " & x

        DataArea.InnerHtml = x

end if

end if

End function

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

Function GetDrivers(strComp)

Dim  propValue, colItems, strDesc, strDrvVer, strDrvDate, strInf, strIsSigned, strFailure

Dim DriverTable

'List MS drivers and 3rd party drivers - indicate if signed or not

On Error Resume Next

Set colItems = objSWbemServices.ExecQuery("Select * from Win32_PnPSignedDriver WHERE InfName Like '%.inf%'","WQL",48)

For Each objItem in colItems

    if instr(1,ucase(objItem.InfName),"OEM")=1 then

     strDrvDate = WMIDateStringToDate(objItem.DriverDate)

     if objItem.IsSigned then sig="Signed" else sig="UNSIGNED"

     DriverTable = DriverTable & LogDrvVer(objItem.Description, objItem.DriverVersion, strDrvDate, objItem.InfName, sig, objItem.DeviceID)

    end if

Next

Set colItems = Nothing

Set objWMIService = Nothing

x = "<br><b>Installed Third Party Drivers</b><br>The following drivers are not 'In-Box' Windows drivers:" & DriverTable & "<br>"

DriverTable=""

Set colItems = objSWbemServices.ExecQuery("Select * from Win32_PnPSignedDriver WHERE InfName Like '%.inf%'","WQL",48)

For Each objItem in colItems

    if instr(1,ucase(objItem.InfName),"OEM")<>1 then

     strDrvDate = WMIDateStringToDate(objItem.DriverDate)

     if objItem.IsSigned then sig="Signed" else sig="UNSIGNED"

     DriverTable = DriverTable & LogDrvVer(objItem.Description, objItem.DriverVersion, strDrvDate, objItem.InfName, sig, objItem.DeviceID)

    end if

Next

Set colItems = Nothing

Set objWMIService = Nothing

GetDrivers = x & "<br><br><b>Installed In-Box Drivers</b><br>The following drivers are 'In Box' Windows drivers:" & DriverTable & "<br>"

End Function

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

'  Function to convert date string to correct format

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

Function WMIDateStringToDate(dtmWMIDate)

If Not IsNull(dtmWMIDate) Then

WMIDateStringToDate = CDate(Mid(dtmWMIDate, 5, 2) & "/" &_

Mid(dtmWMIDate, 7, 2) & "/" & Left(dtmWMIDate, 4) & " " & Mid (dtmWMIDate, 9, 2) & ":" &_

Mid(dtmWMIDate, 11, 2) & ":" & Mid(dtmWMIDate,13, 2))

End If

End Function

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

' log driver versions to file

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

Function LogDrvVer(strDesc, strDrvVer, strDrvDate, strInf, strDrvSig, xx) 

myredon = "<a style=" & chr(34) & "color: red " & chr(34) & "><b>"

myfon = "<a style=" & chr(34) & "color: violet " & chr(34) & "><b>"

myoff = "</a></b>"

mypad = "&nbsp;&nbsp;&nbsp;"

LogDrvVer=  myredon & "<br>" & strDesc  & mypad & myoff & myfon &" v." & strDrvVer  & mypad & strDrvDate & myoff & "<br>" & strDrvSig  & " " & xx 

End Function

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

'  Subroutine to set length of string variables

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

Sub VarLength(strString, intMaxCha, intSpaces)

Dim intTemp,i

on error resume next

strString=strString & "" 'force it to be a string

intTemp=0

strString = Left(strString, intMaxCha)

intTemp = intSpaces + intMaxCha - (Len(strString))

For i = 0 To intTemp

strString = strString & "&nbsp;"

Next

End Sub

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

Function InventoryCDR( strComputer )

On Error Resume Next

cntCDR=0

Set colItems      = objSWbemServices.ExecQuery( "SELECT * FROM Win32_CDROMDrive", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each objItem In colItems

' Parse the PNP Device ID string to get the interface and firmware revision

' Example:

' IDE\CDROM_NEC_DVD_RW_ND-3520AW___________________3.05____\5&2E27B08F&0&0.0.0

' ===  <-  interface                               ====  <-  firmware revision

' The array arrDevID will contain 3 elements: "IDE",

' "CDROM_NEC_DVD_RW_ND-3520AW___________________3.05____" and "5&2E27B08F&0&0.0.0"

arrDevID     = Split( objItem.DeviceID, "\", 3, vbTextCompare )

strInterface = arrDevID(0)

strDeviceId  = arrDevID(1)

' In our example, strDeviceID will contain "CDROM_NEC_DVD_RW_ND-3520AW___________________3.05____"

' The array arrFirmware will contain the elements "CDROM", "NEC", "DVD", "RW", "ND-3520AW", "3.05" and ""

' strFirmware is assigned the value of the last non-empty element in the array

arrFirmware  = Split( strDeviceId, "_", -1, vbTextComapre )

cnt = 0

For Each strElement In arrFirmware

  If strElement <> vbNul Then strFirmware = strElement

  if cnt < 4 then CDName = CDName & " " & strElement

  cnt = cnt + 1

Next

if objItem.Name <> "" then CDName = ""    'no need if valid CDName

   x = x & "<br>" &  objItem.Name & " [" & trim(CDName)

   x = x & "Firmware=" &  strFirmware & "]"

Next

InventoryCDR= "<br><b>Optical Drives</b>" & x  & "<br>"

End Function

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

Function InventoryVideo( strComputer )

On Error Resume Next

Set colItems = objSWbemServices.ExecQuery( "Select * from Win32_VideoController","WQL" , wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each objItem in colItems

if objItem.Name <> "" then

x = x &  "<br>" & objItem.Name

x = x &  " - " & objItem.VideoModeDescription

x = x & " (" & Round( objItem.AdapterRAM / 1048576 ) & "MB)"

End If

Next

InventoryVideo= "<br><b>Video</b>" & x & "<br>"

End Function

'--------

Function InventorySound( strComputer )

On Error Resume Next

Set colItems = objSWbemServices.ExecQuery( "SELECT * FROM Win32_SoundDevice", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each objItem In colItems

x = x &  "<br>" & objItem.Manufacturer

x = x &  " " & objItem.ProductName

Next

if x = "" then x = "<br>No Audio devices detected"

InventorySound  = "<br><b>Audio</b>" & x & "<br>"

End Function

' ___________

Function InventoryTapeDrive ( strComputer )

Set colItems = objSWbemServices.ExecQuery("Select * from Win32_TapeDrive")

For Each objItem In colItems

  Caption=ltrim(objItem.Caption)

  Ecode=objItem.ConfigManagerErrorCode

  If Ecode=0 then Estr="OK"

  If Ecode=1 then Estr="Not Configured correctly"

  If Ecode>1 then Estr="Windows driver/resources fault"

  If Ecode=7 then Estr="Cannot filter"

  If Ecode=9 then Estr="Device not working correctly - bad firmware?"

  If Ecode=10 then Estr="Device cannot start"

  If Ecode=11 then Estr="Device Failed"

  If Ecode=14 then Estr="Not working - Restart required"

  If Ecode=15 then Estr="Device detection problem?"

  If Ecode=31 then Estr="Cannot load device drivers"

  If Ecode=30 then Estr="IRQ resource clash"

  If Ecode=29 then Estr="Device disabled - firmware bad?"

  If Ecode=24 then Estr="Not present or missing drivers"

  If Ecode=22 then Estr="Device is disabled"

'Desc=ltrim(objItem.Description) & ""

'ID=ltrim(objItem.Id) & ""

  Mfr=ltrim(objItem.Manufacturer) & ""

'Name=ltrim(objItem.Name) & ""

  BoolClean=ObjItem.NeedsCleaning

  if BoolClean then Clean="TAPE DRIVE NEEDS CLEANING" else Clean=""

  Status = ltrim(objItem.Status) & ""

  SysName=ltrim(objItem.SystemName) & ""

  if caption<>""  then  x = x & "<br><b><font color=red>" & Caption & "</font></b>" 

'if Desc<>""     then  x = x & "<br>Description=" & Desc

  if SysName<>""  then  x = x & "<br>System Name=" & SysName

'if Name<>""     then  x = x & "<br>Name=" & Name

'if ID<>""       then  x = x & "<br>ID=" & ID

  if Mfr<>""      then  x = x & "<br>Manufacturer=" & Mfr

  if ECode<>""    then  x = x & "<br>Error Status=" & ECode

  if Clean <> ""  then  x = x & "<br>Cleaning status=" & Clean

  if Status <> "" then  x = x & "<br>Tape Drive Status=" & Status

Next

if x = "" then x = "<br>No tape drives found" 

InventoryTapeDrive = "<br><b>Tape Drives</b>" & x & "<br>"

End Function

'_________________

Function InventoryNIC( strComputer )

On Error Resume Next

'Modified to work for 98 and XP systems 

Set col1Items = objSWbemServices.ExecQuery( "SELECT * FROM Win32_NetworkAdapter", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each obj1Item In col1Items

if instr(1,obj1Item.PNPDeviceID,"USB\") OR ( obj1item.Manufacturer <> "Microsoft" AND obj1item.MACAddress <> "" AND instr(1,obj1item.AdapterType,"thernet") ) then 

 x  = x  &  "<br>" & obj1Item.ProductName 

 y = GetNICSpeed( obj1Item.ProductName, StrComputer )

 if y <> "" then x = x & " (" & y  & ")"

 x = x & " MAC=" &  Join( Split( obj1Item.MACAddress, ":", -1, vbTextCompare ), "" )

 end if

Next

InventoryNIC = "<b><br>Network Adapters</b>" & x & "<br>"

InventoryNIC = InventoryNIC & ListIPAdds(strComputer) & "<br>" 'get IP addresses

End Function

'_________________

Function GetNICSpeed( strInstance, strComputer )

On Error Resume Next

Set objSWbemServices2 = objSWbemLocator.ConnectServer( strComputer,"root\WMI", strUser, strPassword, "MS_409", "ntlmdomain:" + strDomain)

Set col2Items = objSWbemServices2.ExecQuery( "SELECT * FROM MSNdis_LinkSpeed WHERE InstanceName LIKE '" & strInstance & "' AND Active = True", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each obj2Item In col2Items

If obj2Item.NdisLinkSpeed < 10000 Then strNICSpeed = obj2Item.NdisLinkSpeed /    10 & " Kb/s"

If obj2Item.NdisLinkSpeed > 9999  Then strNICSpeed = obj2Item.NdisLinkSpeed / 10000 & " Mb/s"

If obj2Item.NdisLinkSpeed < 100   Then strNICSpeed = obj2Item.NdisLinkSpeed

Next

GetNICSpeed = strNICSpeed

End Function

'----

Function ListIPAdds( strComputer )

on error resume next

ListIPAdds = ""

Set IPConfigSet = objSWbemServices.ExecQuery ("Select * from Win32_NetworkAdapterConfiguration where IPEnabled=TRUE",,48) 

   For Each IPConfig In IPConfigSet 

        If Not IsNull(IPConfig.IPAddress) Then 

            For i=LBound(IPConfig.IPAddress) To UBound(IPConfig.IPAddress) 

if LastMac <> IPConfig.MACAddress then ListIPAdds = ListIPAdds &  "<br>MAC Address " & IPConfig.MACAddress & " is using IPAddress: " & IPConfig.IPAddress(i)  &  " Subnet: " & IPConfig.IPSubnet(i) 

LastMac = IPConfig.MACAddress

            Next 

        End If 

    Next

End Function

'_________________

Function InventoryMem( strComputer )

On Error Resume Next

cntMem=0

sizMem=0

' Capacity filter intended for HP/COMPAQ EVO models

Set colItems = objSWbemServices.ExecQuery( "SELECT * FROM Win32_PhysicalMemory  WHERE Capacity > 524288", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)

For Each objItem in colItems

    x = Round(objItem.capacity / 1048576 ) & "MB"

    if objItem.Speed <> "" then s = " (speed=" & objItem.Speed & ")"

    y = trim(objItem.BankLabel)

    if y <> "" then y = y & "="

    sno=ltrim(trim(objitem.SerialNumber))

    pno = ltrim(trim(objitem.PartNumber))

    if pno & sno <> "" then

    if sno <> "" then sno = " SNo=" & sno

    if pno <> "" then pno = "Pno=" & pno

    sno = " (" & pno & sno & ")"

    end if

    sData = sData & "<br>" & y & x & sno

    cntMem = cntMem + 1

    sizMem = sizMem + objItem.Capacity

Next

MemoryModules = cntMem 

MemorySize    = Round( sizMem / 1048576 )

MemoryBanks=-1

Set colItems = objSWbemServices.ExecQuery( "SELECT * FROM Win32_PhysicalMemoryArray", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly )

For Each objItem In colItems

if objItem.MemoryDevices > MemoryBanks then MemoryBanks = objItem.MemoryDevices

Next

InventoryMem  =  "<br><b>Memory</b><br>"

if MemoryBanks > -1 then InventoryMem = InventoryMem & "Total Memory slots=" & MemoryBanks & "<br>Empty Memory slots=" & MemoryBanks - MemoryModules 

InventoryMem = InventoryMem & "<br>Used Memory slots=" &  MemoryModules & "<br>Total Memory=" & MemorySize & "MB"

InventoryMem = InventoryMem  & sData & "<br>"

End Function

'_________________

Function Lpad (MyValue, MyPadChar, MyPaddedLength)

    Lpad = string(MyPaddedLength - Len(MyValue),MyPadChar) & MyValue

End Function

Function Rpad (MyValue, MyPadChar, MyPaddedLength)

    Rpad = MyValue & string(MyPaddedLength - Len(MyValue), MyPadChar)

End Function