wmi.frm

VB获取计算机硬件信息VB获取计算机硬件信息VB获取计算机硬件信息VB获取计算机硬件信息

VERSION 5.00
Begin VB.Form Pcfrm 
   AutoRedraw      =   -1  'True
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "WMI PC Probe"
   ClientHeight    =   6525
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   9960
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6525
   ScaleWidth      =   9960
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton CMDSAVE 
      Caption         =   "&Save"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   345
      Left            =   8190
      TabIndex        =   2
      Top             =   6135
      Width           =   1710
   End
   Begin VB.CommandButton Cmrem 
      Caption         =   "&Get Remote PC"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   345
      Left            =   6330
      TabIndex        =   1
      Top             =   6135
      Width           =   1710
   End
   Begin VB.TextBox txdev 
      Height          =   6105
      Left            =   15
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   -15
      Width           =   9870
   End
End
Attribute VB_Name = "Pcfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Namespace As SWbemServices
Private Type DEVICE
 DEVICE As String
 PROPERTIES() As String
End Type
Private Type DEVICES
 DEVICEARRAY() As DEVICE
End Type
Dim dev As DEVICES
Private Function EnumDev(ByRef dev As DEVICES) As String
On Error GoTo errh
    Dim wb As SWbemObject, PROP As SWbemProperty, PropSet As SWbemPropertySet
    Dim st As String, J As Integer
    Dim DevCnt As Long, DevItem As Long
    Dim PropCnt As Long, PropItem As Long
    Dim wbs As SWbemObjectSet, name As String
    Dim ub As Long
    st = ""
   DevCnt = UBound(dev.DEVICEARRAY)
   For DevItem = 1 To DevCnt
    Set wbs = Namespace.InstancesOf("Win32_" + Replace(dev.DEVICEARRAY(DevItem).DEVICE, " ", ""))
    st = st + dev.DEVICEARRAY(DevItem).DEVICE + vbCrLf
    For Each wb In wbs
     st = st + Replace(Right(wb.Path_, Len(wb.Path_) - InStr(wb.Path_, "=")), Chr(34), "") + vbCrLf
     DoEvents
     Set PropSet = wb.Properties_
    PropCnt = UBound(dev.DEVICEARRAY(DevItem).PROPERTIES)
    For PropItem = 1 To PropCnt
     name = dev.DEVICEARRAY(DevItem).PROPERTIES(PropItem)
     Set PROP = PropSet.Item(Replace(name, " ", ""))
     With PROP
        If Not IsArray(.Value) Then
             st = st + "   " + name + ": " + CStr(IIf(IsNull(.Value) = True, " ", .Value)) + vbCrLf
        Else
          st = st + "   " + name + ": "
          ub = UBound(.Value)
         For J = 0 To ub
           st = st + CStr(IIf(IsNull(.Value(J)) = True, " ", .Value(J))) + IIf(J <> ub, ",", vbCrLf)
         Next
        End If
     End With
    Next PropItem
    st = st + vbCrLf
    Next wb
    st = st + vbCrLf
   Next DevItem
    EnumDev = st
Exit Function
errh:
 EnumDev = st + vbCrLf + "Error:" + Err.Description + "(" + CStr(Err.Number) + ")"
 Err.Clear
End Function

Private Sub CMDSAVE_Click()
Dim st() As String, fh As Integer, fn As String
fh = FreeFile()
st() = Split(Me.txdev.Text, vbCrLf, 3)
fn = Trim(st(1)) + ".txt"
Open fn For Binary Access Write As fh
 Put fh, , Me.txdev.Text
Close fh
MsgBox fn, vbInformation, "Information Saved in Following File:"
End Sub

Private Sub Cmrem_Click()
On Error GoTo errh:
Dim st As String
 st = Trim(InputBox("Enter PC Name", "Remote PC"))
 If Len(st) > 0 Then
   Set Namespace = GetObject("winmgmts://" + st + "/")
    Me.txdev.Text = EnumDev(GETDEVQUERY("COMPSYS.txt"))
 End If
 Exit Sub
errh:
MsgBox Err.Description + "(" + CStr(Err.Number) + ")", vbCritical, "Error"
Err.Clear
 Set Namespace = GetObject("winmgmts:")
  Me.txdev.Text = EnumDev(GETDEVQUERY("COMPSYS.txt"))
End Sub

Private Sub Form_Load()

 Set Namespace = GetObject("winmgmts:")
 Me.txdev.Text = EnumDev(GETDEVQUERY("COMPSYS.txt"))
End Sub
Private Sub Form_Unload(Cancel As Integer)
 Set Namespace = Nothing
End Sub

Private Function GETDEVQUERY(ByVal FILENAME As String) As DEVICES
Dim I As Long, J As Long, K As Long, DSTR As String, DEVNO As Long
 Dim TDEVARR() As String, PROP() As String, PROPNO As Long
 I = FreeFile()
 Open "COMPSYS.txt" For Binary Access Read As I
  DSTR = Space(LOF(I))
  Get I, , DSTR
 Close I
 TDEVARR = Split(DSTR, "#")
 DEVNO = UBound(TDEVARR)
With GETDEVQUERY
 ReDim .DEVICEARRAY(DEVNO)
 For I = 1 To DEVNO
  PROP = Split(TDEVARR(I), vbCrLf)
 With .DEVICEARRAY(I)
  .DEVICE = PROP(0)
  PROPNO = UBound(PROP) - 1
  If PROPNO >= 1 Then
   ReDim .PROPERTIES(PROPNO)
   For J = 1 To PROPNO
     .PROPERTIES(J) = PROP(J)
   Next J
  End If
 End With
 Next I
End With
End Function