www.21code.com的系统控制中就有一个

解决方案 »

  1.   

    API 或Public Sub StartSysInfo()
        On Error GoTo SysInfoErr
            Dim rc As Long
            Dim SysInfoPath As String
                    ' Try To Get System Info Program Path\Name From Registry...
            If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
            ' Try To Get System Info Program Path Only From Registry...
            ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
                    ' Validate Existance Of Known 32 Bit File Version
                    If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
                            SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
                                            ' Error - File Can Not Be Found...
                    Else
                            GoTo SysInfoErr
                    End If
            ' Error - Registry Entry Can Not Be Found...
            Else
                    GoTo SysInfoErr
            End If
                    Call Shell(SysInfoPath, vbNormalFocus)
                    Exit Sub
    SysInfoErr:
            MsgBox "System Information Is Unavailable At This Time", vbOKOnly
    End Sub
    Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
            Dim i As Long                                           ' Loop Counter
            Dim rc As Long                                          ' Return Code
            Dim hKey As Long                                        ' Handle To An Open Registry Key
            Dim hDepth As Long                                      '
            Dim KeyValType As Long                                  ' Data Type Of A Registry Key
            Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
            Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
            '------------------------------------------------------------
            ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
            '------------------------------------------------------------
            rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
                    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
                    tmpVal = String$(1024, 0)                             ' Allocate Variable Space
            KeyValSize = 1024                                       ' Mark Variable Size
                    '------------------------------------------------------------
            ' Retrieve Registry Key Value...
            '------------------------------------------------------------
            rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
                                                            If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
                    tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
            '------------------------------------------------------------
            ' Determine Key Value Type For Conversion...
            '------------------------------------------------------------
            Select Case KeyValType                                  ' Search Data Types...
            Case REG_SZ                                             ' String Registry Key Data Type
                    KeyVal = tmpVal                                     ' Copy String Value
            Case REG_DWORD                                          ' Double Word Registry Key Data Type
                    For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
                            KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
                    Next
                    KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
            End Select
                    GetKeyValue = True                                      ' Return Success
            rc = RegCloseKey(hKey)                                  ' Close Registry Key
            Exit Function                                           ' Exit
            GetKeyError:    ' Cleanup After An Error Has Occured...
            KeyVal = ""                                             ' Set Return Val To Empty String
            GetKeyValue = False                                     ' Return Failure
            rc = RegCloseKey(hKey)                                  ' Close Registry Key
    End Function
      

  2.   

    主板
    VERSION 5.00
    Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
    Begin VB.Form Form1 
       Caption         =   "Form1"
       ClientHeight    =   6300
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   8985
       LinkTopic       =   "Form1"
       ScaleHeight     =   6300
       ScaleWidth      =   8985
       StartUpPosition =   3  'Windows Default
       Begin VB.CommandButton Command1 
          Caption         =   "Command1"
          Height          =   375
          Left            =   3000
          TabIndex        =   1
          Top             =   5640
          Width           =   2655
       End
       Begin MSComctlLib.ListView ListView1 
          Height          =   5295
          Left            =   120
          TabIndex        =   0
          Top             =   120
          Width           =   8655
          _ExtentX        =   15266
          _ExtentY        =   9340
          LabelWrap       =   -1  'True
          HideSelection   =   -1  'True
          _Version        =   393217
          ForeColor       =   -2147483640
          BackColor       =   -2147483643
          BorderStyle     =   1
          Appearance      =   1
          NumItems        =   0
       End
    End
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
    ' Some pages may also contain other copyrights by the author.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Distribution: You can freely use this code in your own
    '               applications, but you can not publish
    '               or reproduce this code on any web site,
    '               on any online service, or distribute on
    '               any media without express permission.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '/* used for listview column auto-resizing
    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1
    Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hwnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
    Private Sub Form_Load()   With ListView1
          .ListItems.Clear
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "Product"
          .ColumnHeaders.Add , , "Manufacturer"
          .View = lvwReport
          .Sorted = False
       End With
       
       Command1.Caption = "BaseBoard Info"End Sub
    Private Sub Command1_Click()   ListView1.ListItems.Clear
       Call wmiBaseBoardInfo
       Call lvAutosizeControl(ListView1)
       
    End Sub
    Private Sub lvAutosizeControl(lv As ListView)   Dim col2adjust As Long  '/* Size each column based on the maximum of
      '/* EITHER the columnheader text width, or,
      '/* if the items below it are wider, the
      '/* widest list item in the column
       For col2adjust = 0 To lv.ColumnHeaders.Count - 1
       
          Call SendMessage(lv.hwnd, _
                           LVM_SETCOLUMNWIDTH, _
                           col2adjust, _
                           ByVal LVSCW_AUTOSIZE_USEHEADER)   Next
       
    End Sub
    Private Sub wmiBaseBoardInfo()   Dim BaseBoardSet As SWbemObjectSet
       Dim bb As SWbemObject
       Dim itmx As ListItem
       
       Set BaseBoardSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                                     InstancesOf("Win32_BaseBoard")
          
       On Local Error Resume Next
       
       For Each bb In BaseBoardSet
       
          Set itmx = ListView1.ListItems.Add(, , "Manufacturer")
          itmx.SubItems(1) = bb.Manufacturer
          Set itmx = ListView1.ListItems.Add(, , "Caption")
          itmx.SubItems(1) = bb.Caption
          Set itmx = ListView1.ListItems.Add(, , "ConfigOptions")
          itmx.SubItems(1) = bb.ConfigOptions
          Set itmx = ListView1.ListItems.Add(, , "CreationClassName")
          itmx.SubItems(1) = bb.CreationClassName
          Set itmx = ListView1.ListItems.Add(, , "Depth")
          itmx.SubItems(1) = bb.Depth
          Set itmx = ListView1.ListItems.Add(, , "Description")
          itmx.SubItems(1) = bb.Description
          Set itmx = ListView1.ListItems.Add(, , "Height")
          itmx.SubItems(1) = bb.Height
          Set itmx = ListView1.ListItems.Add(, , "HostingBoard")
          itmx.SubItems(1) = bb.HostingBoard
          Set itmx = ListView1.ListItems.Add(, , "HotSwappable")
          itmx.SubItems(1) = bb.HotSwappable
          Set itmx = ListView1.ListItems.Add(, , "InstallDate")
          itmx.SubItems(1) = bb.InstallDate
          Set itmx = ListView1.ListItems.Add(, , "Model")
          itmx.SubItems(1) = bb.Model
          Set itmx = ListView1.ListItems.Add(, , "Name")
          itmx.SubItems(1) = bb.Name
          Set itmx = ListView1.ListItems.Add(, , "OtherIdentifyingInfo")
          itmx.SubItems(1) = bb.OtherIdentifyingInfo
          Set itmx = ListView1.ListItems.Add(, , "PartNumber")
          itmx.SubItems(1) = bb.PartNumber
          Set itmx = ListView1.ListItems.Add(, , "PoweredOn")
          itmx.SubItems(1) = bb.PoweredOn
          Set itmx = ListView1.ListItems.Add(, , "Product")
          itmx.SubItems(1) = bb.Product
          Set itmx = ListView1.ListItems.Add(, , "Removable")
          itmx.SubItems(1) = bb.Removable
          Set itmx = ListView1.ListItems.Add(, , "Replaceable")
          itmx.SubItems(1) = bb.Replaceable
          Set itmx = ListView1.ListItems.Add(, , "RequirementsDescription")
          itmx.SubItems(1) = bb.RequirementsDescription
          Set itmx = ListView1.ListItems.Add(, , "RequiresDaughterBoard")
          itmx.SubItems(1) = bb.RequiresDaughterBoard
          Set itmx = ListView1.ListItems.Add(, , "SerialNumber")
          itmx.SubItems(1) = bb.SerialNumber
          Set itmx = ListView1.ListItems.Add(, , "SKU")
          itmx.SubItems(1) = bb.SKU
          Set itmx = ListView1.ListItems.Add(, , "SlotLayout")
          itmx.SubItems(1) = bb.SlotLayout
          Set itmx = ListView1.ListItems.Add(, , "SpecialRequirements")
          itmx.SubItems(1) = bb.SpecialRequirements
          Set itmx = ListView1.ListItems.Add(, , "Status")
          itmx.SubItems(1) = bb.Status
          Set itmx = ListView1.ListItems.Add(, , "Tag")
          itmx.SubItems(1) = bb.Tag
          Set itmx = ListView1.ListItems.Add(, , "Version")
          itmx.SubItems(1) = bb.Version
          Set itmx = ListView1.ListItems.Add(, , "Weight")
          itmx.SubItems(1) = bb.Weight
          Set itmx = ListView1.ListItems.Add(, , "Width")
          itmx.SubItems(1) = bb.Width
       NextEnd Sub
      

  3.   

    硬盘
    VERSION 5.00
    Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
    Begin VB.Form Form1 
       Caption         =   "Form1"
       ClientHeight    =   6375
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   10095
       LinkTopic       =   "Form1"
       ScaleHeight     =   6375
       ScaleWidth      =   10095
       StartUpPosition =   3  'Windows Default
       Begin VB.CommandButton Command1 
          Caption         =   "Command1"
          Height          =   375
          Left            =   4200
          TabIndex        =   1
          Top             =   5880
          Width           =   1815
       End
       Begin MSComctlLib.ListView ListView1 
          Height          =   5535
          Left            =   120
          TabIndex        =   0
          Top             =   120
          Width           =   9855
          _ExtentX        =   17383
          _ExtentY        =   9763
          LabelWrap       =   -1  'True
          HideSelection   =   -1  'True
          _Version        =   393217
          ForeColor       =   -2147483640
          BackColor       =   -2147483643
          BorderStyle     =   1
          Appearance      =   1
          NumItems        =   0
       End
    End
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
    ' Some pages may also contain other copyrights by the author.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Distribution: You can freely use this code in your own
    '               applications, but you can not publish
    '               or reproduce this code on any web site,
    '               on any online service, or distribute on
    '               any media without express permission.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '/* used for listview column auto-resizing
    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1
    Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hwnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
    Private Sub Form_Load()   With ListView1
          .ListItems.Clear
          .ColumnHeaders.Clear
          .View = lvwReport
          .Sorted = False
       End With
       
       Command1.Caption = "Disk Info"End Sub
    Private Sub Command1_Click()   ListView1.ListItems.Clear
       Call wmiDiskDriveInfo
       Call lvAutosizeControl(ListView1)
       
    End Sub
    Private Sub lvAutosizeControl(lv As ListView)   Dim col2adjust As Long  '/* Size each column based on the maximum of
      '/* EITHER the columnheader text width, or,
      '/* if the items below it are wider, the
      '/* widest list item in the column
       For col2adjust = 0 To lv.ColumnHeaders.Count - 1
       
          Call SendMessage(lv.hwnd, _
                           LVM_SETCOLUMNWIDTH, _
                           col2adjust, _
                           ByVal LVSCW_AUTOSIZE_USEHEADER)   Next
       
    End Sub
    Private Sub wmiDiskDriveInfo()   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
       Dim itmx As ListItem   On Local Error GoTo diskinfo_error
       
      'add a first column, and set lv initial parameters
       With ListView1
          .ListItems.Clear
          .View = lvwReport
          .Sorted = False
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "WMI Property"
          
          'add class properties to column 1
          'identification info
          .ListItems.Add , , "ID: Description"
          .ListItems.Add , , "ID: Index"
          .ListItems.Add , , "ID: DeviceID"
          .ListItems.Add , , "ID: Caption"
          .ListItems.Add , , "ID: Manufacturer"
          .ListItems.Add , , "ID: Model"
          .ListItems.Add , , "ID: InterfaceType"
          .ListItems.Add , , "ID: MediaLoaded"
          .ListItems.Add , , "ID: MediaType"
          
          'physical info
          .ListItems.Add , , "Phyical: Status"
          .ListItems.Add , , "Phyical: Size"
          .ListItems.Add , , "Phyical: Partitions"
          .ListItems.Add , , "Phyical: BytesPerSector"
          .ListItems.Add , , "Phyical: SectorsPerTrack"
          .ListItems.Add , , "Phyical: TotalCylinders"
          .ListItems.Add , , "Phyical: TotalHeads"
          .ListItems.Add , , "Phyical: TotalTracks"
          .ListItems.Add , , "Phyical: TracksPerCylinder"
          
          'capabilities of the device
          .ListItems.Add , , "Disk Capabilities:"
       End With   Set DiskDriveSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                                               InstancesOf("Win32_DiskDrive")
           
      'for each drive, fill in respective columns
       For Each dd In DiskDriveSet
       
          With ListView1
             .ColumnHeaders.Add , , dd.Description & " " & dd.Index
             capcount = 0
             thiscol = (.ColumnHeaders.Count - 1)
             
             'add identification info
             .ListItems(1).SubItems(thiscol) = dd.Description
             .ListItems(2).SubItems(thiscol) = dd.Index
             .ListItems(3).SubItems(thiscol) = dd.DeviceID
             .ListItems(4).SubItems(thiscol) = dd.Caption
             .ListItems(5).SubItems(thiscol) = dd.Manufacturer
             .ListItems(6).SubItems(thiscol) = dd.Model
             .ListItems(7).SubItems(thiscol) = dd.InterfaceType
             .ListItems(8).SubItems(thiscol) = dd.MediaLoaded
             .ListItems(9).SubItems(thiscol) = dd.MediaType         'add physical info
             .ListItems(10).SubItems(thiscol) = dd.Status
             .ListItems(11).SubItems(thiscol) = FormatNumber(dd.Size, 0)
             .ListItems(12).SubItems(thiscol) = dd.Partitions
             .ListItems(13).SubItems(thiscol) = FormatNumber(dd.BytesPerSector, 0)
             .ListItems(14).SubItems(thiscol) = FormatNumber(dd.SectorsPerTrack, 0)
             .ListItems(15).SubItems(thiscol) = FormatNumber(dd.TotalCylinders, 0)
             
             'note: the value for the TotalHeads property
             'is obtained through extended functions of
             'BIOS interrupt 13h. The value may be inaccurate
             'if the drive uses a translation scheme to
             'support high capacity disk sizes. Consult
             'the manufacturer for accurate drive
             'specifications
             .ListItems(16).SubItems(thiscol) = FormatNumber(dd.TotalHeads, 0)
             .ListItems(17).SubItems(thiscol) = FormatNumber(dd.TotalTracks, 0)
             .ListItems(18).SubItems(thiscol) = FormatNumber(dd.TracksPerCylinder, 0)
          
            'capabilities of the device
             
            'because different drives may have different
            'capabilites, the routine is coded such that
            'when an insertion is attempted against a
            'non-existant subitem index, the error trap
            'will add the additional row. The sflag
            'just assists in identifying the error
            'occured because of the capactities loop.
             sflag = "caploop"
      

  4.   

    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
                
                .ListItems(19 + capcount).SubItems(thiscol) = msg
            
             Next
             sflag = ""
          
          End With
          
       Next
       
    diskinfo_exit:   On Local Error GoTo 0
       Exit Sub
       
    diskinfo_error:  'if "index out of bounds" error
      'and error occurred as result of
      'adding drive capabilities, add
      'a new blank listitem and resume
       If Err.Number = 35600 And sflag = "caploop" Then
          ListView1.ListItems.Add 19 + capcount, , ""
          Resume
       Else
          Resume Next
       End If
    End Sub
      

  5.   

    网卡IP
    '**********************************
    '* 得到网卡地址
    '* EthernetAddress(0)
    '* 返回值:字符串
    '**********************************
    Public Function EthernetAddress(LanaNumber As Long) As String
      Dim udtNCB       As NCB
      Dim bytResponse  As Byte
      Dim udtASTAT     As ASTAT
      Dim udtTempASTAT As ASTAT
      Dim lngASTAT     As Long
      Dim strOut       As String
      Dim x            As Integer
      udtNCB.ncb_command = NCBRESET
      bytResponse = Netbios(udtNCB)
      udtNCB.ncb_command = NCBASTAT
      udtNCB.ncb_lana_num = LanaNumber
      udtNCB.ncb_callname = "* "
      udtNCB.ncb_length = Len(udtASTAT)
      lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
      strOut = ""
      If lngASTAT Then
        udtNCB.ncb_buffer = lngASTAT
        bytResponse = Netbios(udtNCB)
        CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
         With udtASTAT.adapt
          For x = 0 To 5
            strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
          Next x
        End With
        HeapFree GetProcessHeap(), 0, lngASTAT
      End If
      EthernetAddress = strOut
    End Function
    '得到IP地址
    '屏幕调用 LocalIPAddress()Option ExplicitPublic Const MAX_ADAPTER_NAME_LENGTH         As Long = 256
    Public Const MAX_ADAPTER_DESCRIPTION_LENGTH  As Long = 128
    Public Const MAX_ADAPTER_ADDRESS_LENGTH      As Long = 8
    Public Const ERROR_SUCCESS  As Long = 0Public Type IP_ADDRESS_STRING
        IpAddr(0 To 15)  As Byte
    End TypePublic Type IP_MASK_STRING
        IpMask(0 To 15)  As Byte
    End TypePublic Type IP_ADDR_STRING
        dwNext     As Long
        IpAddress  As IP_ADDRESS_STRING
        IpMask     As IP_MASK_STRING
        dwContext  As Long
    End TypePublic Type IP_ADAPTER_INFO
      dwNext                As Long
      ComboIndex            As Long  '保留
      sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))        As Byte
      sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
      dwAddressLength       As Long
      sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))       As Byte
      dwIndex               As Long
      uType                 As Long
      uDhcpEnabled          As Long
      CurrentIpAddress      As Long
      IpAddressList         As IP_ADDR_STRING
      GatewayList           As IP_ADDR_STRING
      DhcpServer            As IP_ADDR_STRING
      bHaveWins             As Long
      PrimaryWinsServer     As IP_ADDR_STRING
      SecondaryWinsServer   As IP_ADDR_STRING
      LeaseObtained         As Long
      LeaseExpires          As Long
    End TypePublic Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
      (pTcpTable As Any, _
       pdwSize As Long) As Long
       
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
      (dst As Any, _
       src As Any, _
       ByVal bcount As Long)
     Function LocalIPAddress() As String
       Dim cbRequired  As Long
       Dim buff()      As Byte
       Dim Adapter     As IP_ADAPTER_INFO
       Dim AdapterStr  As IP_ADDR_STRING
       Dim ptr1        As Long
       Dim sIPAddr     As String
       Dim found       As Boolean
       Call GetAdaptersInfo(ByVal 0&, cbRequired)
       If cbRequired > 0 Then
          ReDim buff(0 To cbRequired - 1) As Byte
          If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
            '获取存放在buff()中的数据的指针
             ptr1 = VarPtr(buff(0))
             Do While (ptr1 <> 0)
               '将第一个网卡的数据转换到IP_ADAPTER_INFO结构中
                CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
                With Adapter
                  'IpAddress.IpAddr成员给出了DHCP的IP地址
                   sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
                   If Len(sIPAddr) > 0 Then
                      found = True
                      Exit Do
                   End If
                   ptr1 = .dwNext
                End With  'With Adapter
            '不再有网卡时,ptr1的值为0
             Loop  'Do While (ptr1 <> 0)
          End If  'If GetAdaptersInfo
       End If  'If cbRequired > 0
      '返回结果字符串
       LocalIPAddress = sIPAddr
    End Function Function TrimNull(item As String)
        Dim pos As Integer
        pos = InStr(item, Chr$(0))
        If pos Then
              TrimNull = Left$(item, pos - 1)
        Else: TrimNull = item
        End If
    End Function
      

  6.   

    BIOSVERSION 5.00
    Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
    Begin VB.Form Form1 
       Caption         =   "Form1"
       ClientHeight    =   6135
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   9045
       LinkTopic       =   "Form1"
       ScaleHeight     =   6135
       ScaleWidth      =   9045
       StartUpPosition =   3  'Windows Default
       Begin VB.CommandButton Command1 
          Caption         =   "Command1"
          Height          =   375
          Left            =   3720
          TabIndex        =   1
          Top             =   5640
          Width           =   1815
       End
       Begin MSComctlLib.ListView ListView1 
          Height          =   5295
          Left            =   120
          TabIndex        =   0
          Top             =   120
          Width           =   8775
          _ExtentX        =   15478
          _ExtentY        =   9340
          LabelWrap       =   -1  'True
          HideSelection   =   -1  'True
          _Version        =   393217
          ForeColor       =   -2147483640
          BackColor       =   -2147483643
          BorderStyle     =   1
          Appearance      =   1
          NumItems        =   0
       End
    End
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
    ' Some pages may also contain other copyrights by the author.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Distribution: You can freely use this code in your own
    '               applications, but you can not publish
    '               or reproduce this code on any web site,
    '               on any online service, or distribute on
    '               any media without express permission.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'listview column auto-resizing
    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1
    Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hwnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
    Private Sub Form_Load()   With ListView1
          .ListItems.Clear
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "WMI Property"
          .ColumnHeaders.Add , , "Value(s)"
          .View = lvwReport
          .Sorted = False
       End With
       
       Command1.Caption = "BIOS Info"End Sub
    Private Sub Command1_Click()   ListView1.ListItems.Clear
       Call wmiBiosInfo
       Call lvAutosizeControl(ListView1)
       
    End Sub
    Private Sub lvAutosizeControl(lv As ListView)   Dim col2adjust As Long  '/* Size each column based on the maximum of
      '/* EITHER the columnheader text width, or,
      '/* if the items below it are wider, the
      '/* widest list item in the column
       For col2adjust = 0 To lv.ColumnHeaders.Count - 1
       
          Call SendMessage(lv.hwnd, _
                           LVM_SETCOLUMNWIDTH, _
                           col2adjust, _
                           ByVal LVSCW_AUTOSIZE_USEHEADER)   Next
       
    End Sub
    Private Sub wmiBiosInfo()
          
       Dim BiosSet As SWbemObjectSet
       Dim bios As SWbemObject
       Dim itmx As ListItem
       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
       
          Set itmx = ListView1.ListItems.Add(, , "PrimaryBIOS")
          itmx.SubItems(1) = bios.PrimaryBIOS
                
          Set itmx = ListView1.ListItems.Add(, , "Status")
          itmx.SubItems(1) = bios.Status
          
          For cnt = LBound(bios.BIOSVersion) To UBound(bios.BIOSVersion)
             Set itmx = ListView1.ListItems.Add(, , IIf(cnt = 0, "BIOSVersion strings", ""))
             itmx.SubItems(1) = bios.BIOSVersion(cnt)
          Next
          
          Set itmx = ListView1.ListItems.Add(, , "Caption")
          itmx.SubItems(1) = bios.Caption
          
          Set itmx = ListView1.ListItems.Add(, , "Description")
          itmx.SubItems(1) = bios.Description
          
          Set itmx = ListView1.ListItems.Add(, , "Name")
          itmx.SubItems(1) = bios.Name      Set itmx = ListView1.ListItems.Add(, , "Manufacturer")
          itmx.SubItems(1) = bios.Manufacturer      Set itmx = ListView1.ListItems.Add(, , "ReleaseDate")
          itmx.SubItems(1) = bios.ReleaseDate      Set itmx = ListView1.ListItems.Add(, , "SerialNumber")
          itmx.SubItems(1) = bios.SerialNumber      Set itmx = ListView1.ListItems.Add(, , "SMBIOSBIOSVersion")
          itmx.SubItems(1) = bios.SMBIOSBIOSVersion
          
          Set itmx = ListView1.ListItems.Add(, , "SMBIOSMajorVersion")
          itmx.SubItems(1) = bios.SMBIOSMajorVersion
          
          Set itmx = ListView1.ListItems.Add(, , "SMBIOSMinorVersion")
          itmx.SubItems(1) = bios.SMBIOSMinorVersion      Set itmx = ListView1.ListItems.Add(, , "SMBIOSPresent")
          itmx.SubItems(1) = bios.SMBIOSPresent
          
          Set itmx = ListView1.ListItems.Add(, , "SoftwareElementID")
          itmx.SubItems(1) = bios.SoftwareElementID
          
          Set itmx = ListView1.ListItems.Add(, , "SoftwareElementState")
          Select Case bios.SoftwareElementState
             Case 0: msg = "deployable"
             Case 1: msg = "installable"
             Case 2: msg = "executable"
             Case 3: msg = "running"
          End Select
          itmx.SubItems(1) = msg
          
          Set itmx = ListView1.ListItems.Add(, , "Version")
          itmx.SubItems(1) = bios.Version      Set itmx = ListView1.ListItems.Add(, , "InstallableLanguages")
          itmx.SubItems(1) = bios.InstallableLanguages      Set itmx = ListView1.ListItems.Add(, , "CurrentLanguage")
          itmx.SubItems(1) = bios.CurrentLanguage
            
      

  7.   

    For cnt = LBound(bios.ListOfLanguages) To UBound(bios.ListOfLanguages)
          
             Set itmx = ListView1.ListItems.Add(, , IIf(cnt = 0, "ListOfLanguages", ""))
             itmx.SubItems(1) = bios.ListOfLanguages(cnt)
             
          Next cnt      For cnt = LBound(bios.BiosCharacteristics) To UBound(bios.BiosCharacteristics)
          
             Set itmx = ListView1.ListItems.Add(, , IIf(cnt = 0, "BIOS Characteristics", ""))
          
             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
             
             itmx.SubItems(1) = msg
             
          Next  'For cnt
          
       Next  'For Each biosEnd Sub
      

  8.   

    显卡
    VERSION 5.00
    Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
    Begin VB.Form Form1 
       Caption         =   "Form1"
       ClientHeight    =   6300
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   10125
       LinkTopic       =   "Form1"
       ScaleHeight     =   6300
       ScaleWidth      =   10125
       StartUpPosition =   3  'Windows Default
       Begin VB.CommandButton Command1 
          Caption         =   "Command1"
          Height          =   495
          Left            =   4320
          TabIndex        =   1
          Top             =   5640
          Width           =   1695
       End
       Begin MSComctlLib.ListView ListView1 
          Height          =   5295
          Left            =   120
          TabIndex        =   0
          Top             =   120
          Width           =   9855
          _ExtentX        =   17383
          _ExtentY        =   9340
          LabelWrap       =   -1  'True
          HideSelection   =   -1  'True
          _Version        =   393217
          ForeColor       =   -2147483640
          BackColor       =   -2147483643
          BorderStyle     =   1
          Appearance      =   1
          NumItems        =   0
       End
    End
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
    ' Some pages may also contain other copyrights by the author.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Distribution: You can freely use this code in your own
    '               applications, but you can not publish
    '               or reproduce this code on any web site,
    '               on any online service, or distribute on
    '               any media without express permission.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'listview column auto-resizing
    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1
    Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hwnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
    Private Sub Form_Load()   With ListView1
          .ListItems.Clear
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "Processor"
          .ColumnHeaders.Add , , "BPS"
          .ColumnHeaders.Add , , "Hres"
          .ColumnHeaders.Add , , "Vres"
          .ColumnHeaders.Add , , "Freq"
          .ColumnHeaders.Add , , "Colours"
          .ColumnHeaders.Add , , "rf min"
          .ColumnHeaders.Add , , "rf max"
          .ColumnHeaders.Add , , "Vmode"
          .ColumnHeaders.Add , , "Mem"
          .ColumnHeaders.Add , , "AdapterDACType"
          
          .View = lvwReport
          .Sorted = False
          
       End With
       
       Command1.Caption = "Video Controller Info"End Sub
    Private Sub Command1_Click()   ListView1.ListItems.Clear
       Call wmiVideoControllerInfo
       Call lvAutosizeControl(ListView1)
       
    End Sub
    Private Sub lvAutosizeControl(lv As ListView)   Dim col2adjust As Long  'Size each column based on the maximum of
      'wither the ColumnHeader text width, or,
      'if the items below it are wider, the
      'widest list item in the column
       lv.Visible = False
       For col2adjust = 0 To lv.ColumnHeaders.Count - 1
       
          Call SendMessage(lv.hwnd, _
                           LVM_SETCOLUMNWIDTH, _
                           col2adjust, _
                           ByVal LVSCW_AUTOSIZE_USEHEADER)   Next
       lv.Visible = True
       
    End Sub
    Private Sub wmiVideoControllerInfo()   Dim wmiObjSet As SWbemObjectSet
       Dim obj As SWbemObject
       Dim itmx As ListItem
       Dim msg As String
       
       Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                              InstancesOf("Win32_VideoController")
       
       On Local Error Resume Next
       
       For Each obj In wmiObjSet
       
          Set itmx = ListView1.ListItems.Add(, , obj.VideoProcessor)
          
          itmx.SubItems(1) = obj.CurrentBitsPerPixel
          itmx.SubItems(2) = obj.CurrentHorizontalResolution
          itmx.SubItems(3) = obj.CurrentVerticalResolution
          itmx.SubItems(4) = obj.CurrentRefreshRate
          itmx.SubItems(5) = obj.CurrentNumberOfColors
          itmx.SubItems(6) = obj.MinRefreshRate
          itmx.SubItems(7) = obj.MaxRefreshRate      Select Case obj.CurrentScanMode
             Case 1: msg = "other"
             Case 2: msg = "unknwn"
             Case 3: msg = "intrlcd"
             Case 4: msg = "nintrlcd"
          End Select
          itmx.SubItems(8) = msg
          
          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
          itmx.SubItems(9) = msg
          itmx.SubItems(9) = obj.AdapterDACType   Next
       
    End Sub
      

  9.   

    显示器
    VERSION 5.00
    Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
    Begin VB.Form Form1 
       Caption         =   "Form1"
       ClientHeight    =   5985
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   10350
       LinkTopic       =   "Form1"
       ScaleHeight     =   5985
       ScaleWidth      =   10350
       StartUpPosition =   3  'Windows Default
       Begin VB.CommandButton Command1 
          Caption         =   "Command1"
          Height          =   375
          Left            =   4200
          TabIndex        =   1
          Top             =   5400
          Width           =   2055
       End
       Begin MSComctlLib.ListView ListView1 
          Height          =   5055
          Left            =   120
          TabIndex        =   0
          Top             =   120
          Width           =   10095
          _ExtentX        =   17806
          _ExtentY        =   8916
          LabelWrap       =   -1  'True
          HideSelection   =   -1  'True
          _Version        =   393217
          ForeColor       =   -2147483640
          BackColor       =   -2147483643
          BorderStyle     =   1
          Appearance      =   1
          NumItems        =   0
       End
    End
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
    ' Some pages may also contain other copyrights by the author.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Distribution: You can freely use this code in your own
    '               applications, but you can not publish
    '               or reproduce this code on any web site,
    '               on any online service, or distribute on
    '               any media without express permission.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'listview column auto-resizing
    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1
    Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hwnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
    Private Sub Form_Load()   With ListView1
          .ListItems.Clear
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "Device ID"
          .ColumnHeaders.Add , , "Caption"
          .ColumnHeaders.Add , , "Manu"
          .ColumnHeaders.Add , , "Stat"
          .ColumnHeaders.Add , , "Availability"
          .View = lvwReport
          .Sorted = False
       End With
       
       Command1.Caption = "Desktop Monitor Info"
          
    End Sub
    Private Sub Command1_Click()   ListView1.ListItems.Clear
       Call wmiDesktopMonitorInfo
       Call lvAutosizeControl(ListView1)
       
    End Sub
    Private Sub lvAutosizeControl(lv As ListView)   Dim col2adjust As Long  'Size each column based on the maximum of
      'wither the ColumnHeader text width, or,
      'if the items below it are wider, the
      'widest list item in the column
       lv.Visible = False
       For col2adjust = 0 To lv.ColumnHeaders.Count - 1
       
          Call SendMessage(lv.hwnd, _
                           LVM_SETCOLUMNWIDTH, _
                           col2adjust, _
                           ByVal LVSCW_AUTOSIZE_USEHEADER)   Next
       lv.Visible = True
       
    End Sub
    Private Sub wmiDesktopMonitorInfo()   Dim dtmSet As SWbemObjectSet
       Dim dtm As SWbemObject
       Dim itmx As ListItem
       Dim msg As String
       
       Set dtmSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                              InstancesOf("Win32_DesktopMonitor")
          
       On Local Error Resume Next
       
       For Each dtm In dtmSet
       
          Set itmx = ListView1.ListItems.Add(, , dtm.DeviceID)
          
          itmx.SubItems(1) = dtm.Caption
          itmx.SubItems(2) = dtm.MonitorManufacturer
          itmx.SubItems(3) = dtm.Status
          
          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
          itmx.SubItems(4) = msg
       
       Next
       
    End Sub
      

  10.   

    系统插槽
    VERSION 5.00
    Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
    Begin VB.Form Form1 
       Caption         =   "Form1"
       ClientHeight    =   5640
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   10680
       LinkTopic       =   "Form1"
       ScaleHeight     =   5640
       ScaleWidth      =   10680
       StartUpPosition =   3  'Windows Default
       Begin VB.CommandButton Command1 
          Caption         =   "Command1"
          Height          =   375
          Left            =   4920
          TabIndex        =   1
          Top             =   5040
          Width           =   1455
       End
       Begin MSComctlLib.ListView ListView1 
          Height          =   4455
          Left            =   240
          TabIndex        =   0
          Top             =   240
          Width           =   10095
          _ExtentX        =   17806
          _ExtentY        =   7858
          LabelWrap       =   -1  'True
          HideSelection   =   -1  'True
          _Version        =   393217
          ForeColor       =   -2147483640
          BackColor       =   -2147483643
          BorderStyle     =   1
          Appearance      =   1
          NumItems        =   0
       End
    End
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copyright ?1996-2002 VBnet, Randy Birch, All Rights Reserved.
    ' Some pages may also contain other copyrights by the author.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Distribution: You can freely use this code in your own
    '               applications, but you can not publish
    '               or reproduce this code on any web site,
    '               on any online service, or distribute on
    '               any media without express permission.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Below used for listview column auto-resizing
    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1
    Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hwnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
    Private Sub Form_Load()   With ListView1
          .ListItems.Clear
          .ColumnHeaders.Clear
          .View = lvwReport
          .Sorted = False
       End With
       
       Command1.Caption = "SystemSlot Info"End Sub
    Private Sub Command1_Click()   ListView1.ListItems.Clear
       Call wmiSystemSlotInfo
       Call lvAutosizeControl(ListView1)
       
    End Sub
    Private Sub lvAutosizeControl(lv As ListView)   Dim col2adjust As Long  'Size each column based on the maximum of
      'either the ColumnHeader text width, or,
      'if the items below it are wider, the
      'widest list item in the column
       For col2adjust = 0 To lv.ColumnHeaders.Count - 1
       
          Call SendMessage(lv.hwnd, _
                           LVM_SETCOLUMNWIDTH, _
                           col2adjust, _
                           ByVal LVSCW_AUTOSIZE_USEHEADER)   Next
       
    End Sub
    Private Sub wmiSystemSlotInfo()   Dim wmiObjSet  As SWbemObjectSet
       Dim obj        As SWbemObject
       Dim thiscol    As Long
       Dim capcount   As Long
       Dim msg        As String
       Dim cnt        As Long
       Dim sflag      As String  'used in err trap
       Dim itmx       As ListItem   On Local Error GoTo systemslot_error
       
      'add first column and set initial parameters
       With ListView1
          .ListItems.Clear
          .View = lvwReport
          .Sorted = False
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "WMI Property"
          .ListItems.Add , , "Number"
          .ListItems.Add , , "Description"
          .ListItems.Add , , "Tag"
          .ListItems.Add , , "Status"
          .ListItems.Add , , "ConnectorPinout"
          .ListItems.Add , , "CurrentUsage"
          .ListItems.Add , , "MaxDataWidth"
          .ListItems.Add , , "PMESignal"
          .ListItems.Add , , "Shared"
          .ListItems.Add , , "SupportsHotPlug"
          .ListItems.Add , , "VccMixedVoltageSupport"
          .ListItems.Add , , "ConnectorType"   End With   Set wmiObjSet = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                                               InstancesOf("Win32_SystemSlot")
           
      'fill in respective columns for each object
       For Each obj In wmiObjSet
       
          With ListView1
             .ColumnHeaders.Add , , obj.SlotDesignation
             capcount = 0
             thiscol = (.ColumnHeaders.Count - 1)
             
             .ListItems(1).SubItems(thiscol) = IIf(obj.Number, obj.Number, "null")
             .ListItems(2).SubItems(thiscol) = obj.Description
             .ListItems(3).SubItems(thiscol) = obj.Tag
             .ListItems(4).SubItems(thiscol) = obj.Status
             .ListItems(5).SubItems(thiscol) = IIf(obj.ConnectorPinout, obj.ConnectorPinout, "null")
             
             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
             .ListItems(6).SubItems(thiscol) = msg
             
             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
             .ListItems(7).SubItems(thiscol) = msg
             
             .ListItems(8).SubItems(thiscol) = obj.PMESignal
             .ListItems(9).SubItems(thiscol) = obj.Shared
             .ListItems(10).SubItems(thiscol) = obj.SupportsHotPlug
             
             msg = ""
             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
             .ListItems(11).SubItems(thiscol) = msg
             
      

  11.   

    sflag = "ConnectorType"
             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
                
                 .ListItems(12 + capcount).SubItems(thiscol) = msg
       
             Next
             sflag = ""
             
          End With
          
       Next
       
    systemslot_exit:   On Local Error GoTo 0
       Exit Sub
       
    systemslot_error:   If Err.Number = 35600 And sflag = "ConnectorType" Then
          ListView1.ListItems.Add 12 + capcount, , ""
          Resume
       Else
          Resume Next
       End If
       
    End Sub
      

  12.   

    '**************为取网卡地址的API声明**************Private Const NCBASTAT = &H33
    Private Const NCBNAMSZ = 16
    Private Const HEAP_ZERO_MEMORY = &H8
    Private Const HEAP_GENERATE_EXCEPTIONS = &H4
    Private Const NCBRESET = &H32Private Type NCB
      ncb_command As Byte
      ncb_retcode As Byte
      ncb_lsn As Byte
      ncb_num As Byte
      ncb_buffer As Long
      ncb_length As Integer
      ncb_callname As String * NCBNAMSZ
      ncb_name As String * NCBNAMSZ
      ncb_rto As Byte
      ncb_sto As Byte
      ncb_post As Long
      ncb_lana_num As Byte
      ncb_cmd_cplt As Byte
      ncb_reserve(9) As Byte ' Reserved, must be 0
      ncb_event As Long
    End TypePrivate Type ADAPTER_STATUS
      adapter_address(5) As Byte
      rev_major As Byte
      reserved0 As Byte
      adapter_type As Byte
      rev_minor As Byte
      duration As Integer
      frmr_recv As Integer
      frmr_xmit As Integer
      iframe_recv_err As Integer
      xmit_aborts As Integer
      xmit_success As Long
      recv_success As Long
      iframe_xmit_err As Integer
      recv_buff_unavail As Integer
      t1_timeouts As Integer
      ti_timeouts As Integer
      Reserved1 As Long
      free_ncbs As Integer
      max_cfg_ncbs As Integer
      max_ncbs As Integer
      xmit_buf_unavail As Integer
      max_dgram_size As Integer
      pending_sess As Integer
      max_cfg_sess As Integer
      max_sess As Integer
      max_sess_pkt_size As Integer
      name_count As Integer
    End TypePrivate Type NAME_BUFFER
      name As String * NCBNAMSZ
      name_num As Integer
      name_flags As Integer
    End TypePrivate Type ASTAT
      adapt As ADAPTER_STATUS
      NameBuff(30) As NAME_BUFFER
    End TypePrivate Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) As Byte
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    Private Declare Function GetProcessHeap Lib "kernel32" () As Long
    Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long'**********************************
    '* 得到网卡地址
    '* EthernetAddress(0)
    '* 返回值:字符串
    '**********************************
    Public Function EthernetAddress(LanaNumber As Long) As String
      Dim udtNCB       As NCB
      Dim bytResponse  As Byte
      Dim udtASTAT     As ASTAT
      Dim udtTempASTAT As ASTAT
      Dim lngASTAT     As Long
      Dim strOut       As String
      Dim x            As Integer
      udtNCB.ncb_command = NCBRESET
      bytResponse = Netbios(udtNCB)
      udtNCB.ncb_command = NCBASTAT
      udtNCB.ncb_lana_num = LanaNumber
      udtNCB.ncb_callname = "* "
      udtNCB.ncb_length = Len(udtASTAT)
      lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
      strOut = ""
      If lngASTAT Then
        udtNCB.ncb_buffer = lngASTAT
        bytResponse = Netbios(udtNCB)
        CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
         With udtASTAT.adapt
          For x = 0 To 5
            strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
          Next x
        End With
        HeapFree GetProcessHeap(), 0, lngASTAT
      End If
      EthernetAddress = strOut
    End Function
    '得到IP地址
    '屏幕调用 LocalIPAddress()Option ExplicitPublic Const MAX_ADAPTER_NAME_LENGTH         As Long = 256
    Public Const MAX_ADAPTER_DESCRIPTION_LENGTH  As Long = 128
    Public Const MAX_ADAPTER_ADDRESS_LENGTH      As Long = 8
    Public Const ERROR_SUCCESS  As Long = 0Public Type IP_ADDRESS_STRING
        IpAddr(0 To 15)  As Byte
    End TypePublic Type IP_MASK_STRING
        IpMask(0 To 15)  As Byte
    End TypePublic Type IP_ADDR_STRING
        dwNext     As Long
        IpAddress  As IP_ADDRESS_STRING
        IpMask     As IP_MASK_STRING
        dwContext  As Long
    End TypePublic Type IP_ADAPTER_INFO
      dwNext                As Long
      ComboIndex            As Long  '保留
      sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))        As Byte
      sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
      dwAddressLength       As Long
      sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))       As Byte
      dwIndex               As Long
      uType                 As Long
      uDhcpEnabled          As Long
      CurrentIpAddress      As Long
      IpAddressList         As IP_ADDR_STRING
      GatewayList           As IP_ADDR_STRING
      DhcpServer            As IP_ADDR_STRING
      bHaveWins             As Long
      PrimaryWinsServer     As IP_ADDR_STRING
      SecondaryWinsServer   As IP_ADDR_STRING
      LeaseObtained         As Long
      LeaseExpires          As Long
    End TypePublic Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
      (pTcpTable As Any, _
       pdwSize As Long) As Long
       
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
      (dst As Any, _
       src As Any, _
       ByVal bcount As Long)
     Function LocalIPAddress() As String
       Dim cbRequired  As Long
       Dim buff()      As Byte
       Dim Adapter     As IP_ADAPTER_INFO
       Dim AdapterStr  As IP_ADDR_STRING
       Dim ptr1        As Long
       Dim sIPAddr     As String
       Dim found       As Boolean
       Call GetAdaptersInfo(ByVal 0&, cbRequired)
       If cbRequired > 0 Then
          ReDim buff(0 To cbRequired - 1) As Byte
          If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
            '获取存放在buff()中的数据的指针
             ptr1 = VarPtr(buff(0))
             Do While (ptr1 <> 0)
               '将第一个网卡的数据转换到IP_ADAPTER_INFO结构中
                CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
                With Adapter
                  'IpAddress.IpAddr成员给出了DHCP的IP地址
                   sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
                   If Len(sIPAddr) > 0 Then
                      found = True
                      Exit Do
                   End If
                   ptr1 = .dwNext
                End With  'With Adapter
            '不再有网卡时,ptr1的值为0
             Loop  'Do While (ptr1 <> 0)
          End If  'If GetAdaptersInfo
       End If  'If cbRequired > 0
      '返回结果字符串
       LocalIPAddress = sIPAddr
    End Function Function TrimNull(item As String)
        Dim pos As Integer
        pos = InStr(item, Chr$(0))
        If pos Then
              TrimNull = Left$(item, pos - 1)
        Else: TrimNull = item
        End If
    End Function
      

  13.   

    SWbemObjectSet对象的声明或定义还没有告诉我,我在其它地方也没有找到,jennyvenus兄,再帮帮我吧。
      

  14.   

    把相应的回复整个另存为*。FRM文件,包括文件头,或者把你的邮箱给我。