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

Part of the final output as it appears to the user

SysInfo is an hta script (html application) which can be used to display information collected from your computer or any computer you have Admin access to on your network.

If you download the zip file and use NotePad to look at the SysInfo.hta file, you will find lots of useful vb script code which you can use in your own scripts.

Some of the more unusual features are:

1. Find the native screen resolution of your display (useful for TFT monitors) + lists screen size and resolution and monitor serial number, etc.

2. List PCI IDs and native Windows + 3rd party drivers

3. List installed software, disk volumes sizes and free space, HDD make and models, etc.

4. List Event log errors for last 7 days (filtered by type and date)

5. Lists Nic Ethernet connection speed, MAC addresses, IP addresses

6. Lists Memory DIMMs, filled and available slots, DIMM Serial numbers (if Win7/SVR2K8R2)

7. Lists SMBIOS/DMI mainboard values

8. List 'Problem devices and drivers'

9. Get same information on any system on the network (provided you have Admin access and they have been set up correctly - see form for details).

10. Send a report email via http - (this feature requires that you set up a server so that when it receives an http post packet, it emails the data contents to the correct recipient. In this way the end user can email anyone without needing an active Exchange account. Just http access is required. If you do not have your own web server then remove the email code as it won't work. You could code it to use your own webmail account instead, but you would have to include your account password in the .hta code which may pose a security risk and also means you could never change the password.)

SysInfo2.hta uses a gmail server (gmail account required).

11. Export report to a file

12. Hot fixes

13. Startup programs

14. Printers (inc. which one is the default)

15. Graphics adapter and current resolution

...and much more.

Download and run this .hta vbscript file sysinfo.zip or latest gmail version sysinfo2.zip

You can easily modify the script to add your own Company heading, etc.

If sysinfo.ico is in the same folder, it will be used as the icon (top left of form) instead of the default .hta Windows icon.

How to set up SysInfo2 for use with gmail

SysInfo2.hta is a later revision which allows you to use a gmail account to email the report to anyone else (or to your email address).

You can send from a Gmail account to any other email address by using the Gmail server.

I suggest you create a new Gmail account and then scroll down in your Google account options page and set it for 'Allow less secure apps' - it will not work unless the account is set for less secure apps!

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>

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

<!--

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

'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

Else

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

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 = " Comments: "

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 & " "

Else

str = str & x & vbCrLf

htmlstr = htmlstr & x & " "

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 & " " & objStartupCommand.Name & " "

x=x & objStartupCommand.Command

x=x & " ..........From Location: " & objStartupCommand.Location

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

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

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

End If

GetStartup=" Startup Programs" & x & " "

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 = " " & objPrinter.Name & " (DEFAULT PRINTER)" else x = x & " " & objPrinter.Name

y = y & x

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

GetPrinters = " Printer Drivers" & y & " "

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 & " EventCode=" & objItem.EventCode

dtmConvertedDate.Value = objItem.TimeWritten

dtmDate = dtmConvertedDate.GetVarDate

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

x = x & " " & objItem.Message

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

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

EventErrors = " System Event Log Errors in the Last Week" & x & " "

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 & " EventCode=" & objItem.EventCode

dtmConvertedDate.Value = objItem.TimeWritten

dtmDate = dtmConvertedDate.GetVarDate

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

x = x & " " & objItem.Message

intRecordNum = intRecordNum +1

End If

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

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

EventErrors = " System Event Log Errors" & x & " "

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 = " PCI Device IDs "

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 & " "

end if

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 & "" & strSubKey & "     &nbsp" & " Version=" & strVValue & "  &nbsp Install Date=" & strDValue & " "

'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 Version=" & strVValue

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

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

End if

End If

Set objSWbemServicesX = nothing

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

strMsg = StrMsg & strM

strMsg1 = "Installed RM Software "

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 Version=" & strVValue & "  &nbsp Install Date=" & strDValue & " "

End If

Set objSWbemServicesX = nothing

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

strMsg = StrMsg & strM

strMsg1 = " Latest Installed HSP is HSP" & HSP & ""

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 = " Installed Software and HotFixes "

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 & " "

End If

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

Else

strMsg = " Installed Software"

For Each objSoftware in colSoftware

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

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

strMsg = strMsg & SWMsg

'Now get hotfixes installed

strMsg = strMsg & " Hotfixes" & 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 & " " & objQuickFix.HotFixID & " " & desc

end if

End if

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

ListSW=strMsg & HFXMsg & " "

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 & " OS Type=" & OSName & " " & Other

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

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

x = x & " Architecture=" & objOperatingSystem.OSArchitecture

' x = x & " Product Type=" & objOperatingSystem.ProductType

x = x & " Install Date=" & dtmInstallDate

x = x & " Serial Number=" & objOperatingSystem.SerialNumber

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

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

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

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

x = x & " Windows Directory=" & objOperatingSystem.WindowsDirectory

x = x & " System Drive=" & objOperatingSystem.SystemDrive

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

x = x & " User=" & objOperatingSystem.RegisteredUser

CurrentUser = objOperatingSystem.RegisteredUser

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

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

GetOSVer = " Operating System " & x & " "

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

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 = " ERROR " & objItem.ConfigManagerErrorCode & ": " & strErrorReason & " " & T

If strErrorReason <> "" Then

T = T & " " & objItem.Description & " "

T = T & " " & objItem.DeviceID

End If

S = S & T

if S = "" then S = " No problem devices found" & " "

GetProblemDev = " Problem Devices or Drivers" & S & " "

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 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 & "" & Computer.Name & " , "

x = "Computers in the domain: " & UCase(strDomain) & " "

AccountArea.InnerHtml = x & y & ""

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 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

Set colItems = Nothing

Set objWMIService = Nothing

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

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

Set colItems = Nothing

Set objWMIService = Nothing

GetDrivers = x & " Installed In-Box Drivers The following drivers are 'In Box' Windows drivers:" & DriverTable & " "

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) & ">"

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

myoff = "</a>"

mypad = "   "

LogDrvVer= myredon & " " & strDesc & mypad & myoff & myfon &" v." & strDrvVer & mypad & strDrvDate & myoff & " " & 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 & " "

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

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

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

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

InventoryCDR= " Optical Drives" & x & " "

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 & " " & objItem.Name

x = x & " - " & objItem.VideoModeDescription

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

End If

InventoryVideo= " Video" & x & " "

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 & " " & objItem.Manufacturer

x = x & " " & objItem.ProductName

if x = "" then x = " No Audio devices detected"

InventorySound = " Audio" & x & " "

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 & " " & Caption & ""

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

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

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

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

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

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

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

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

if x = "" then x = " No tape drives found"

InventoryTapeDrive = " Tape Drives" & x & " "

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 & " " & obj1Item.ProductName

y = GetNICSpeed( obj1Item.ProductName, StrComputer )

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

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

end if

InventoryNIC = " Network Adapters" & x & " "

InventoryNIC = InventoryNIC & ListIPAdds(strComputer) & " " '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

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 & " MAC Address " & IPConfig.MACAddress & " is using IPAddress: " & IPConfig.IPAddress(i) & " Subnet: " & IPConfig.IPSubnet(i)

LastMac = IPConfig.MACAddress

End If

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 & " " & y & x & sno

cntMem = cntMem + 1

sizMem = sizMem + objItem.Capacity

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

InventoryMem = " Memory "

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

InventoryMem = InventoryMem & " Used Memory slots=" & MemoryModules & " Total Memory=" & MemorySize & "MB"

InventoryMem = InventoryMem & sData & " "

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

'_________________

Private Function PadSpace( strInput1, Length )

' Replace spaces with &nbsp

'note due to proportional typefont, spaces will not take up as much space as an M say!

On Error Resume Next

strInput = RPad(strInput1," ", Length) 'pad string to n chars

For i = 1 to Len(strInput)

x=Mid( strInput, i,1 )

if x = " " then PadSPace = PadSpace & " " else PadSpace=PadSpace & x

End Function

'_________________

Private Function Strip( strInput )

' Strip leading spaces

On Error Resume Next

Do While Left( strInput, 1 ) = " "

strInput = Mid( strInput, 2 )

Loop

Strip = strInput

End Function

'___________________

Function InventoryMon( strComputer )

On Error Resume Next

'some code by Michael Baird with thanks

Dim strarrRawEDID()

intMonitorCount=0

sBaseKey = "SYSTEM\CurrentControlSet\Enum\DISPLAY\"

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

set oRegistry = oRoot.Get("stdregprov")

'enumerate all the keys HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\

iRC = oRegistry.EnumKey(HKLM, sBaseKey, arSubKeys)

For Each sKey In arSubKeys

'we are now in the registry at the level of:

'HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\<VESA_Monitor_ID\

'we need to dive in one more level and check the data of the "HardwareID" value

sBaseKey2 = sBaseKey & sKey & "\"

iRC2 = oRegistry.EnumKey(HKLM, sBaseKey2, arSubKeys2)

For Each sKey2 In arSubKeys2

'now we are at the level of:

'HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\<VESA_Monitor_ID\<PNP_ID>\

'so we can check the "HardwareID" value

oRegistry.GetMultiStringValue HKLM, sBaseKey2 & sKey2 & "\", "HardwareID", sValue

for tmpctr=0 to ubound(svalue)

if lcase(left(svalue(tmpctr),8))="monitor\" then

'if it is a monitor we will check for the existance of a control subkey

'that way we know it is an active monitor

sBaseKey3 = sBaseKey2 & sKey2 & "\"

iRC3 = oRegistry.EnumKey(HKLM, sBaseKey3, arSubKeys3)

For Each sKey3 In arSubKeys3

if skey3="Control" then

'if the Control sub-key exists then we should read the edid info

'Next line is Bugfix for multiple monitors - thanks to Sean H (2014-06-13)

strRawEDID=""

oRegistry.GetBinaryValue HKLM, sbasekey3 & "Device Parameters\", "EDID", arrintEDID

if vartype(arrintedid) <> 8204 then 'and if we don't find it...

strRawEDID="EDID Not Available" 'store an "unavailable message

else

for each bytevalue in arrintedid 'otherwise conver the byte array from the registry into a string (for easier processing later)

strRawEDID=strRawEDID & chr(bytevalue)

end If

'now take the string and store it in an array, that way we can support multiple monitors

redim preserve strarrRawEDID(intMonitorCount)

strarrRawEDID(intMonitorCount)=strRawEDID

intMonitorCount=intMonitorCount+1

end if

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

'now the EDID info for each active monitor is stored in an array of strings called strarrRawEDID

'so we can process it to get the good stuff out of it which we will store in a 5 dimensional array

'called arrMonitorInfo, the dimensions are as follows:

'0=VESA Mfg ID, 1=VESA Device ID, 2=MFG Date (M/YYYY),3=Serial Num (If available),4=Model Descriptor

'5=EDID Version

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

redim arrMonitorInfo(intMonitorCount-1,7)

dim location(3)

for tmpctr=0 to intMonitorCount-1

if strarrRawEDID(tmpctr) <> "EDID Not Available" then

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

'first get the model and serial numbers from the vesa descriptor

'blocks in the edid. the model number is required to be present

'according to the spec. (v1.2 and beyond)but serial number is not

'required. There are 4 descriptor blocks in edid at offset locations

'&H36 &H48 &H5a and &H6c each block is 18 bytes long

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

location(0)=mid(strarrRawEDID(tmpctr),&H36+1,18)

location(1)=mid(strarrRawEDID(tmpctr),&H48+1,18)

location(2)=mid(strarrRawEDID(tmpctr),&H5a+1,18)

location(3)=mid(strarrRawEDID(tmpctr),&H6c+1,18)

'54–71: Descriptor Block 1

' 54–55: Pixel Clock (in 10 kHz) or 0

' If Pixel Clock is non null:

' 56: Horizontal Active (in pixels)

' 57: Horizontal Blanking (in pixels)

' 58: Horizontal Active high (4 upper bits)

' Horizontal Blanking high (4 lower bits)

' 59: Vertical Active (in pixels)

' 61: Vertical Active high (4 upper bits)

' Vertical Blanking high (4 lower bits)

ssd = mid(strarrRawEDID(tmpctr),&H18+1,1) '18h bit 1 set = preferred timing (native res)

ssd = asc(ssd) AND &H02

if ssd = 2 then

ssd = mid(strarrRawEDID(tmpctr),56+1,1) 'get first byte LSB

ssxx = Asc(ssd) 'get LSB

ssd = mid(strarrRawEDID(tmpctr),58+1,1) 'get upper 4 bits in byte

ssd = Asc(ssd) And &Hf0

ssxx = ssxx + ssd * 16

ssd = mid(strarrRawEDID(tmpctr),59+1,1) 'get vert

ssy = asc(ssd) 'get LSB

ssd = mid(strarrRawEDID(tmpctr),61+1,1) 'get upper 4 bits in byte

ssd = Asc(ssd) And &Hf0

ssy = ssy + ssd * 16

tmpnative = ssxx & " x " & ssy

'Now report size of screen

'66 42 Horizontal Image Size = xxx mm (lower 8 bits)

'67 43 Vertical Image Size = xxx mm (lower 8 bits)

'68 44 Horizontal & Vertical Image Size (upper 4:4 bits)

ssd = mid(strarrRawEDID(tmpctr),66+1,1) 'get LSB Hsize

ssH = Asc(ssd)

ssd = mid(strarrRawEDID(tmpctr),68+1,1) 'get MSB Hsize

ssd = asc(ssd) And &HF0

ssH = ssH + ssd * 16 'get H size

ssd = mid(strarrRawEDID(tmpctr),67+1,1) 'get LSB Hsize

ssV = Asc(ssd)

ssd = mid(strarrRawEDID(tmpctr),68+1,1) 'get MSB Hsize

ssd = asc(ssd) And &H0F

ssV = ssV + ssd * 256 'get H size

tmpScrSize = ssH & "mm x " & ssV & "mm "

'print diagonal size of screen

diag = ssH*ssH + ssV*ssV

diag = Sqr(diag) * 0.0394

diag = int(diag + 0.5) 'round to nearest inch

tmpScrSize = tmpScrSize & "(" & diag & " inch screen)"

Else

tmpnative = "Not reported"

End if

'you can tell if the location contains a serial number if it starts with &H00 00 00 ff

strSerFind=chr(&H00) & chr(&H00) & chr(&H00) & chr(&Hff)

'or a model description if it starts with &H00 00 00 fc

strMdlFind=chr(&H00) & chr(&H00) & chr(&H00) & chr(&Hfc)

intSerFoundAt=-1

intMdlFoundAt=-1

for findit = 0 to 3

if instr(location(findit),strSerFind)>0 then

intSerFoundAt=findit

end if

if instr(location(findit),strMdlFind)>0 then

intMdlFoundAt=findit

end if

'if a location containing a serial number block was found then store it

if intSerFoundAt<>-1 then

tmp=right(location(intSerFoundAt),14)

if instr(tmp,chr(&H0a))>0 then

tmpser=trim(left(tmp,instr(tmp,chr(&H0a))-1))

else

tmpser=trim(tmp)

end if

'although it is not part of the edid spec it seems as though the

'serial number will frequently be preceeded by &H00, this

'compensates for that

if left(tmpser,1)=chr(0) then tmpser=right(tmpser,len(tmpser)-1)

else

tmpser="(Not found)"

end if

'if a location containing a model number block was found then store it

if intMdlFoundAt<>-1 then

tmp=right(location(intMdlFoundAt),14)

if instr(tmp,chr(&H0a))>0 then

tmpmdl=trim(left(tmp,instr(tmp,chr(&H0a))-1))

else

tmpmdl=trim(tmp)

end if

'although it is not part of the edid spec it seems as though the

'serial number will frequently be preceeded by &H00, this

'compensates for that

if left(tmpmdl,1)=chr(0) then tmpmdl=right(tmpmdl,len(tmpmdl)-1)

else

tmpmdl="(Not found)"

end if

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

'next get the mfg date

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

'the week of manufacture is stored at EDID offset &H10

tmpmfgweek=asc(mid(strarrRawEDID(tmpctr),&H10+1,1))

'the year of manufacture is stored at EDID offset &H11

'and is the current year -1990

tmpmfgyear=(asc(mid(strarrRawEDID(tmpctr),&H11+1,1)))+1990

'store it in month/year format

tmpmdt=month(dateadd("ww",tmpmfgweek,datevalue("1/1/" & tmpmfgyear))) & "/" & tmpmfgyear

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

'next get the edid version

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

'the version is at EDID offset &H12

tmpEDIDMajorVer=asc(mid(strarrRawEDID(tmpctr),&H12+1,1))

'the revision level is at EDID offset &H13

tmpEDIDRev=asc(mid(strarrRawEDID(tmpctr),&H13+1,1))

'store it in month/year format

tmpver=chr(48+tmpEDIDMajorVer) & "." & chr(48+tmpEDIDRev)

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

'next get the mfg id

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

'the mfg id is 2 bytes starting at EDID offset &H08

'the id is three characters long. using 5 bits to represent

'each character. the bits are used so that 1=A 2=B etc..

'get the data

tmpEDIDMfg=mid(strarrRawEDID(tmpctr),&H08+1,2)

Char1=0 : Char2=0 : Char3=0

Byte1=asc(left(tmpEDIDMfg,1)) 'get the first half of the string

Byte2=asc(right(tmpEDIDMfg,1)) 'get the first half of the string

'now shift the bits

'shift the 64 bit to the 16 bit

if (Byte1 and 64) > 0 then Char1=Char1+16

'shift the 32 bit to the 8 bit

if (Byte1 and 32) > 0 then Char1=Char1+8

'etc....

if (Byte1 and 16) > 0 then Char1=Char1+4

if (Byte1 and 8) > 0 then Char1=Char1+2

if (Byte1 and 4) > 0 then Char1=Char1+1

'the 2nd character uses the 2 bit and the 1 bit of the 1st byte

if (Byte1 and 2) > 0 then Char2=Char2+16

if (Byte1 and 1) > 0 then Char2=Char2+8

'and the 128,64 and 32 bits of the 2nd byte

if (Byte2 and 128) > 0 then Char2=Char2+4

if (Byte2 and 64) > 0 then Char2=Char2+2

if (Byte2 and 32) > 0 then Char2=Char2+1

'the bits for the 3rd character don't need shifting

'we can use them as they are

Char3=Char3+(Byte2 and 16)

Char3=Char3+(Byte2 and 8)

Char3=Char3+(Byte2 and 4)

Char3=Char3+(Byte2 and 2)

Char3=Char3+(Byte2 and 1)

tmpmfg=chr(Char1+64) & chr(Char2+64) & chr(Char3+64)

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

'next get the device id

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

'the device id is 2bytes starting at EDID offset &H0a

'the bytes are in reverse order.

'this code is not text. it is just a 2 byte code assigned

'by the manufacturer. they should be unique to a model

tmpEDIDDev1=hex(asc(mid(strarrRawEDID(tmpctr),&H0a+1,1)))

tmpEDIDDev2=hex(asc(mid(strarrRawEDID(tmpctr),&H0b+1,1)))

if len(tmpEDIDDev1)=1 then tmpEDIDDev1="0" & tmpEDIDDev1

if len(tmpEDIDDev2)=1 then tmpEDIDDev2="0" & tmpEDIDDev2

tmpdev=tmpEDIDDev2 & tmpEDIDDev1

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

'finally store all the values into the array

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

arrMonitorInfo(tmpctr,0)=ltrim(trim(tmpmfg))

arrMonitorInfo(tmpctr,1)=ltrim(trim(tmpdev))

arrMonitorInfo(tmpctr,2)=tmpmdt

arrMonitorInfo(tmpctr,3)=ltrim(trim(tmpser))

arrMonitorInfo(tmpctr,4)=ltrim(trim(tmpmdl))

arrMonitorInfo(tmpctr,5)=ltrim(trim(tmpver))

arrMonitorInfo(tmpctr,6)=ltrim(trim(tmpnative))

arrMonitorInfo(tmpctr,7)=ltrim(trim(tmpScrSize))

End if

mon=0

for tmpctr=0 to intMonitorCount-1

if arrMonitorInfo(tmpctr,0) & arrMonitorInfo(tmpctr,1) & arrMonitorInfo(tmpctr,2) & arrMonitorInfo(tmpctr,3) & arrMonitorInfo(tmpctr,4) <> "" then

If LastSerial <> arrMonitorInfo(tmpctr,3) then

mon = mon + 1

x = x & " "

x = x & "Monitor " & mon & ""

x = x & " Model Name=" & arrMonitorInfo(tmpctr,4)

x = x & " Serial Number=" & arrMonitorInfo(tmpctr,3)

x = x & " Mfr ID=" & arrMonitorInfo(tmpctr,0)

x = x & " Device ID=" & arrMonitorInfo(tmpctr,1)

x = x & " Mfr Date=" & arrMonitorInfo(tmpctr,2)

if arrMonitorInfo(tmpctr,5) <> "" then

x = x & " EDID Version=" & arrMonitorInfo(tmpctr,5)

x = x & " Native Resolution=" & arrMonitorInfo(tmpctr,6) & " (obtained from monitor EDID information)"

x = x & " Screen size=" & arrMonitorInfo(tmpctr,7)

end if

LastSerial = arrMonitorInfo(tmpctr,3)

end if

'if mon > 1 then x = x & " "

x = x & " "

End if

InventoryMon = x

End Function

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

Function HexStringToAscii( HS )

'serial number is in format bababa - e.g. 2020202020202020202020205135354541423536 = 5QE5BA65

On error Resume next

'check for illegal chars

if instr(HS,"&") then Exit Function

if instr(HS,".") then Exit Function

X = len(HS)

if x < 2 then exit function

for i = 0 to x-1 step 2

a = mid(HS,i+1, 2) 'e.g. a = "20"

ai = Cint("&H00" & a) 'ensure we get 0 if conversion fails

if (ai > 20 and ai < 127) then

a = chr(ai)

all = all & a

end if

HexStringToAscii = ByteSwap(all)

End Function

'---

Function ByteSwap( BS)

'BS is string abcdef - convert to badcfe

for i = 0 to len(BS)-1 step 2

a = mid(BS,i+2,1) & mid(BS,i+1,1)

b = b & a

ByteSwap = trim(ltrim(b)) 'get rid of leading and ending spaces

End Function

'---

Function InventoryHDD( strComputer )

'Get HDD info including serial number

On Error Resume Next

'Set colItems = objSWbemServices.ExecQuery( "SELECT * FROM Win32_DiskDrive WHERE SCSITargetId >= 0", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly )

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

For Each objItem In colItems

x = x & " Hard Disk " & objItem.Index

x = x & " " & objItem.Model

x = x & " " & DoSize(objItem.Size)

f = ""

s = ""

fs = ""

f = objitem.FirmwareRevision & ""

s = HexStringToAscii(objitem.SerialNumber & "")

if f & s = "" then call ParseDiskPnP(objitem.PnPDeviceID,f,s)

if f <> "" then f = "Firmware=" & f

if s <> "" then s = "Sno=" & s

if f & s <> "" then fs = " [" & trim(rtrim(s & " " & f)) & "]"

x = x & " (" & objItem.InterfaceType & ")" & fs

p = objitem.Partitions

if p <> "" then x = x & " (" & p & " Partition"

if p > 1 then x = x & "s)" else x = x & ")"

cntHDD = cntHDD + 1

InventoryHDD = " Physical Hard Disk Drives" & x & " "

InventoryHdd = InventoryHdd & DiskLogical(strComputer) & " "

End Function

'--

Function DiskLogical(strComputer)

On Error Resume Next

Set colItems = objSWbemServices.ExecQuery ("Select * from Win32_LogicalDisk WHERE DriveType=3 OR DriveType=2")

For Each objItem in colItems

z = objItem.VolumeName & "" 'add empty string in case returns nul

if z = "" then z = objItem.Description

x = " " & objItem.Name & " " & z

x = x & " " & DoSize(objItem.Size) & ""

x = x & " Free Space=" & DoSize(objItem.FreeSpace)

if objItem.Compressed = True then x = x & " Compressed"

y = y & x

DiskLogical = " Logical Hard Disk Volumes" & y

End Function

'---

Sub ParseDiskPnP(IDString,fw,sn)

'IDE\DISKMAXTOR_6E040L0__________________________NAR61590\3145424337584559202020202020202020202020

'USBSTOR\DISK&VEN_SANDISK&PROD_U3_TITANIUM&REV_2.16\0000060410011041&0

a = instrRev(IDString,"_")

x = mid(IDString,a+1)

b = instrRev(x,"\")

y = mid(x,b+1)

fw = mid(x,1,b-1)

sn = HexStringToAscii(y)

End Sub

'---

Function DoSize(S)

if S < 1000 then DoSize = FormatNumber( S,1 ) & "B"

if S < 1000000 then DoSize = FormatNumber( S / 1000 ,1) & "KB"

if S < 1000000000 then DoSize = FormatNumber( S / 1000000,1 ) & "MB"

if S > 999999999 then DoSize = FormatNumber( S / 1000000000,1 ) & "GB"

If DoSize="" then DoSize = "(unknown)"

End Function

' ----

Function FormatiSpc(intSpace)

intSpace = intSpace/1024

intSpace= FormatNumber(intSpace,1)

FormatiSpc = intSpace

End function

'______________

Function InventoryCPU( strComputer )

On Error Resume Next

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

For Each objItem In colItems

CPUNumber = CPUNumber + 1

CPUModel = Strip(objItem.Name)

CPUSpeed = objItem.CurrentClockSpeed

CPUSocket = objItem.SocketDesignation

CPUCaption = objItem.Caption

CPUMax = objItem.MaxClockSpeed

'WMI MAxClock Speed is not always correct so read registry to see if larger value

strBaseKey = "HARDWARE\DESCRIPTION\System\CentralProcessor\0"

strValue=""

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

Set objReg = objSWbemServicesX.Get ("StdRegProv")

objReg.GetDWORDValue HKLM, strBaseKey, "~MHz", strValue

if strValue <> "" AND NOT (IsNull(strValue)) then CPUMAx=strValue

Set objSWbemServicesX = nothing

InventoryCPU = InventoryCPU & " CPU Core " & CPUNumber & " CPU value=" & CPUModel & " Current speed=" & CPUSpeed & "MHz Max Clock speed=" & CPUMax & "MHz CPU Socket=" & CPUSocket & " Type=" & CPUCaption

InventoryCPU = " " & InventoryCPU & " "

End Function

' _______________

Function Chassis( strComputer )

On Error Resume Next

Set colChassis = objSWbemServices.ExecQuery( "Select * from Win32_SystemEnclosure","WQL" , 16 )

For Each objChassis in colChassis

For Each objItem in objChassis.ChassisTypes

Select Case objItem

Case 1 strChassis = "Maybe Virtual Machine"

Case 2 strChassis = "Unknown"

Case 3 strChassis = "Desktop"

Case 4 strChassis = "Thin Desktop"

Case 5 strChassis = "Pizza Box"

Case 6 strChassis = "Mini Tower"

Case 7 strChassis = "Full Tower"

Case 8 strChassis = "Portable"

Case 9 strChassis = "Laptop"

Case 10 strChassis = "Notebook"

Case 11 strChassis = "Hand Held"

Case 12 strChassis = "Docking Station"

Case 13 strChassis = "All in One"

Case 14 strChassis = "Sub Notebook"

Case 15 strChassis = "Space-Saving"

Case 16 strChassis = "Lunch Box"

Case 17 strChassis = "Main System Chassis"

Case 18 strChassis = "Lunch Box"

Case 19 strChassis = "SubChassis"

Case 20 strChassis = "Bus Expansion Chassis"

Case 21 strChassis = "Peripheral Chassis"

Case 22 strChassis = "Storage Chassis"

Case 23 strChassis = "Rack Mount Unit"

Case 24 strChassis = "Sealed-Case PC"

End Select

Chassis = strChassis

End Function

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

Function UnTag( strString )

' This function replaces special characters by their "ampersand code".

' The lines strPre = "" etc. are there to make sure that strPre has

' a value even if the next line fails.

On Error Resume Next

If InStr( strString, "&" ) > 0 Then

posAmp = -1

Do Until posAmp = 0

posAmp = InStr( posAmp + 2, strString, "&" )

strPre = ""

strPre = Mid( strString, 1, posAmp - 1 )

strPost = ""

strPost = Mid( strString, posAmp + 1 )

If posAmp > 0 Then strString = strPre & "&" & strPost

Loop

End If

If InStr( strString, "<" ) > 0 Then

posLt = -1

Do Until posLt = 0

posLt = InStr( posLt + 2, strString, "<" )

strPre = ""

strPre = Mid( strString, 1, posLt - 1 )

strPost = ""

strPost = Mid( strString, posLt + 1 )

If posLt > 0 Then strString = strPre & "<" & strPost

Loop

End If

If InStr( strString, ">" ) > 0 Then

posGt = -1

Do Until posGt = 0

posGt = InStr( posGt + 2, strString, ">" )

strPre = ""

strPre = Mid( strString, 1, posGt - 1 )

strPost = ""

strPost = Mid( strString, posGt + 1 )

If posGt > 0 Then strString = strPre & ">" & strPost

Loop

End If

UnTag = strString

End Function

Function WMIDateStringToDate(dtmDate)

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

Mid(dtmDate, 7, 2) & "/" & Left(dtmDate, 4) _

& " " & Mid (dtmDate, 9, 2) & ":" & Mid(dtmDate, 11, 2) & ":" & Mid(dtmDate,13, 2))

End Function

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

' GETBOARDINFO

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

Function GetBoardInfo (strComputer)

Dim colGUID

Dim objComputer

Dim colSMBIOS

Dim objWMIService

'get Mainboard DMI/SMBIOS information - these parameters are all stored in the mainboard BIOS DMI data tables

On Error Resume Next

x=""

Set colSMBIOS = objSWbemServices.ExecQuery ("SELECT * FROM Win32_BaseBoard","WQL", 48)

For Each objSMBIOS in colSMBIOS

BS= trim(objSMBIOS.SerialNumber)

MP = trim(objSMBIOS.Product)

MV = trim(objSMBIOS.Version)

MMod=trim(objSMBIOS.Model)

MManuf=trim(objSMBIOS.Manufacturer)

x = x & " Mainboard"

if MP <> "" then x =x & " Product=" & MP

if MV <> "" then x =x & " Version=" & MV

if BS <> "" then x =x & " Serial Number=" & BS

if MMod <> "" then x =x & " Model=" & MMod

if MManuf <> "" then x =x & " Manufacturer=" & MManuf

Set colSMBIOS = objSWbemServices.ExecQuery ("SELECT * FROM Win32_BIOS","WQL",48)

For Each objSMBIOS in colSMBIOS

BN = trim(objSMBIOS.Name)

BV = trim(objSMBIOS.Version)

BD = trim(objSMBIOS.Description)

BS = trim(objSMBIOS.SerialNumber)

SBV=trim(objSMBIOS.SMBIOSBIOSVersion)

BMan=trim(objSMBIOS.Manufacturer)

BID=trim(objSMBIOS.IdentificationCode)

BDate=WMIDateStringToDate(objSMBIOS.ReleaseDate)

BinstDate=WMIDateStringToDate(objSMBIOS.InstallDate)

x = x & " BIOS"

'if BN <> "" then x = x & " Name=" & BN 'BN same as BD

if BV <> "" then x = x & " Version=" & BV

if BD <> "" then x = x & " Description=" & BD

'if BS <> "" then x = x & " Serial Number=" & BS 'same as System Serial number

if SBV <> "" then x = x & " SMBIOS Version=" & SBV

if BMan <> "" then x = x & " Manufacturer=" & BMan

if BID <> "" then x = x & " ID=" & BID

if BDate <> "" then x = x & " Release Date=" & BDate

if BinstDate <> "" then x = x & " Install Date=" & BinstDate

Set colSMBIOS = objSWbemServices.ExecQuery ("SELECT * FROM Win32_SystemEnclosure","WQL",48)

For Each objSMBIOS in colSMBIOS

CS=trim(objSMBIOS.SerialNumber)

CA=trim(objSMBIOS.SMBIOSAssetTag)

CV=trim(objSMBIOS.Version)

CM=trim(objSMBIOS.Manufacturer)

CP=trim(objSMBIOS.PartNumber)

CMod=trim(objSMBIOS.Model)

CN=trim(objSMBIOS.Name)

Chas = Chassis(strComputer)

Chas = ltrim(Chas)

x = x & " Chassis"

if CS <> "" then x = x & " Serial Number=" & CS

if CA <> "" then x = x & " Asset Tag=" & CA

if Chas <> "" then x = x & " Type=" & Chas

if CV <> "" then x = x & " Version=" & CV

if CM <> "" then x = x & " Manufacturer=" & CM

if CP <> "" then x = x & " Part Number=" & CP

if CMod <> "" then x = x & " Model=" & CMod

'if CN <> "" then x = x & " Name=" & CN ' System Enclosure

Set colGUID = objSWbemServices.ExecQuery("Select * from Win32_ComputerSystemProduct","WQL",48)

For Each objComputer in colGUID

SS = trim(objComputer.IdentifyingNumber)

SP = trim(objComputer.Name)

GUID = trim(objComputer.UUID)

SM = trim(objComputer.Vendor)

SV = trim(objComputer.Version)

SCap=trim(objComputer.Caption)

Sdesc=trim(objComputer.Description)

SSKU=trim(objComputer.SKUNumber)

IF GUID <> "" then

p1=mid(GUID,1,2)

p2=mid(GUID,3,2)

p3=mid(GUID,5,2)

p4=mid(GUID,7,2)

p5=mid(GUID,10,2)

p6=mid(GUID,12,2)

p7=mid(GUID,15,2)

p8=mid(GUID,17,2)

p9=mid(GUID,20,4)

p10=mid(GUID,25)

GUID= GUID & " GUID (Wire format for PXE)=" & p4 & p3 & p2 & p1 & p6 & p5 & p8 & p7 & p9 & p10

End if

x = x & " System"

if SS<>"" then x = x & " Serial Number=" & SS

if SP<>"" then x = x & " Product=" & SP

if SM<>"" then x = x & " Manufacturer=" & SM

if SV<>"" then x = x & " Version=" & SV

'if SCap<>"" then x = x & " Caption=" & SCap 'Computer System Product

'if Sdesc<>"" then x = x & " Description=" & Sdesc 'Computer System Product

if SSKU<>"" then x = x & " SKU Number=" & SSKU

if GUID<>"" then x = x & " GUID (Windows format)=" & GUID

set colGUID = Nothing

set objWMIService = Nothing

GetBoardInfo = x

End Function

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

' GETINFO - MAIN ROUTINE TO COLLECT ALL INFO

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

Function GetInfo()

Dim colGUID

Dim objComputer

Dim colSMBIOS

Dim objWMIService

On ERROR RESUME NEXT

'Establish a connection to the computer which can be on a network

Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")

Set objSWbemServices = objSWbemLocator.ConnectServer(strComputer, _

"root\cimv2", _

strUser, _

strPassword, _

"MS_409", _

"ntlmdomain:" + strDomain)

'Get all info into x

x = x & GetOSVer()

x = x & GetBoardInfo(strComputer)

x = x & InventoryCPU(strComputer)

if 1=1 then

x = x & InventoryHDD(strComputer)

x = x & InventoryCDR(strComputer)

x = x & InventoryTapeDrive(strComputer)

x = x & InventoryMEM(strComputer)

x = x & InventoryNIC(strComputer)

x = x & InventorySound(strComputer)

x = x & InventoryVideo(strComputer)

x = x & InventoryMon(strComputer)

x = x & GetProblemDev(strComputer)

x = x & ListHSP(strComputer)

End If

If ExtraList = true then

if 1=1 then

x = x & ListServerSW(strComputer)

x = x & GetPrinters(strComputer)

x = x & GetDrivers(strComputer)

x = x & ListPCI(strComputer)

x = x & ListSW(strComputer)

x = x & GetStartup(strComputer)

x = x & EventErrors(strComputer)

End If

CompName=GetComputerName()

'form header text in hdr

hdr="<h1>System Information for "

hdr=hdr & CompName & "</h1></a>"

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

hdr=hdr & " <h3>Your system serial number is " & SearchString & "</h3>"

hdr=hdr & "Date: " & Now & " "

'return text for page as a string

GetInfo = hdr & x & " "

'set MyGetInfo if local computer or YourGetInfo if remote computer

if strComputer = "." then MyGetInfo = GetInfo else YourGetInfo=GetInfo

if strComputer = "." then MyComputerName=CompName else YourComputerName=CompName

if strComputer = "." then MYSN=MyWO else YourSN=MyWO

End function

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

' GETWO

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

Function GetWO()

Dim colGUID

Dim objComputer

Dim colSMBIOS

Dim objWMIService

On ERROR RESUME NEXT

'Routine to get the system serial number from the DMI values

'It assumes that the serial number is in the format TOnnnnnnnn or WOnnnnnnnn

if strComputer="" then strComputer="."

Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")

Set objSWbemServices = objSWbemLocator.ConnectServer(strComputer, _

"root\cimv2", _

strUser, _

strPassword, _

"MS_409", _

"ntlmdomain:" + strDomain)

if Err then

GetWo=Err

Else

Set colSMBIOS = objSWbemServices.ExecQuery ("SELECT * FROM Win32_SystemEnclosure","WQL",48)

For Each objSMBIOS in colSMBIOS

CS= trim(objSMBIOS.SerialNumber)

CA= trim(objSMBIOS.SMBIOSAssetTag)

Set colGUID = objSWbemServices.ExecQuery("Select * from Win32_ComputerSystemProduct","WQL",48)

For Each objComputer in colGUID

SS = trim(objComputer.IdentifyingNumber)

set colGUID = Nothing

set objWMIService = Nothing

'CS="WO43210102"

if len(CS)<>10 then CS=""

if len(CA)<>10 then CA=""

if len(SS)<>10 then SS=""

if Instr(CS," ")<>0 then CS=""

if Instr(CA," ")<>0 then CA=""

if Instr(SS," ")<>0 then SS=""

'Serial number should begin with WO or TO and have no spaces in the middle

if (InStr(CS,"WO") > 0) then GetWO=CS

if (InStr(CS,"TO") > 0) then GetWO=CS

if (InStr(SS,"WO") > 0) then GetWO=SS

if (InStr(SS,"TO") > 0) then GetWO=SS

if (InStr(CA,"WO") > 0) then GetWO=CA

if (InStr(CA,"TO") > 0) then GetWO=CA

if GetWO = "" then

GetWO="unknown"

SearchString = "http://www.xx.com"

Else

SearchString = "http://www.xx.com/support/mycomputer.asp?serialno=" & GetWO

End if

MyWO = trim(GetWO)

SearchString = "<a style=" & chr(34) & "color: red; text-decoration: underline;" & chr(34) & " href=" & chr(34) & SearchString & chr(34) & ">" & GetWO & "</a>"

GetWo="OK"

End if

End function

'-----

Function Clear()

Checkbox1.checked=False

ExtraList = Checkbox1.checked

End Function

'---

Sub CheckBoxList ()

'respond to checkbox click

ExtraList = Checkbox1.checked

If ExtraList = True then

y = msgbox ("Include list of installed Software, Drivers, Event Log errors, etc. - this may take several minutes",1)

if y = vbOK then

MyArea.InnerHtml = " Query in progress - please wait..."

strComputer = "."

x = GetInfo()

MyArea.InnerHtml=x

Else

ExtraList = False

Checkbox1.checked = false

end if

End Sub

'---

Sub CheckBoxList2 ()

'respond to checkbox click

ExtraList = Checkbox2.checked

End Sub

-->

</SCRIPT>

</head>

<HTA:Application

Caption = Yes

Border = Thick

ShowInTaskBar = Yes

MaximizeButton = Yes

MinimizeButton = Yes

icon="SysInfo.ico"

SINGLEINSTANCE = "yes"

APPLICATIONNAME= "SysInfo"

<input type = "checkbox" name="Checkbox1" value="False" onClick="CheckBoxList"> Also list Printers, Software, Hotfixes, PCI IDs, EventLog Errors and Drivers (may take several minutes)

GetWO()

MyArea.InnerHtml = GetInfo()

Checkbox1.checked = True

call CheckBoxList()

</script>

<hr>

<h2>Collect System Information from Remote Computer</h2>

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.

<input type = "checkbox" name="Checkbox2" value="False" onClick="CheckBoxList2"> Also list Printers, Software, Hotfixes, PCI IDs, EventLog Errors and Drivers (may take several minutes)

<td>User Password <input type="password" name="APassword" size="15" title="Password for the User account"></td>

<td>Domain <input type="text" name="ADomain" size="15" title="Domain name or WORKGROUP"></td>

<td>Computer Name <input type="text" name="AComputer" size="15" title="Computer Name (use List Computers to see a list of these)"></td>

</table>

<hr>

<hr>

</body>

Version 1 used a background gradient fill (see here) - but it was removed as it seems to fail to work on modern browsers!