VB WMI 对象的示例代码

http://www.diybl.com/course/3_program/vb/2008331/107856.html

Attribute VB_Name = "ModuleWMI"
Option Explicit
Private Declare Function ExpandEnvironmentStrings()Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As LongAs Long
Private Declare Function lstrlen()Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongAs Long
Private Const MAX_PATH = 260
''***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiBiosInfo()Function wmiBiosInfo() As String
   
Dim BiosSet As SWbemObjectSet
   
Dim bios As SWbemObject
   
Dim Cnt As Long
   
Dim Msg As String
Set BiosSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_BIOS")
On Local Error Resume Next
For Each bios In BiosSet
wmiBiosInfo 
= wmiBiosInfo & "PrimaryBIOS" & vbTab & bios.PrimaryBIOS & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "Status" & vbTab & bios.Status & vbCrLf
    
For Cnt = LBound(bios.BIOSVersion) To UBound(bios.BIOSVersion)
        wmiBiosInfo 
= wmiBiosInfo & "BIOSVersion strings" & vbTab & bios.BIOSVersion(Cnt) & vbCrLf
    
Next Cnt
wmiBiosInfo 
= wmiBiosInfo & "Caption" & vbTab & bios.Caption & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "Description" & vbTab & bios.Description & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "Name" & vbTab & bios.Name & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "Manufacturer" & vbTab & bios.Manufacturer & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "ReleaseDate" & vbTab & bios.ReleaseDate & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "SerialNumber" & vbTab & bios.SerialNumber & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "SMBIOSBIOSVersion" & vbTab & bios.SMBIOSBIOSVersion & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "SMBIOSMajorVersion" & vbTab & bios.SMBIOSMajorVersion & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "SMBIOSMinorVersion" & vbTab & bios.SMBIOSMinorVersion & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "SMBIOSPresent" & vbTab & bios.SMBIOSPresent & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "SoftwareElementID" & vbTab & bios.SoftwareElementID & vbCrLf
    
Select Case bios.SoftwareElementState
         
Case 0: Msg = "deployable"
         
Case 1: Msg = "installable"
         
Case 2: Msg = "executable"
         
Case 3: Msg = "running"
      
End Select
wmiBiosInfo 
= wmiBiosInfo & "SoftwareElementState" & vbTab & Msg & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "Version" & vbTab & bios.Version & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "InstallableLanguages" & vbTab & bios.InstallableLanguages & vbCrLf
wmiBiosInfo 
= wmiBiosInfo & "CurrentLanguage" & vbTab & bios.CurrentLanguage & vbCrLf
    
For Cnt = LBound(bios.ListOfLanguages) To UBound(bios.ListOfLanguages)
        wmiBiosInfo 
= wmiBiosInfo & "ListOfLanguages" & vbTab & bios.ListOfLanguages(Cnt) & vbCrLf
    
Next Cnt
    
For Cnt = LBound(bios.BiosCharacteristics) To UBound(bios.BiosCharacteristics)
        
Select Case bios.BiosCharacteristics(Cnt)
            
Case 0: Msg = "reserved"
            
Case 1: Msg = "reserved"
            
Case 2: Msg = "unknown"
            
Case 3: Msg = "BIOS characteristics not supported"
            
Case 4: Msg = "ISA supported"
            
Case 5: Msg = "MCA supported"
            
Case 6: Msg = "EISA supported"
            
Case 7: Msg = "PCI supported"
            
Case 8: Msg = "PC Card (PCMCIA) supported"
            
Case 9: Msg = "Plug and Play supported"
            
Case 10: Msg = "APM is supported"
            
Case 11: Msg = "BIOS upgradable (Flash)"
            
Case 12: Msg = "BIOS shadowing allowed"
            
Case 13: Msg = "VL-VESA supported"
            
Case 14: Msg = "ESCD support available"
            
Case 15: Msg = "Boot from CD supported"
            
Case 16: Msg = "Selectable boot supported"
            
Case 17: Msg = "BIOS ROM socketed"
            
Case 18: Msg = "Boot from PC card (PCMCIA) supported"
            
Case 19: Msg = "EDD (Enhanced Disk Drive) specification supported"
            
Case 20: Msg = "Int 13h, Japanese Floppy for NEC 9800 1.2mb (3.5, 1k b/s, 360 RPM) supported"
            
Case 21: Msg = "Int 13h, Japanese Floppy for Toshiba 1.2mb (3.5, 360 RPM) supported"
            
Case 22: Msg = "Int 13h, 5.25 / 360 KB floppy services supported"
            
Case 23: Msg = "Int 13h, 5.25 /1.2MB floppy services supported"
            
Case 24: Msg = "Int 13h 3.5 / 720 KB floppy services supported"
            
Case 25: Msg = "Int 13h, 3.5 / 2.88 MB floppy services supported"
            
Case 26: Msg = "Int 5h, print screen service supported"
            
Case 27: Msg = "Int 9h, 8042 keyboard services supported"
            
Case 28: Msg = "Int 14h, serial services supported"
            
Case 29: Msg = "Int 17h, printer services supported"
            
Case 30: Msg = "Int 10h, CGA/Mono video aervices supported"
            
Case 31: Msg = "NEC PC-98"
            
Case 32: Msg = "ACPI supported"
            
Case 33: Msg = "USB Legacy supported"
            
Case 34: Msg = "AGP supported"
            
Case 35: Msg = "I2O boot supported"
            
Case 36: Msg = "LS-120 boot supported"
            
Case 37: Msg = "ATAPI ZIP drive boot supported"
            
Case 38: Msg = "1394 boot supported"
            
Case 39: Msg = "Smart battery supported"
         
End Select
         wmiBiosInfo 
= wmiBiosInfo & "BIOS Characteristics" & vbTab & Msg & vbCrLf
      
Next Cnt ''For cnt
wmiBiosInfo = wmiBiosInfo & vbCrLf
   
Next bios ''For Each bios
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiDesktopInfo()Function wmiDesktopInfo() As String
   
Dim DesktopSet As SWbemObjectSet
   
Dim desktop As SWbemObject
   
Dim Thiscol As Long
wmiDesktopInfo 
= wmiDesktopInfo & "WMI Property" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "BorderWidth" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "CoolSwitch" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "CursorBlinkRate" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "DragFullWindows" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "GridGranularity" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "IconSpacing" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "IconTitleFaceName" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "IconTitleSize" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "IconTitleWrap" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "Pattern" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "ScrSaveActive" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "ScrSaveExecutable" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "ScrSaveSecure" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "ScrSaveTimeout" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "Wallpaper" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "WallpaperStretched" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & "WallpaperTiled" & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & vbCrLf
   
Set DesktopSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_Desktop")
    
    
For Each desktop In DesktopSet
wmiDesktopInfo 
= wmiDesktopInfo & desktop.Name & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.BorderWidth & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.CoolSwitch & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.CursorBlinkRate & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.DragFullWindows & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.GridGranularity & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.IconSpacing & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.IconTitleFaceName & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.IconTitleSize & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.IconTitleWrap & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.Pattern & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.ScreenSaverActive & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.ScreenSaverExecutable & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.ScreenSaverSecure & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.ScreenSaverTimeout & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.Wallpaper & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.WallpaperStretched & vbTab
wmiDesktopInfo 
= wmiDesktopInfo & desktop.WallpaperTiled
wmiDesktopInfo 
= wmiDesktopInfo & vbCrLf
    
Next desktop
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiDiskDriveInfo()Function wmiDiskDriveInfo() As String
   
Dim DiskDriveSet As SWbemObjectSet
   
Dim dd As SWbemObject
   
Dim Thiscol As Long
   
Dim capcount As Long
   
Dim Msg As String
   
Dim sflag As String  ''used in err trap
On Local Error Resume Next
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "WMI Property" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: Description" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: Index" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: DeviceID" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: Caption" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: Manufacturer" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: Model" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: InterfaceType" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: MediaLoaded" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "ID: MediaType" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: Status" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: Size" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: Partitions" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: BytesPerSector" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: SectorsPerTrack" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: TotalCylinders" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: TotalHeads" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: TotalTracks" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Phyical: TracksPerCylinder"
wmiDiskDriveInfo 
= wmiDiskDriveInfo & "Disk Capabilities:" & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & vbCrLf
Set DiskDriveSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_DiskDrive")
   
For Each dd In DiskDriveSet
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Description & " " & dd.Index & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Description & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Index & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.DeviceID & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Caption & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Manufacturer & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Model & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.InterfaceType & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.MediaLoaded & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.MediaType & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Status & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & FormatNumber(dd.Size, 0& vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.Partitions & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & FormatNumber(dd.BytesPerSector, 0& vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & FormatNumber(dd.SectorsPerTrack, 0& vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & FormatNumber(dd.TotalCylinders, 0& vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.TotalHeads & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.TotalTracks & vbTab
wmiDiskDriveInfo 
= wmiDiskDriveInfo & dd.TracksPerCylinder & vbTab
For capcount = LBound(dd.capabilities) To UBound(dd.capabilities)
    
Select Case dd.capabilities(capcount)
               
Case 0: Msg = "Unknown "
               
Case 1: Msg = "Other "
               
Case 2: Msg = "Sequential Access "
               
Case 3: Msg = "Random Access "
               
Case 4: Msg = "Supports Writing "
               
Case 5: Msg = "Encryption "
               
Case 6: Msg = "Compression "
               
Case 7: Msg = "Supports Removable Media "
               
Case 8: Msg = "Manual Cleaning "
               
Case 9: Msg = "Automatic Cleaning "
               
Case 10: Msg = "SMART Notification "
               
Case 11: Msg = "Supports Dual Sided Media "
               
Case 12: Msg = "Ejection Prior to Drive Dismount Not Required"
    
End Select
wmiDiskDriveInfo 
= wmiDiskDriveInfo & Msg & vbTab
Next capcount
wmiDiskDriveInfo 
= wmiDiskDriveInfo & vbCrLf
Next dd
''--end block--''
End Function
''***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiVideoControllerInfo()Function wmiVideoControllerInfo() As String
   
Dim wmiObjSet As SWbemObjectSet
   
Dim obj As SWbemObject
   
Dim Msg As String
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Processor" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "BPS" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Hres" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Vres" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Freq" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Colours" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "rf min" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "rf max" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Vmode" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "Mem" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & "AdapterDACType" & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & vbCrLf
   
Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_VideoController")
   
On Local Error Resume Next
   
For Each obj In wmiObjSet
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.VideoProcessor & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.CurrentBitsPerPixel & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.CurrentHorizontalResolution & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.CurrentVerticalResolution & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.CurrentRefreshRate & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.CurrentNumberOfColors & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.MinRefreshRate & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.MaxRefreshRate & vbTab
    
Select Case obj.CurrentScanMode
         
Case 1: Msg = "other"
         
Case 2: Msg = "unknwn"
         
Case 3: Msg = "intrlcd"
         
Case 4: Msg = "nintrlcd"
    
End Select
wmiVideoControllerInfo 
= wmiVideoControllerInfo & Msg & vbTab
      
Select Case obj.VideoMemoryType
         
Case 1: Msg = "other"
         
Case 2: Msg = "unknown"
         
Case 3: Msg = "VRAM"
         
Case 4: Msg = "DRAM"
         
Case 5: Msg = "SRAM"
         
Case 6: Msg = "WRAM"
         
Case 7: Msg = "EDO RAM"
         
Case 8: Msg = "Burst Synchronous DRAM"
         
Case 9: Msg = "Pipelined Burst SRAM"
         
Case 10: Msg = "CDRAM"
         
Case 11: Msg = "3DRAM"
         
Case 12: Msg = "SDRAM"
         
Case 13: Msg = "SGRAM"
      
End Select
wmiVideoControllerInfo 
= wmiVideoControllerInfo & Msg & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & obj.AdapterDACType & vbTab
wmiVideoControllerInfo 
= wmiVideoControllerInfo & vbCrLf
Next obj
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiDisplayConfiguration()Function wmiDisplayConfiguration() As String
   
Dim dcSet As SWbemObjectSet
   
Dim dc As SWbemObject
   
Dim Msg As String
wmiDisplayConfiguration 
= wmiDisplayConfiguration & "Caption" & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & "Driver ver" & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & "LogPixels" & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & "PelsH" & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & "PelsV" & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & "Spec ver" & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & vbCrLf
   
Set dcSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_DisplayConfiguration")
On Local Error Resume Next
   
For Each dc In dcSet
wmiDisplayConfiguration 
= wmiDisplayConfiguration & dc.Caption & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & dc.DriverVersion & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & dc.LogPixels & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & dc.PelsHeight & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & dc.PelsWidth & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & dc.SpecificationVersion & vbTab
wmiDisplayConfiguration 
= wmiDisplayConfiguration & vbCrLf
   
Next dc
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Private Function ChangeEnvironmentToPath()Function ChangeEnvironmentToPath(ByVal sEnvironPath As StringAs String
Dim buff As String
   buff 
= Space$(MAX_PATH)
   
Call ExpandEnvironmentStrings(sEnvironPath, buff, Len(buff))
   ChangeEnvironmentToPath 
= Left$(buff, lstrlen(StrPtr(buff)))
End Function
Public Function wmiEnvironmentInfo()Function wmiEnvironmentInfo() As String
wmiEnvironmentInfo 
= wmiEnvironmentInfo & "Variable Name" & vbTab
wmiEnvironmentInfo 
= wmiEnvironmentInfo & "Environment Value" & vbTab
wmiEnvironmentInfo 
= wmiEnvironmentInfo & "Expanded String" & vbTab
wmiEnvironmentInfo 
= wmiEnvironmentInfo & vbCrLf
   
Dim EnvSet As SWbemObjectSet
   
Dim env As SWbemObject
   
Set EnvSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_Environment")
On Local Error Resume Next
  
For Each env In EnvSet
wmiEnvironmentInfo 
= wmiEnvironmentInfo & env.Name & vbTab
wmiEnvironmentInfo 
= wmiEnvironmentInfo & env.VariableValue & vbTab
wmiEnvironmentInfo 
= wmiEnvironmentInfo & ChangeEnvironmentToPath(env.VariableValue) & vbTab
wmiEnvironmentInfo 
= wmiEnvironmentInfo & vbCrLf
   
Next env
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiKeyboardInfo()Function wmiKeyboardInfo() As String
   
Dim wmiObjSet  As SWbemObjectSet
   
Dim obj        As SWbemObject
   
Dim Thiscol    As Long
   
On Local Error Resume Next
wmiKeyboardInfo 
= wmiKeyboardInfo & "WMI Property" & vbTab
wmiKeyboardInfo 
= wmiKeyboardInfo & "Value" & vbTab
wmiKeyboardInfo 
= wmiKeyboardInfo & vbCrLf
Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_Keyboard")
   
For Each obj In wmiObjSet
wmiKeyboardInfo 
= wmiKeyboardInfo & "Description" & vbTab & obj.Description & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "Name" & vbTab & obj.Name & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "Caption" & vbTab & obj.Caption & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "Status" & vbTab & obj.Status & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "Availability" & vbTab & IIf(obj.Availability, obj.Availability, "null"& vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "Layout" & vbTab & obj.Layout & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "NumberOfFunctionKeys" & vbTab & obj.NumberOfFunctionKeys & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "DeviceID" & vbTab & obj.DeviceID & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & "PNPDeviceID" & vbTab & obj.PNPDeviceID & vbCrLf
wmiKeyboardInfo 
= wmiKeyboardInfo & vbCrLf
Next obj
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiBaseBoardInfo()Function wmiBaseBoardInfo() As String
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Product" & vbTab
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Manufacturer" & vbTab
   
Dim BaseBoardSet As SWbemObjectSet
   
Dim bb As SWbemObject
Set BaseBoardSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_BaseBoard")
On Local Error Resume Next
For Each bb In BaseBoardSet
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Manufacturer" & vbTab & bb.Manufacturer & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Caption" & vbTab & bb.Caption & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "ConfigOptions" & vbTab & bb.ConfigOptions & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "CreationClassName" & vbTab & bb.CreationClassName & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Depth" & vbTab & bb.Depth & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Description" & vbTab & bb.Description & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Height" & vbTab & bb.Height & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "HostingBoard" & vbTab & bb.HostingBoard & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "HotSwappable" & vbTab & bb.HotSwappable & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "InstallDate" & vbTab & bb.InstallDate & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Model" & vbTab & bb.Model & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Name" & vbTab & bb.Name & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "OtherIdentifyingInfo" & vbTab & bb.OtherIdentifyingInfo & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "PartNumber" & vbTab & bb.PartNumber & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "PoweredOn" & vbTab & bb.PoweredOn & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Product" & vbTab & bb.Product & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Removable" & vbTab & bb.Removable & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Replaceable" & vbTab & bb.Replaceable & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "RequirementsDescription" & vbTab & bb.RequirementsDescription & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "RequiresDaughterBoard" & vbTab & bb.RequiresDaughterBoard & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "SerialNumber" & vbTab & bb.SerialNumber & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "SKU" & vbTab & bb.SKU & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "SlotLayout" & vbTab & bb.SlotLayout & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "SpecialRequirements" & vbTab & bb.SpecialRequirements & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Status" & vbTab & bb.Status & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Tag" & vbTab & bb.Tag & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Version" & vbTab & bb.Version & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Weight" & vbTab & bb.Weight & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & "Width" & vbTab & bb.Width & vbCrLf
wmiBaseBoardInfo 
= wmiBaseBoardInfo & vbCrLf
   
Next bb
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiDesktopMonitorInfo()Function wmiDesktopMonitorInfo() As String
   
Dim dtmSet As SWbemObjectSet
   
Dim dtm As SWbemObject
   
Dim Msg As String
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & "Device ID" & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & "Caption" & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & "Manu" & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & "Stat" & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & "Availability" & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & vbCrLf
   
Set dtmSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_DesktopMonitor")
On Local Error Resume Next
For Each dtm In dtmSet
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & dtm.DeviceID & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & dtm.Caption & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & dtm.MonitorManufacturer & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & dtm.Status & vbTab
    
Select Case dtm.Availability
         
Case 1: Msg = "other"
         
Case 2: Msg = "unknown "
         
Case 3: Msg = "running/full power"
         
Case 4: Msg = "warning "
         
Case 5: Msg = "in test "
         
Case 6: Msg = "not applicable "
         
Case 7: Msg = "power off "
         
Case 8: Msg = "off line "
         
Case 9: Msg = "off duty "
         
Case 10: Msg = "degraded "
         
Case 11: Msg = "not installed "
         
Case 12: Msg = "install error "
         
Case 13: Msg = "power save - unknown "
         
Case 14: Msg = "power save - low power mode "
         
Case 15: Msg = "power save - standby "
         
Case 16: Msg = "power cycle "
         
Case 17: Msg = "power save - warning "
         
Case 18: Msg = "paused "
         
Case 19: Msg = "not ready "
         
Case 20: Msg = "not configured "
         
Case 21: Msg = "quiesced"
    
End Select
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & Msg & vbTab
wmiDesktopMonitorInfo 
= wmiDesktopMonitorInfo & vbCrLf
Next dtm
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Private Function SplitDateTimeBias()Function SplitDateTimeBias(ByVal leasedate As String, leasedatepart As String, leasetimepart As StringAs Long
Dim pos As Long, bias As Long
   pos 
= InStr(leasedate, ".")
If pos > 0 Then
      bias 
= StripTimeZoneBias(leasedate)
      leasedatepart 
= Left$(leasedate, 8)
      leasetimepart 
= Mid$(leasedate, 9, pos - Len(leasedatepart) - 1)
      leasedatepart 
= InsertInString(leasedatepart, "-"5"")
      leasedatepart 
= InsertInString(leasedatepart, "-"8"")
      leasetimepart 
= InsertInString(leasetimepart, ":"3"")
      leasetimepart 
= InsertInString(leasetimepart, ":"6"")
      SplitDateTimeBias 
= bias
End If
End Function
Private Function InsertInString()Function InsertInString(ByVal sOriginal As String, sReplace As String, nField As Long, sDelimeter As StringAs String
Dim nCount As Long, nStart As Long, nLast As Long
Do While InStr(nStart + 1, sOriginal, sDelimeter) > 0
      nStart 
= InStr(nStart + 1, sOriginal, sDelimeter)
      nCount 
= nCount + 1
      
If nCount >= nField Then
         
Exit Do
      
End If
      nLast 
= nStart
Loop
    
Select Case nCount
      
Case 1
         InsertInString 
= sReplace & Mid$(sOriginal, nStart)
      
Case Is >= nField
         InsertInString 
= Mid$(sOriginal, 1, nLast) & sReplace & Mid$(sOriginal, nStart)
      
Case Else
         InsertInString 
= sOriginal & String$((nField - 1- nCount, sDelimeter) & sReplace
    
End Select
End Function
Private Function StripTimeZoneBias()Function StripTimeZoneBias(leasedate As StringAs Long
Dim pos As Long, tmp As String
pos 
= InStr(leasedate, "-")
   
If pos = 0 Then
      pos 
= InStr(leasedate, "+")
      
If pos = 0 Then
         StripTimeZoneBias 
= 0
      
End If
   
Else
      tmp 
= Mid$(leasedate, pos, Len(leasedate))
      leasedate 
= Mid$(leasedate, 1, pos - 1)
      StripTimeZoneBias 
= CLng(tmp)
   
End If
End Function
Public Function wmiOperatingSystemInfo()Function wmiOperatingSystemInfo() As String
   
Dim wmiObjSet As SWbemObjectSet
   
Dim obj As SWbemObject
   
Dim Msg As String
   
Dim dtb As String
   
Dim d As String
   
Dim t As String
   
Dim bias As Long
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "WMI Property" & vbTab
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "Value(s)" & vbTab
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & vbCrLf
On Local Error Resume Next
Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_OperatingSystem")
For Each obj In wmiObjSet
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "Operating System" & vbTab & obj.Caption & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "Version" & vbTab & obj.Version & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "BuildNumber" & vbTab & obj.BuildNumber & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "BuildType" & vbTab & obj.BuildType & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "Latest Service Pack" & vbTab & obj.CSDVersion & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "EncryptionLevel" & vbTab & obj.EncryptionLevel & "-bit" & vbCrLf
      
Select Case obj.OSType
         
Case 15: Msg = "WIN3x"
         
Case 16: Msg = "WIN95"
         
Case 17: Msg = "WIN98"
         
Case 18: Msg = "WINNT"
         
Case 19: Msg = "WINCE"
         
Case Else: Msg = "non-windows - see MSDN for complete list"
      
End Select
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "OSType" & vbTab & Msg & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "BootDevice" & vbTab & obj.BootDevice & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "RegisteredUser" & vbTab & obj.RegisteredUser & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "SerialNumber" & vbTab & obj.SerialNumber & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "Status" & vbTab & obj.Status & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "SystemDevice" & vbTab & obj.SystemDevice & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "SystemDrive" & vbTab & obj.SystemDrive & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "WindowsDirectory" & vbTab & obj.WindowsDirectory & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "SystemDirectory" & vbTab & obj.SystemDirectory & vbCrLf
    dtb 
= obj.LocalDateTime
    bias 
= SplitDateTimeBias(dtb, d, t)
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "LocalDateTime" & vbTab & Format$(d, "dddd mmm d, yyyy"& " " & Format$(t, "hh:mm"& " (includes " & bias & " bias)" & vbCrLf
    dtb 
= obj.InstallDate
    bias 
= SplitDateTimeBias(dtb, d, t)
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "InstallDate" & vbTab & Format$(d, "dddd mmm d, yyyy"& " at " & Format$(t, "hh:mm"& " (includes " & bias & " bias)" & vbCrLf
    dtb 
= obj.LastBootUpTime
    bias 
= SplitDateTimeBias(dtb, d, t)
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "LastBootUpTime" & vbTab & Format$(d, "dddd mmm d, yyyy"& " at " & Format$(t, "hh:mm"& " (includes " & bias & " bias)" & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "OSLanguage" & vbTab & obj.OSLanguage & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "CodeSet" & vbTab & obj.CodeSet & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "Locale" & vbTab & obj.Locale & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "CountryCode" & vbTab & obj.CountryCode & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "CurrentTimeZone" & vbTab & obj.CurrentTimeZone & vbCrLf
      
Select Case obj.ForegroundApplicationBoost
         
Case 0: Msg = "none"
         
Case 1: Msg = "minimum"
         
Case 2: Msg = "maximum (default)"
      
End Select
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "ForegroundApplicationBoost" & vbTab & Msg & vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "TotalVisibleMemorySize" & vbTab & FormatNumber(obj.TotalVisibleMemorySize, 0& vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "FreePhysicalMemory" & vbTab & FormatNumber(obj.FreePhysicalMemory, 0& vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "TotalVirtualMemorySize" & vbTab & FormatNumber(obj.TotalVirtualMemorySize, 0& vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "FreeVirtualMemory" & vbTab & FormatNumber(obj.FreeVirtualMemory, 0& vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "FreeSpaceInPagingFiles" & vbTab & FormatNumber(obj.FreeSpaceInPagingFiles, 0& vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & "SizeStoredInPagingFiles" & FormatNumber(obj.SizeStoredInPagingFiles, 0& vbCrLf
wmiOperatingSystemInfo 
= wmiOperatingSystemInfo & vbCrLf
Next obj
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiPointingDeviceInfo()Function wmiPointingDeviceInfo() As String
   
Dim wmiObjSet  As SWbemObjectSet
   
Dim obj        As SWbemObject
   
Dim Msg        As String
   
Dim Thiscol    As Long
On Local Error Resume Next
   
  
''add first column and set initial parameters
wmiPointingDeviceInfo = wmiPointingDeviceInfo & "WMI Property" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "Description" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "Status" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "ConfigManagerErrorCode" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "Manufacturer" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "Name" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "HardwareType" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "DeviceInterface" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "DoubleSpeedThreshold" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "Handedness" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "NumberOfButtons" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "PointingType" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "QuadSpeedThreshold" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "DeviceID" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & "PNPDeviceID" & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & vbCrLf
Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_PointingDevice")
For Each obj In wmiObjSet
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.Description & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.Description & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.Status & vbTab
        
Select Case obj.ConfigManagerErrorCode
            
Case 0: Msg = "This device is working properly."
            
Case 1: Msg = "This device is not configured correctly."
            
Case 2: Msg = "Windows cannot load the driver for this device."
            
Case 3: Msg = "The driver might be corrupted, or your system " & "may be running low on memory or other resources."
            
Case 4: Msg = "This device is not working properly. One of its " & "drivers or your registry might be corrupted."
            
Case 5: Msg = "The driver for this device needs a resource " & "that Windows cannot manage."
            
Case 6: Msg = "The boot configuration for this device " & "conflicts with other devices."
            
Case 7: Msg = "Cannot filter."
            
Case 8: Msg = "The driver loader for the device is missing."
            
Case 9: Msg = "This device is not working properly because" & "the controlling firmware is reporting the " & "resources for the device incorrectly."
            
Case 10: Msg = "This device cannot start."
            
Case 11: Msg = "This device failed."
            
Case 12: Msg = "This device cannot find enough free " & "resources that it can use."
            
Case 13: Msg = "Windows cannot verify this device''s resources."
            
Case 14: Msg = "This device cannot work properly until " & "you restart your computer."
            
Case 15: Msg = "This device is not working properly because " & "there is probably a re-enumeration problem."
            
Case 16: Msg = "Windows cannot identify all the resources this device uses."
            
Case 17: Msg = "This device is asking for an unknown resource type."
            
Case 18: Msg = "Reinstall the drivers for this device."
            
Case 19: Msg = "Failure using the VXD loader."
            
Case 20: Msg = "Your registry might be corrupted."
            
Case 21: Msg = "System failure: Try changing the driver for this device. " & "If that does not work, see your hardware " & "documentation. Windows is removing this device."
            
Case 22: Msg = "This device is disabled."
            
Case 23: Msg = "System failure: Try changing the driver for " & "this device. If that doesn''t work, see your " & "hardware documentation."
            
Case 24: Msg = "This device is not present, is not working " & "properly, or does not have all its drivers installed."
            
Case 25: Msg = "Windows is still setting up this device."
            
Case 26: Msg = "Windows is still setting up this device."
            
Case 27: Msg = "This device does not have valid log configuration."
            
Case 28: Msg = "The drivers for this device are not installed."
            
Case 29: Msg = "This device is disabled because the firmware of " & "the device did not give it the required resources."
            
Case 30: Msg = "This device is using an Interrupt Request (IRQ) " & "resource that another device is using."
            
Case 31: Msg = "This device is not working properly because Windows " & "cannot load the drivers required for this device."
         
End Select
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & Msg & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.Manufacturer & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.Name & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.HardwareType & vbTab
         
Select Case obj.DeviceInterface
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "Serial"
            
Case 4: Msg = "PS/2"
            
Case 5: Msg = "Infrared"
            
Case 6: Msg = "HP-HIL"
            
Case 7: Msg = "Bus mouse"
            
Case 8: Msg = "ADB (Apple Desktop Bus)"
            
Case 160: Msg = "Bus mouse DB-9"
            
Case 161: Msg = "Bus mouse micro-DIN"
            
Case 162: Msg = "USB"
         
End Select
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & Msg & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.DoubleSpeedThreshold & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.Handedness & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.NumberOfButtons & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.PointingType & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.QuadSpeedThreshold & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.DeviceID & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & obj.PNPDeviceID & vbTab
wmiPointingDeviceInfo 
= wmiPointingDeviceInfo & vbCrLf
Next obj
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************

Public Function wmiSystemSlotInfo()Function wmiSystemSlotInfo() As String
   
Dim wmiObjSet  As SWbemObjectSet
   
Dim obj        As SWbemObject
   
Dim Thiscol    As Long
   
Dim capcount   As Long
   
Dim Msg        As String
   
Dim Cnt        As Long
On Local Error Resume Next
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "WMI Property" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "Number" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "Description" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "Tag" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "Status" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "ConnectorPinout" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "CurrentUsage" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "MaxDataWidth" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "PMESignal" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "Shared" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "SupportsHotPlug" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "VccMixedVoltageSupport" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & "ConnectorType" & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & vbCrLf
Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_SystemSlot")
For Each obj In wmiObjSet
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.SlotDesignation & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & IIf(obj.Number, obj.Number, "null"& vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.Description & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.Tag & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.Status & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & IIf(obj.ConnectorPinout, obj.ConnectorPinout, "null"& vbTab
         
Select Case obj.CurrentUsage
            
Case 0: Msg = "Reserved"
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "Available"
            
Case 4: Msg = "In use"
         
End Select
wmiSystemSlotInfo 
= wmiSystemSlotInfo & Msg & vbTab
         
Select Case obj.MaxDataWidth
            
Case 0: Msg = "8"
            
Case 1: Msg = "16"
            
Case 2: Msg = "32"
            
Case 3: Msg = "64"
            
Case 4: Msg = "128"
         
End Select
wmiSystemSlotInfo 
= wmiSystemSlotInfo & Msg & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.PMESignal & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.Shared & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & obj.SupportsHotPlug & vbTab
    
For Cnt = LBound(obj.VccMixedVoltageSupport) To UBound(obj.VccMixedVoltageSupport)
        
Select Case obj.VccMixedVoltageSupport(Cnt)
               
Case 0: Msg = Msg & "Unknown  "
               
Case 1: Msg = Msg & "Other  "
               
Case 2: Msg = Msg & "3.3v  "
               
Case 3: Msg = Msg & "5v  "
               
Case Else: Msg = ""
        
End Select
    
Next Cnt
wmiSystemSlotInfo 
= wmiSystemSlotInfo & Msg & vbTab
    
For capcount = LBound(obj.ConnectorType) To UBound(obj.ConnectorType)
            
Select Case obj.ConnectorType(capcount)
               
Case 0: Msg = " Unknown"
               
Case 1: Msg = " Other"
               
Case 2: Msg = " Male"
               
Case 3: Msg = " Female"
               
Case 4: Msg = " Shielded"
               
Case 5: Msg = " Unshielded"
               
Case 6: Msg = " SCSI (A) High-Density (50 pins)"
               
Case 7: Msg = " SCSI (A) Low-Density (50 pins)"
               
Case 8: Msg = " SCSI (P) High-Density (68 pins)"
               
Case 9: Msg = " SCSI SCA-I (80 pins)"
               
Case 10: Msg = "SCSI SCA-II (80 pins)"
               
Case 11: Msg = "SCSI Fibre Channel (DB-9, Copper)"
               
Case 12: Msg = "SCSI Fibre Channel (Fibre)"
               
Case 13: Msg = "SCSI Fibre Channel SCA-II (40 pins)"
               
Case 14: Msg = "SCSI Fibre Channel SCA-II (20 pins)"
               
Case 15: Msg = "SCSI Fibre Channel BNC"
               
Case 16: Msg = "ATA 3-1/2 Inch (40 pins)"
               
Case 17: Msg = "ATA 2-1/2 Inch (44 pins)"
               
Case 18: Msg = "ATA-2"
               
Case 19: Msg = "ATA-3"
               
Case 20: Msg = "ATA/66"
               
Case 21: Msg = "DB-9"
               
Case 22: Msg = "DB-15"
               
Case 23: Msg = "DB-25"
               
Case 24: Msg = "DB-36"
               
Case 25: Msg = "RS-232C"
               
Case 26: Msg = "RS-422"
               
Case 27: Msg = "RS-423"
               
Case 28: Msg = "RS-485"
               
Case 29: Msg = "RS-449"
               
Case 30: Msg = "V.35"
               
Case 31: Msg = "X.21"
               
Case 32: Msg = "IEEE-488"
               
Case 33: Msg = "AUI"
               
Case 34: Msg = "UTP Category 3"
               
Case 35: Msg = "UTP Category 4"
               
Case 36: Msg = "UTP Category 5"
               
Case 37: Msg = "BNC"
               
Case 38: Msg = "RJ11"
               
Case 39: Msg = "RJ45"
               
Case 40: Msg = "Fiber MIC"
               
Case 41: Msg = "Apple AUI"
               
Case 42: Msg = "Apple GeoPort"
               
Case 43: Msg = "PCI"
               
Case 44: Msg = "ISA"
               
Case 45: Msg = "EISA"
               
Case 46: Msg = "VESA"
               
Case 47: Msg = "PCMCIA"
               
Case 48: Msg = "PCMCIA Type I"
               
Case 49: Msg = "PCMCIA Type II"
               
Case 50: Msg = "PCMCIA Type III"
               
Case 51: Msg = "ZV Port"
               
Case 52: Msg = "CardBus"
               
Case 53: Msg = "USB"
               
Case 54: Msg = "IEEE 1394"
               
Case 55: Msg = "HIPPI"
               
Case 56: Msg = "HSSDC (6 pins)"
               
Case 57: Msg = "GBIC"
               
Case 58: Msg = "DIN"
               
Case 59: Msg = "Mini-DIN"
               
Case 60: Msg = "Micro-DIN"
               
Case 61: Msg = "PS/2"
               
Case 62: Msg = "Infrared"
               
Case 63: Msg = "HP-HIL"
               
Case 64: Msg = "Access.bus"
               
Case 65: Msg = "NuBus"
               
Case 66: Msg = "Centronics"
               
Case 67: Msg = "Mini-Centronics"
               
Case 68: Msg = "Mini-Centronics Type-14"
               
Case 69: Msg = "Mini-Centronics Type-20"
               
Case 70: Msg = "Mini-Centronics Type-26"
               
Case 71: Msg = "Bus Mouse"
               
Case 72: Msg = "ADB"
               
Case 73: Msg = "AGP"
               
Case 74: Msg = "VME Bus"
               
Case 75: Msg = "VME64"
               
Case 76: Msg = "Proprietary"
               
Case 77: Msg = "Proprietary Processor Card Slot"
               
Case 78: Msg = "Proprietary Memory Card Slot"
               
Case 79: Msg = "Proprietary I/O Riser Slot"
               
Case 80: Msg = "PCI-66MHZ"
               
Case 81: Msg = "AGP2X"
               
Case 82: Msg = "AGP4X"
            
End Select
    
Next capcount
wmiSystemSlotInfo 
= wmiSystemSlotInfo & Msg & vbTab
wmiSystemSlotInfo 
= wmiSystemSlotInfo & vbCrLf
Next obj
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************
Public Function wmiComputerSystemInfo()Function wmiComputerSystemInfo() As String
   
Dim ComputerSystemSet As SWbemObjectSet
   
Dim Css As SWbemObject
   
Dim Thiscol As Long
   
Dim Msg As String
   
Dim Cnt As Long
On Error Resume Next
Set ComputerSystemSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_ComputerSystem")
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "WMI ComputerSystem Property" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "AdminPasswordStatus" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "AutomaticResetBootOption" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "AutomaticResetCapability" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "BootROMSupported" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "BootupState" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Caption" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "ChassisBootupState" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "CurrentTimeZone" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "DaylightInEffect" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Description" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Domain" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "DomainRole" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "EnableDaylightSavingsTime" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "FrontPanelResetStatus" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "InfraredSupported" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "KeyboardPasswordStatus" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Manufacturer" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Model" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Name" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "NetworkServerModeEnabled" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "NumberOfProcessors" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "PartOfDomain" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "PauseAfterReset" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "PowerOnPasswordStatus" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "PowerState" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "PowerSupplyState" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "PrimaryOwnerName" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "ResetCapability" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "ResetCount" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "ResetLimit" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Status" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "SystemStartupDelay" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "SystemStartupSetting" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "SystemType" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "ThermalState" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "TotalPhysicalMemory" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "UserName" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "WakeUpType" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "SystemStartupOptions" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & "Roles" & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & vbCrLf
For Each Css In ComputerSystemSet
         
Select Case Css.AdminPasswordStatus
            
Case 0: Msg = "Disabled"
            
Case 1: Msg = "Enabled"
            
Case 2: Msg = "Not Implemented"
            
Case 3: Msg = "Unknown"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Name & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.AutomaticResetBootOption & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.AutomaticResetCapability & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.BootROMSupported & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.BootupState & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Caption & vbTab
         
Select Case Css.ChassisBootupState
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "Safe"
            
Case 4: Msg = "Warning"
            
Case 5: Msg = "Critical"
            
Case 6: Msg = "Non-recoverable"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.CurrentTimeZone & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.DaylightInEffect & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Description & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Domain & vbTab
         
Select Case Css.DomainRole
            
Case 0: Msg = "Standalone Workstation"
            
Case 1: Msg = "Member Workstation"
            
Case 2: Msg = "Standalone Server"
            
Case 3: Msg = "Member Server"
            
Case 4: Msg = "Backup Domain Controller"
            
Case 5: Msg = "Primary Domain Controller"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.EnableDaylightSavingsTime & vbTab
         
Select Case Css.FrontPanelResetStatus
            
Case 0: Msg = "Disabled"
            
Case 1: Msg = "Enabled"
            
Case 2: Msg = "Not Implemented"
            
Case 3: Msg = "Unknown"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.InfraredSupported & vbTab
         
Select Case Css.KeyboardPasswordStatus
            
Case 0: Msg = "Disabled"
            
Case 1: Msg = "Enabled"
            
Case 2: Msg = "Not Implemented"
            
Case 3: Msg = "Unknown"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Manufacturer & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Model & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Name & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.NetworkServerModeEnabled & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.NumberOfProcessors & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.PartOfDomain & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.PauseAfterReset & vbTab
         
Select Case Css.PowerOnPasswordStatus
            
Case 0: Msg = "Disabled"
            
Case 1: Msg = "Enabled"
            
Case 2: Msg = "Not Implemented"
            
Case 3: Msg = "Unknown"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
         
Select Case Css.PowerState
            
Case 0: Msg = "Unknown"
            
Case 1: Msg = "Full Power"
            
Case 2: Msg = "Power Save - Low Power Mode"
            
Case 3: Msg = "Power Save - Standby"
            
Case 4: Msg = "Power Save - Unknown"
            
Case 5: Msg = "Power Cycle"
            
Case 6: Msg = "Power Off"
            
Case 7: Msg = "Power Save - Warning"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
        
Select Case Css.PowerSupplyState
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "Save"
            
Case 4: Msg = "Warning"
            
Case 5: Msg = "Critical"
            
Case 6: Msg = "Non-recoverable"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.PrimaryOwnerName & vbTab
          
Select Case Css.ResetCapability
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "Disabled"
            
Case 4: Msg = "Enabled"
            
Case 5: Msg = "Non-recoverable"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.ResetCount & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.ResetLimit & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.Status & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.SystemStartupDelay & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.SystemStartupSetting & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.SystemType & vbTab
          
Select Case Css.ThermalState
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "Safe"
            
Case 4: Msg = "Warning"
            
Case 5: Msg = "Critical"
            
Case 6: Msg = "Non-recoverable"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & FormatNumber(Css.TotalPhysicalMemory, 0& vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Css.UserName & vbTab
          
Select Case Css.WakeUpType
            
Case 0: Msg = "Reserved"
            
Case 1: Msg = "Other"
            
Case 2: Msg = "Unknown"
            
Case 3: Msg = "APM Timer"
            
Case 4: Msg = "Modem Ring"
            
Case 5: Msg = "LAN Remote"
            
Case 6: Msg = "Power Switch"
            
Case 7: Msg = "PCI PME#"
            
Case 8: Msg = "AC Power Restored"
            
Case Else: Msg = ""
         
End Select
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
         Msg 
= ""
         
For Cnt = LBound(Css.SystemStartupOptions) To UBound(Css.SystemStartupOptions)
            Msg 
= Msg & Css.SystemStartupOptions(Cnt) & "-And-"
         
Next Cnt
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
         Msg 
= ""
         
For Cnt = LBound(Css.Roles) To UBound(Css.Roles)
            Msg 
= Msg & Css.Roles(Cnt) & "-And-"
         
Next Cnt
wmiComputerSystemInfo 
= wmiComputerSystemInfo & Msg & vbTab
wmiComputerSystemInfo 
= wmiComputerSystemInfo & vbCrLf
Next Css
End Function
''--end block--''
'
'***********************************************************************************************
'
'***********************************************************************************************
posted @ 2008-07-08 21:13  Athrun  阅读(660)  评论(0编辑  收藏  举报