亲宝软件园·资讯

展开

收集硬件信息vbs-远程检测V3.1版 用vbs实现获取电脑硬件信息的脚本_最新版

人气:0
想了解用vbs实现获取电脑硬件信息的脚本_最新版的相关内容吗,在本文为您仔细讲解收集硬件信息vbs-远程检测V3.1版的相关知识和一些Code实例,欢迎阅读和指正,我们先划重点:收集,硬件信息,vbs,下面大家一起来学习吧。

代码一:

'******************************************************************************************* 
 'Version:3.1 
 '   调整错误处理方法,错误信息输出到LogFile文件,可以查看扫描失败原因 
 '     如果出现“RPC 服务器不可用”错误,是因为远程主机没开机 
 '     如果出现“RPC 服务器不可用”之外的错误,可能是由于正在运行的程序造成,请你把此信息告诉我 
 '     重启后再次扫描就可以排除非“RPC 服务器不可用。”的错误 
 '     如果扫描到的硬件信息为空,应该是驱动问题(或BIOS不完善),请自行解决 
 'Version:3.0 
 '   增加输出BIOS的发行日期,和主板信息放在一起 
 'Version:2.9 
 '   修正所有GetInfo过程遇错的处理方法,避免返回的数组上限不符合输出要求导致脚本报错。 
 '     之所以为出现这种情况,是因为Win32类检索不到硬件或连接到Win32类失败; 
 '     原来判断是否出现Err,忽略了检索不到硬件的情况(连接成功无Err,Count为0) 
 '     检索不到硬件多数是因为驱动没装好 
 'Version:2.8 
 '   增加GetIDEProtocol过程,获取IDE控制器使用的协议,只是增加了代码,没有调用 
 '   计划增加检索其它存储器控制器的过程 
 'Version:2.7 
 '   检索硬盘/显卡/网卡/声卡的过程增加 DeviceID 属性(设备标识符) 
 '     此属性不被输出,用于脚本内部判断 
 'Version:2.6 
 '   原来输出搜索到的第一个硬盘 
 '   改为输出搜索到的第一个InterfaceType属性为IDE的硬盘的信息 
 'Version:2.5 
 '   增加Sort过程,排序硬件信息 
 'Version:2.4 
 '   调整输出信息的分类,同类信息尽可能的只使用一个逗号分隔,以便导入xls后在同一列 
 '   查询到的硬件信息如果是空或0,有可能是相关驱动不完善或未定义此信息,也可能是未安装驱动 
 '   因为WMI查询就代表了系统知道这些硬件的详细信息,查不到信息就是系统不知道 
 '   系统不知道硬件的详细信息,代表着性能可能有所缺失,建议找个好驱动安装 
 '   值得注意的是主板驱动 
 '   (为了更容易理解,此版本的升级信息被编辑过) 
 'Version:2.3 
 '   取消2.2版增加输出的硬盘接口类型 
 '     由于STAT也归于IDE接口,这会导致误解 
 '     PS:脚本只输出搜索到的第一个硬盘 
 'Version:2.2 
 '   GetMemoryInfo过程增加MemoryType、FormFactor、TypeDetail三个属性 
 '     输出增加内存类型、封装类型 
 '     输出增加硬盘容量、接口类型 
 'Version:2.1 
 '   GetOSInfo过程增加去掉Caption属性中带有的逗号“,”的代码 
 '     原因:在检测2003系统时,读取到的Caption属性,带有逗号“,” 
 '     这会影响输出,因为输出是以逗号“,”为分隔符的 
 'Version:2.0 B5发布版 
 '   GetNetworkInfo过程改为使用MACAddress属性非空、 
 '     Manufacturer属性非"Microsoft"判断网卡 
 'Version:2.0 Beta4 
 '   GetNetworkInfo过程使用NetConnectionStatus属性判断网络适配器 
 '     NetConnectionStatus属性表明连接状态(2000系统不支持此属性) 
 '     物理网络适配器才具有此状态(包括停用状态在内) 
 'Version:2.0 Beta3 
 '   GetNetworkInfo过程增加一个判断 
 '     忽略读取IPAddress(0)时会产生Err类型数据的适配器(对战平台) 
 'Version:2.0 Beta2 
 '   GetOSInfo过程原来使用的Name、ServicePackMajorVersion属性 
 '     改为使用Caption、CSDVersion属性 
 '   所有GetInfo过程增加错误处理代码,避免正在扫描的时候 
 '     脚本遇到运行时错误导致脚本退出 
 'Version:2.0 Beta1 
 '   增加扫描失败记录,再次运行脚本只读取失败记录,忽略配置信息 
 'Version:1.1 
 '   GetNetworkInfo过程增加一个判断 
 '     忽略NetConnectionID属性(接口名称)为空的适配器 
 'Version:1.0 
 '   初始版本 

 Option Explicit 
 '************************************** 
 '作 者: LZ-MyST QQ:8450919 
 'http://hi.baidu.com/lzmyst 
 'http://www.clxp.net.cn 
 'E-Mail:lzmyst@163.com 
 '你可以任意编辑、引用脚本的全部或部分代码 
 '转贴、引用脚本的全部或部分代码请保留版权 
 '************************************** 
  
 '********************************说明开始************************************* 
 'Input格式:起始IP-数量=用户名=密码;起始计算机名-数量=用户名=密码 
 '       多个配置项用“;”隔开 
 '例:192.168.0.1-10指明IP范围为192.168.0.1~192.168.0.10,支持跨网段 
 '例:PC001-10指明范围为PC001~PC010(计算机名可以包含-号) 
 '与指定格式不相同的,默认为单IP[计算机名],也可以在"未扫描的计算机.txt"里配置 
 '"硬件信息.txt"是以逗号分隔各项硬件信息,你需要自己导入XLS整理、精简 
 '未扫描到的计算机,会把机号、用户名、密码保存到"未扫描的计算机.txt" 
 '再次运行脚本将只读取"未扫描的计算机.txt"里的信息(如果存在并且大小不为0) 
 '********************************说明结束************************************* 
  
 Dim Input, InfoOutFile, LogFile '请按格式给Input赋值 
 'Input = "pc021=administrator=cylslynetbar" 
 Input = "PC001-109=administrator=cylslynetbar;pc110-85=administrator=LYjfnetbaradmin" 
 InfoOutFile = "硬件信息.txt" 
 LogFile = "未扫描的计算机.txt" 
  
 Redim arrConfig(0) 
 Dim WshShell, FSO, intCount1, intCount2 
 intCount1 = 0 
 intCount2 = 0 
 Set WshShell = WScript.CreateObject("WScript.Shell") 
 Set FSO = WScript.Createobject("Scripting.Filesystemobject") 
 ReadConfig 
 WshShell.Popup "扫描过程会很慢,请耐心等待,完成后会给出提示",,"扫描开始" 
 LinkRemoteServer arrConfig 
 Dim LenNum1, LenNum2 
 If intCount1 > intCount2 Then 
  LenNum1 = 0 
  LenNum2 = Len(intCount1) - Len(intCount2) 
 Else 
  LenNum1 = Len(intCount2) - Len(intCount1) 
  LenNum2 = 0 
 End If 
 Sort InfoOutFile 
 WshShell.Popup "扫描结果:" & _ 
         vbCrLf & vbTab & "扫描成功:" & Space(LenNum1) & intCount1 & " 台" & _ 
         vbCrLf & vbTab & "扫描失败:" & Space(LenNum2) & intCount2 & " 台" & _ 
         vbCrLf & "扫描失败的电脑已做记录,再次运行脚本只扫描记录里的电脑",,"扫描完成" 
  
Function ReadConfig 
 Dim objMatches, objMatche,objLogFile, arrLog, intUBarrConfig 
 If FSO.FileExists(LogFile) Then 
  If FSO.GetFile(LogFile).Size = 0 Then 
   Set objMatches = GetMatche("([^;=]+)=([^;=]+)=([^;=]+)", Input) 
   For Each objMatche In objMatches 
    GetConfig objMatche.SubMatches(0), objMatche.SubMatches(1), objMatche.SubMatches(2) 
   Next 
   If objMatches.Count = 0 Then 
    Msgbox "配置信息格式不正确,请修改" 
    WScript.Quit 
   End If 
  Else 
   Set objLogFile = FSO.OpenTextFile(LogFile) 
   Do Until objLogFile.AtEndOfStream 
    arrLog = Split(objLogFile.ReadLine,"=") 
    intUBarrConfig = ((Ubound(arrConfig)+1)\3+1)*3-1 
    Redim Preserve arrConfig(intUBarrConfig) 
    arrConfig(intUBarrConfig-2) = arrLog(0) 
    arrConfig(intUBarrConfig-1) = arrLog(1) 
    arrConfig(intUBarrConfig-0) = arrLog(2) 
   Loop 
  End If 
 Else 
  Set objMatches = GetMatche("([^;=]+)=([^;=]+)=([^;=]+)", Input) 
  For Each objMatche In objMatches 
   GetConfig objMatche.SubMatches(0), objMatche.SubMatches(1), objMatche.SubMatches(2) 
  Next 
  If objMatches.Count = 0 Then 
   Msgbox "配置信息格式不正确,请修改" 
   WScript.Quit 
  End If 
 End If 
End Function 


'********************************************************************************* 
'目的:连接到远程主机的WMI命名空间 
'输入:arrArray数组,包含有计算机名[IP]、用户名、密码 
'调用:LinkServer过程 
'    如果返回SWbemLocator对象ConnectServer方法的实例,调用OutInfo过程 
'    如果返回Err信息(字符串类型),输出计算机名[IP]、用户名、密码及错误信息到LogFile文件 
'   OutInfo过程 
'    如果返回Err信息(字符串类型)输出计算机名[IP]、用户名、密码及错误信息到LogFile文件 
'传递:SWbemLocator对象ConnectServer方法的实例传递给OutInfo过程 
'   计算机名[IP]、命名空间、用户名、密码传递给LinkServer过程 
'********************************************************************************* 
Function LinkRemoteServer(arrArray) 
 Dim objErrLog, E, objLinkServer, objConnection, objWbemLocator, objErr 
 Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator") 
 Set objErrLog = FSO.CreateTextFile(LogFile,True) 
 For E = 0 To Ubound(arrArray) Step 3 
  Set objLinkServer = LinkServer(arrConfig(E),"root\cimv2",arrConfig(E+1),arrConfig(E+2)) 
  If Err Then 
   objErrLog.Writeline arrArray(E) & "=" & arrArray(E+1) & "=" & arrArray(E+2) & "=" & _ 
             "错误编号:" & CStr(Err.Number) & _ 
             ",错误原因:" & CStr(Err.Description) & _ 
             ",错误来源:" & CStr(Err.Source) & " By LinkServer Function" 
   intCount2 = intCount2 + 1 
   Err.Clear 
  Else 
   objErr = OutInfo(objLinkServer) 
   If Vartype(objErr) = 8 Then 
    objErrLog.Writeline arrArray(E) & "=" & arrArray(E+1) & "=" & arrArray(E+2) & "=" & objErr 
    intCount2 = intCount2 + 1 
   End If 
  End If 
 Next 
End Function 

'****************************************************** 
'目的:输出硬件信息 
'输入:SWbemLocator对象ConnectServer方法的实例 
'调用:获取硬件信息的GetXXXInfo过程 
'传递:SWbemLocator对象ConnectServer方法的实例 
'返回:所有调用的GetInfo过程都未返回Err对象,则返回True 
'   某个GetInfo过程返回Err对象,则返回False 
'****************************************************** 
Function OutInfo(objRemote) 
 Dim OutFile, arrInfo, strOutInfo, Tmp, A 
 If FSO.FileExists(InfoOutFile) Then 
  Set OutFile = FSO.OpenTextFile(InfoOutFile,8) 
 Else 
  Set OutFile = FSO.CreateTextFile(InfoOutFile) 
  OutFile.Writeline "计算机名,系统(初装日期),主板型号(厂商)(发行日期),CPU型号(接口类型),外频,L2容量(速度)," & _ 
           "内存总量,内存速度(位置),内存类型(封装类型),硬盘型号(容量),显卡型号(显存),网卡,IP/MAC" 
 End If 
 '系统 
 arrInfo = GetOSInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 strOutInfo = arrInfo(0) & "," & arrInfo(1) & "(" & arrInfo(2) & ")," 
 '主板 
 arrInfo = GetBoardInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 strOutInfo = strOutInfo & arrInfo(0) & "(" & arrInfo(1) & ")" 
 'BIOS 
 arrInfo = GetBIOSInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 strOutInfo = strOutInfo & "(" & arrInfo(2) & ")," 
 'CPU 
 arrInfo = GetCPUInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 strOutInfo = strOutInfo & arrInfo(1) & "(" & arrInfo(8) & ")," & arrInfo(4) & "," & _ 
        arrInfo(6) & "(" & arrInfo(7) & ")," 
 '内存 
 arrInfo = GetMemoryInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 Tmp = 0 
 For A = 1 To Ubound(arrInfo) Step 6 
  Tmp = Tmp + Cint(arrInfo(A)) 
 Next 
 strOutInfo = strOutInfo & arrInfo(0) & "条,共" & Tmp & "M," 
 Tmp = "" 
 For A = 2 To Ubound(arrInfo) Step 6 
  If A = Ubound(arrInfo) - 4 Then 
   Tmp = Tmp & arrInfo(A) & "(" & arrInfo(A+1) & ")," 
  Else 
   Tmp = Tmp & arrInfo(A) & "(" & arrInfo(A+1) & ") " 
  End If 
 Next 
 strOutInfo = strOutInfo & Tmp 
 Tmp = "" 
 For A = 4 To Ubound(arrInfo) Step 6 
  If A = Ubound(arrInfo) - 2 Then 
   Tmp = Tmp & arrInfo(A) & "(" & arrInfo(A+1) & ")," 
  Else 
   Tmp = Tmp & arrInfo(A) & "(" & arrInfo(A+1) & ") " 
  End If 
 Next 
 strOutInfo = strOutInfo & Tmp 
 '硬盘 
 Tmp = "" 
 arrInfo = GetDiskInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 For A = 1 To Ubound(arrInfo) Step 5 
  If arrInfo(A+1) = "IDE" Then 
   Tmp = arrInfo(A) & "(" & arrInfo(A+2) & "G)," 
   Exit For 
  End If 
 Next 
 If Tmp = "" Then 
  strOutInfo = strOutInfo & "硬盘型号未检索到," 
 Else 
  strOutInfo = strOutInfo & Tmp 
 End If 
 '显卡 
 arrInfo = GetVideoInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 strOutInfo = strOutInfo & arrInfo(0) & "(" & arrInfo(1) & "M)," 
 '网卡 
 arrInfo = GetNetworkInfo(objRemote) 
 If Vartype(arrInfo) = 8 Then 
  OutInfo = arrInfo 
  Exit Function 
 End If 
 strOutInfo = strOutInfo & arrInfo(1) & "," & arrInfo(2) & Space(17-Len(arrInfo(2))) & arrInfo(3) 
 '输出 
 OutFile.Writeline strOutInfo 
 intCount1 = intCount1 + 1 
 OutInfo = True 
End Function 

'********************************************************* 
'目的:连接到远程主机的WMI命名空间 
'输入:strComputer:远程主机的计算机名或IP 
'   strNamespace:命令空间 
'   strUserName:用户名 
'   strPassword:密码 
'返回:连接成功,返回SWbemLocator类连接远程主机后的对象的实例 
'   连接失败,返回错误对象 
'********************************************************* 
Function LinkServer(strComputer,strNamespace,strUserName,strPassword) 
 Dim objWbemLocator 
 Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator") 
 Dim objConnection 
 On Error Resume Next 
 Set objConnection = objwbemLocator.ConnectServer _ 
           (strComputer, strNamespace, strUserName, strPassword) 
 If Err Then 
   Set LinkServer = Err 
   Exit Function 
 End If 
 On Error Goto 0 
 objConnection.Security_.ImpersonationLevel = 3 
 Set LinkServer = objConnection 
End Function 

'****************************************** 
'目的:正则表达式 
'输入:strPatrn:正则表达式模式 
'   strString:要执行正则表达式的字符串 
'返回:Match对象 
'****************************************** 
Function GetMatche(strPatrn, strString) 
 Dim RegEx 
 Set RegEx = New Regexp 
 RegEx.Global = True 
 RegEx.IgnoreCase =True 
 RegEx.Pattern = strPatrn 
 Set GetMatche = RegEx.Execute(strString) 
End Function 

'*************************************** 
'目的:2、8、16进制转10进制 
'输入:strString:2、8、16进制数 
'   intNum:进制(2|8|16) 
'返回:10进制数 
'*************************************** 
Function ChangeToDecimal(strString, intNum) 
 ChangeToDecimal = 0 
 If Isnull(strString) Then ChangeToDecimal = 0 : Exit Function 
 Dim A, M 
 For A = 1 To Len(strString) 
  M = LCase(Mid(strString, A, 1)) 
  Select Case M 
   Case "a" :M = 10 
   Case "b" :M = 11 
   Case "c" :M = 12 
   Case "d" :M = 13 
   Case "e" :M = 14 
   Case "f" :M = 15 
  End Select 
  ChangeToDecimal = ChangeToDecimal + M * intNum^(Len(strString)-A) 
 Next 
End Function 

'******************************************************* 
'目的:分析配置信息 
'输入:strIP, strUser, strPW:IP[计算机名]、账户、密码 
'返回:无,直接把分析结果保存在数组 
'******************************************************* 
Function GetConfig(strIP, strUser, strPW) 
 Dim Matches, SubMatche 
 Dim IP_1, IP_2, IP_3, IP_4, intStar, intEnd, A, intConfigNum 
 Dim IP_Patrn 
 IP_Patrn = "([\d]+)\.([\d]+)\.([\d]+)\.([\d]+)-([\d]+)" 
 Set Matches = GetMatche(IP_Patrn, strIP) 
 If Matches.Count = 1 Then 
  Set SubMatche = Matches(0) 
  intStar = Cint(SubMatche.SubMatches(3)) 
  intEnd = intStar + Cint(SubMatche.SubMatches(4)) - 1 
  For A = intStar To intEnd 
   IP_4 = A Mod 256 
   IP_3 = (Cint(SubMatche.SubMatches(2))+ A\256) Mod 256 
   IP_2 = (Cint(SubMatche.SubMatches(1)) + (Cint(SubMatche.SubMatches(2))+ A\256)\256) Mod 256 
   IP_1 = Cint(SubMatche.SubMatches(0)) + (Cint(SubMatche.SubMatches(1)) + _ 
       (Cint(SubMatche.SubMatches(2))+ A\256)\256)\256 
   If IP_1 > 223 Or IP_1 = 127 Or IP_1 < 1 Then 
    Msgbox strIP & "包含的" & IP_1 & "." & IP_2 & "." & IP_3 & "." & IP_4 & _ 
        "不是有效IP,此IP及之后的IP已被丢弃" 
    Exit Function 
   End If 
   intConfigNum = (Ubound(arrConfig)+1)\3 + 1 
   Redim Preserve arrConfig(intConfigNum*3-1) 
   arrConfig(intConfigNum*3-3) = IP_1 & "." & IP_2 & "." & IP_3 & "." & IP_4 
   arrConfig(intConfigNum*3-2) = strUser 
   arrConfig(intConfigNum*3-1) = strPW 
  Next 
  Exit Function 
 End If 
 Dim ComputerName_Patrn, Prefix, intLen 
 ComputerName_Patrn = "([\S]+[^0-9]{1})([0]*[\d]+)-([\d]+)" 
 Set Matches = GetMatche(ComputerName_Patrn, strIP) 
 If Matches.Count = 1 Then 
  Set SubMatche = Matches(0) 
  Prefix = SubMatche.SubMatches(0) 
  intLen = Len(SubMatche.SubMatches(1)) 
  intStar = Cint(SubMatche.SubMatches(1)) 
  intEnd = intStar + Cint(SubMatche.SubMatches(2)) - 1 
  For A = intStar To intEnd 
   intConfigNum = (Ubound(arrConfig)+1)\3 + 1 
   Redim Preserve arrConfig(intConfigNum*3-1) 
   If Len(A) < intLen Then 
    arrConfig(intConfigNum*3-3) = Prefix & String(intLen-Len(A),"0") & A 
   Else 
    arrConfig(intConfigNum*3-3) = Prefix & A 
   End If 
   arrConfig(intConfigNum*3-2) = strUser 
   arrConfig(intConfigNum*3-1) = strPW 
  Next 
  Exit Function 
 End If 
 intConfigNum = (Ubound(arrConfig)+1)\3 + 1 
 Redim Preserve arrConfig(intConfigNum*3-1) 
 arrConfig(intConfigNum*3-3) = strIP 
 arrConfig(intConfigNum*3-2) = strUser 
 arrConfig(intConfigNum*3-1) = strPW 
End Function 

'*********************************************************** 
'目的:获取操作系统信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为2 
'    取操作系统的3种属性: 
'  0     1         2 
'  CSName  Caption&CSDVersion  InstallDate 
'  计算机名  系统名&SP版本   初装日期 
'LastBootUpTime属性表示系统最近一次的启动时间 
'*********************************************************** 
Function GetOSInfo(objConnection) 
 Dim arrOSInfo 
 Dim objSystemInfos, objSystemInfo, arrOS(2) 
 Dim Tmp 
 On Error Resume Next 
 Set objSystemInfos = objConnection.InstancesOf("win32_operatingsystem") 
 If Err Then 
  GetOSInfo = "错误编号:" & CStr(Err.Number) & _ 
        ",错误原因:" & CStr(Err.Description) & _ 
        ",错误来源:" & CStr(Err.Source) & " By GetOSInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objSystemInfos.Count 
 If Err Then 
  GetOSInfo = "错误编号:" & CStr(Err.Number) & _ 
        ",错误原因:" & CStr(Err.Description) & _ 
        ",错误来源:" & CStr(Err.Source) & " By GetOSInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For Each objSystemInfo In objSystemInfos 
   arrOS(0) = objSystemInfo.CSName 
   arrOS(1) = Replace(objSystemInfo.Caption,",","") & " " & objSystemInfo.CSDVersion 
   arrOS(2) = Mid(CStr(objSystemInfo.InstallDate),1,4) & "-" & _ 
         Mid(CStr(objSystemInfo.InstallDate),5,2) & "-" & _ 
         Mid(CStr(objSystemInfo.InstallDate),7,2) '& ", " & _ 
         'Mid(CStr(objSystemInfo.InstallDate),9,2) & ":" & _ 
         'Mid(CStr(objSystemInfo.InstallDate),11,2) & ":" & _ 
         'Mid(CStr(objSystemInfo.InstallDate),13,2) 
 Next 
 If Err Then 
  GetOSInfo = "错误编号:" & CStr(Err.Number) & _ 
        ",错误原因:" & CStr(Err.Description) & _ 
        ",错误来源:" & CStr(Err.Source) & " By GetOSInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 GetOSInfo = arrOS 
 On Error Goto 0 
End Function 

'*********************************************************** 
'目的:获取主板信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为2 
'    取主板的3种属性: 
'  0     1       2 
'  Product  Manufacturer  Version 
'  型号   厂商      版本 
'*********************************************************** 
Function GetBoardInfo(objConnection) 
 Dim objboards, objboard, arrBoard(2) 
 Dim Tmp 
 On Error Resume Next 
 Set objboards = objConnection.InstancesOf("Win32_BaseBoard") 
 If Err Then 
  GetBoardInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetBoardInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objboards.Count 
 If Err Then 
  GetBoardInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetBoardInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For each objboard In objboards 
  arrBoard(0) = Replace(Trim(objboard.Product),",","") '型号 
  arrBoard(1) = Replace(Trim(objboard.Manufacturer),",","") '厂商 
  arrBoard(2) = Replace(Trim(objboard.Version),",","") '版本 
 Next 
 If Err Then 
  GetBoardInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetBoardInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 GetBoardInfo = arrBoard 
 On Error Goto 0 
End Function 

'*********************************************************** 
'目的:获取BIOS信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为2 
'    取BIOS的2种属性: 
'  0       1         2 
'  Manufacturer  SMBIOSBIOSVersion ReleaseDate 
'  厂商      版本        发行日期 
'*********************************************************** 
Function GetBIOSInfo(objConnection) 
 Dim objBIOSs, objBIOS, arrBIOS(2) 
 Dim Tmp 
 On Error Resume Next 
 Set objBIOSs = objConnection.InstancesOf("Win32_BIOS") 
 If Err Then 
  GetBIOSInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetBIOSInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objBIOSs.Count 
 If Err Then 
  GetBIOSInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetBIOSInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For each objBIOS In objBIOSs 
   If Isnull(objBIOS.Manufacturer) Then 
    arrBIOS(0) = "BIOS厂商不存在" '请检查主板驱动是否完善或未安装,或BIOS不完善需要刷BIOS 
   Else 
    arrBIOS(0) = Replace(Trim(objBIOS.Manufacturer),",","") 
   End If 
   If Isnull(objBIOS.SMBIOSBIOSVersion) Then 
    arrBIOS(1) = "由SMBIOS汇报的BIOS版本不存在" '请检查主板驱动是否完善或未安装,或BIOS不完善需要刷BIOS 
   Else 
    arrBIOS(1) = Replace(Trim(objBIOS.SMBIOSBIOSVersion),",","") 
   End If 
   If Isnull(objBIOS.ReleaseDate) Then 
    arrBIOS(2) = "BIOS发行日期未知" '请检查主板驱动是否完善或未安装,或BIOS不完善需要刷BIOS 
   Else 
    arrBIOS(2) = Left(Cstr(objBIOS.ReleaseDate),8) 
   End If 
 Next 
 If Err Then 
  GetBIOSInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetBIOSInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 GetBIOSInfo = arrBIOS 
 On Error Goto 0 
End Function 

'************************************************************ 
'目的:获取CPU信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为8 
'    取CPU的9种属性: 
'  0     1   2       3        4 
'       Name MaxClockSpeed CurrentVoltage  ExtClock 
' 核心数量  型号 主频      电压       外频   
' 5       6      7       8 
' AddressWidth L2CacheSize L2CacheSpeed SocketDesignation 
' 位宽     L2容量    L2频率    插槽类型 
'************************************************************ 
Function GetCPUInfo(objConnection) 
 Dim objCPU, objCPUs, arrCPU(8) 
 On Error Resume Next 
 Set objCPUs = objConnection.InstancesOf("win32_processor") 
 If Err Then 
  GetCPUInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetCPUInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 arrCPU(0) = objCPUs.Count '每个CPU核心都返回一个实例,实例数量即为CPU核心数量 
 If Err Then 
  GetCPUInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetCPUInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For each objCPU In objCPUs 
  arrCPU(1) = Replace(Trim(objCPU.Name),",","") '型号 
  arrCPU(2) = objCPU.MaxClockSpeed '主频 
  arrCPU(3) = ChangeToDecimal(objCPU.CurrentVoltage, 16)/10 '电压 
  arrCPU(4) = objCPU.ExtClock '外频 
  arrCPU(5) = objCPU.AddressWidth '位宽 
  arrCPU(6) = objCPU.L2CacheSize 'L2容量 
  arrCPU(7) = objCPU.L2CacheSpeed 'L2频率 
  arrCPU(8) = objCPU.SocketDesignation '插槽类型 
 Next 
 If Err Then 
  GetCPUInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetCPUInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 GetCPUInfo = arrCPU 
 On Error Goto 0 
End Function 

'******************************************************************************************** 
'目的:获取内存信息 
'输入:SWbemLocator对象的ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为(内存条的数量*6),0=内存条的数量 
'    取内存的6种属性: 
'    1     2   3       4      5        6 
'    capacity Speed DeviceLocator MemoryType FormFactor   TypeDetail 
'    容量   速度  插槽位置    内存类型   封装(接口)类型  详细类型-系统应用类型 
'DeviceLocator属性表示这个内存所在的插槽 
'         一般是字符加数字,数字相当于主板上内存插槽的物理位置 
'******************************************************************************************** 
Function GetMemoryInfo(objConnection) 
 Dim objMemorys, objMemory, Num 
 Redim arrMemory(0) 
 On Error Resume Next 
 Set objMemorys = objConnection.InstancesOf("Win32_PhysicalMemory") 
 If Err Then 
  GetMemoryInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetMemoryInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 arrMemory(0) = objMemorys.Count '每条内存都返回一个实例,实例项数即内存条数量 
 If Err Then 
  GetMemoryInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetMemoryInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Num = 0 
 For Each objMemory In objMemorys 
  Num = Num + 1 
  Redim Preserve arrMemory(Num*6) 
  arrMemory(Num*6-5) = objMemory.capacity/1048576 '容量(M) 
  arrMemory(Num*6-4) = objMemory.Speed '速度(MHz) 
  arrMemory(Num*6-3) = objMemory.DeviceLocator '插槽位置 
  Select Case objMemory.MemoryType '内存类型, 
   Case 0 :arrMemory(Num*6-2) = "Unknown" '未知 
   Case 1 :arrMemory(Num*6-2) = "Other" '其它 
   Case 2 :arrMemory(Num*6-2) = "DRAM" '动态随机存储器 
   Case 3 :arrMemory(Num*6-2) = "Synchronous DRAM" '同步动态随机存储器 
   Case 4 :arrMemory(Num*6-2) = "Cache DRAM" '同步缓存动态随机存储器,三菱专利技术,插入一个SRAM作为二级CACHE使用 
   Case 5 :arrMemory(Num*6-2) = "EDO" '外扩充数据模式存储器(Extended Date Out) 
   Case 6 :arrMemory(Num*6-2) = "EDRAM" '增强型动态随机存储器,在DRAM中包括了一小部分的SRAM(Enhanced DRAM) 
   Case 7 :arrMemory(Num*6-2) = "VRAM" '视频存储器,专门为图形应用优化的存储器(Video DRAM) 
   Case 8 :arrMemory(Num*6-2) = "SRAM" '静态随机存储器 
   Case 9 :arrMemory(Num*6-2) = "RAM" '随机存储器 
   Case 10 :arrMemory(Num*6-2) = "ROM" '只读存储器 
   Case 11 :arrMemory(Num*6-2) = "Flash" '闪速存储器,简称闪存(Flash Memory),属于EEPROM(电擦除可编程只读存储器)类型 
   Case 12 :arrMemory(Num*6-2) = "EEPROM" '电可擦写可编程只读存储器 
   Case 13 :arrMemory(Num*6-2) = "FEPROM" 'F什么可擦写可编程只读存储器 
   Case 14 :arrMemory(Num*6-2) = "EPROM" '可擦写可编程只读存储器(Erasable Programmable ROM) 
   Case 15 :arrMemory(Num*6-2) = "CDRAM" '同步缓存动态随机存储器,即Cache DRAM 
   Case 16 :arrMemory(Num*6-2) = "3DRAM" '3维视频处理器专用存储器(3 DIMESION RAM) 
   Case 17 :arrMemory(Num*6-2) = "SDRAM" '同步动态随机存储器,即Synchronous DRAM 
   Case 18 :arrMemory(Num*6-2) = "SGRAM" '单口随机存储器(Signal RAM) 
   Case 19 :arrMemory(Num*6-2) = "RDRAM" '总线式动态随机存储器 
   Case 20 :arrMemory(Num*6-2) = "DDR" '双倍速率同步动态随机存储器,一个时钟周期内传输二次数据 
   Case 21 :arrMemory(Num*6-2) = "DDR-2" '双倍速率同步动态随机存储器2,一个时钟周期内传输二次数据,4bit数据预读取能力 
  End Select 
  Select Case objMemory.FormFactor '封装类型(接口类型) 
   Case 0 :arrMemory(Num*6-1) = "Unknown" '未知 
   Case 1 :arrMemory(Num*6-1) = "Other" '其它 
   Case 2 :arrMemory(Num*6-1) = "SIP" '单列直插式封装 
   Case 3 :arrMemory(Num*6-1) = "DIP" '双列直插式封装(Dual ln-line Package) 
   Case 4 :arrMemory(Num*6-1) = "ZIP" '零插拔力封装(Zero Insertion Package) 
   Case 5 :arrMemory(Num*6-1) = "SOJ" '小尺寸(小外形)J形引脚封装(Small Out-Line J-Lead) 
   Case 6 :arrMemory(Num*6-1) = "Proprietary" '专有封装(有专利权的) 
   Case 7 :arrMemory(Num*6-1) = "SIMM" '单列直插式封装(Single Inline Memory Module) 
   Case 8 :arrMemory(Num*6-1) = "DIMM" '双列直插式封装(Dual Inline Memory Module) 
   Case 9 :arrMemory(Num*6-1) = "TSOP" '薄型小尺寸封装(Thin Small Outline Package) 
   Case 10 :arrMemory(Num*6-1) = "PGA" '陈列引脚封装。底面的垂直引脚呈陈列状排列。用于高速大规模逻辑LSI电路。 
   Case 11 :arrMemory(Num*6-1) = "RIMM" '总线式封装,RIMM是Rambus公司生产的RDRAM内存所采用的接口类型 
   Case 12 :arrMemory(Num*6-1) = "SODIMM" '小尺寸双列直插式封装(Small Outline DIMM Module) 
   Case 13 :arrMemory(Num*6-1) = "SRIMM" '小尺寸总线式封装 
   Case 14 :arrMemory(Num*6-1) = "SMD" '表面贴装型封装(Surface Mounted Devices),也叫贴片封装 
   Case 15 :arrMemory(Num*6-1) = "SSMP" '未搜到此类型的信息,谁知道的请告诉偶,谢谢 
   Case 16 :arrMemory(Num*6-1) = "QFP" '方型扁平封装(Quad Flat Package) 
   Case 17 :arrMemory(Num*6-1) = "TQFP" '薄方型扁平封装 
   Case 18 :arrMemory(Num*6-1) = "SOIC" '小尺寸集成电路封装,SOP(Small Outline Package,小外形封装)之一 
   Case 19 :arrMemory(Num*6-1) = "LCC" '无引脚封装,指只有电极接触而无引脚的表面贴装型封装 
   Case 20 :arrMemory(Num*6-1) = "PLCC" '塑封J形引脚封装 
   Case 21 :arrMemory(Num*6-1) = "BGA" '球栅阵列封装,在背面按陈列方式制作出球形凸点代替引脚 
   Case 22 :arrMemory(Num*6-1) = "FPBGA" '方型扁平球栅阵列封装 
   Case 23 :arrMemory(Num*6-1) = "LGA" '触点陈列封装。 
  End Select 
  Select Case objMemory.TypeDetail '详细类型(系统用于那方面的应用) 
   Case 1 :arrMemory(Num*6) = "Reserved" '预留 
   Case 2 :arrMemory(Num*6) = "Other" '其它 
   Case 4 :arrMemory(Num*6) = "Unknown" '未知 
   Case 8 :arrMemory(Num*6) = "Fast-paged" '快速分页 
   Case 16 :arrMemory(Num*6) = "Static column" '静态列 
   Case 32 :arrMemory(Num*6) = "Pseudo-static" '假静态 
   Case 64 :arrMemory(Num*6) = "RAMBUS" 'Rambus公司 
   Case 128 :arrMemory(Num*6) = "Synchronous" '同步 
   Case 256 :arrMemory(Num*6) = "CMOS" '互补 
   Case 512 :arrMemory(Num*6) = "EDO" '外扩充 
   Case 1024 :arrMemory(Num*6) = "Window DRAM" '视频 
   Case 2048 :arrMemory(Num*6) = "Cache DRAM" '缓存 
   Case 4096 :arrMemory(Num*6) = "Nonvolatile" '非易失性 
  End Select 
 Next 
 If Err Then 
  GetMemoryInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetMemoryInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 If Num = 0 Then 
  Redim Preserve arrMemory(6) 
 End If 
 GetMemoryInfo = arrMemory 
 On Error Goto 0 
End Function 

'*************************************************************************************** 
'目的:获取硬盘信息 
'输入:SWbemLocator对象的ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为(硬盘数量*5),0=硬盘的数量 
'    取硬盘的4种属性: 
'    1   2       3   4     5 
'    Model InterfaceType Size MediaType DeviceID 
'    型号  接口      容量 类型    设备标识符 
'注意:InterfaceType是指接口类型,有5个值:SCSI、HDC、IDE、USB、1394 
'   MediaType属性是指媒体类型: 
'     Vista下有四个值: External hard disk media:外接硬盘 
'             Removable media other than floppy:移动媒体或软盘 
'             Fixed hard disk media:固定硬盘 
'             Format is unknown:未知类型 
'     NT 4.0/2000/XP/2003下有三个值: Removable media:移动媒体 
'                    Fixed hard disk:固定硬盘 
'                    Unknown:未知类型 
'   Size属性是1000进制,返回结果是以1024进制换算成G取小数点后二位数,和磁盘管理里看到的相同 
'*************************************************************************************** 
Function GetDiskInfo(objConnection) 
 Dim objDisks, objDisk, Num 
 Dim Tmp 
 On Error Resume Next 
 Set objDisks = objConnection.InstancesOf("win32_Diskdrive") 
 If Err Then 
  GetDiskInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetDiskInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objDisks.Count 
 If Err Then 
  GetDiskInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetDiskInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Redim arrDisk(0) 
 Num = 0 
 For Each objDisk In objDisks 
  Num = Num + 1 
  Redim Preserve arrDisk(Num*5) 
  arrDisk(Num*5-4) = Replace(Trim(objDisk.Model),",","") '型号 
  arrDisk(Num*5-3) = objDisk.InterfaceType '接口 
  arrDisk(Num*5-2) = Round(objDisk.Size/1073741824,2) '容量(G) 
  arrDisk(Num*5-1) = objDisk.MediaType '类型 
  arrDisk(Num*5-0) = objDisk.DeviceID 
 Next 
 If Err Then 
  GetDiskInfo = "错误编号:" & CStr(Err.Number) & _ 
         ",错误原因:" & CStr(Err.Description) & _ 
         ",错误来源:" & CStr(Err.Source) & " By GetDiskInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 If Num = 0 Then 
  Redim Preserve arrDisk(5) 
 End If 
 GetDiskInfo = arrDisk 
 On Error Goto 0 
End Function 

'*********************************************************** 
'目的:获取显卡信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为2 
'    取显卡的3种属性: 
'    0      1      2 
'    Description AdapterRAM DeviceID 
'    描述     显存     设备标识符 
'注意:AdapterRAM属性的单位是字节,返回结果已换算成M字节 
'*********************************************************** 
Function GetVideoInfo(objConnection) 
 Dim objVideos, objVideo, arrVideo(2) 
 Dim Tmp 
 On Error Resume Next 
 Set objVideos = objConnection.InstancesOf("win32_videocontroller") 
 If Err Then 
  GetVideoInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetVideoInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objVideos.Count 
 If Err Then 
  GetVideoInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetVideoInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For Each objVideo In objVideos 
  If Not IsNull(objVideo.VideoModeDescription) Then 
   arrVideo(0) = Replace(Trim(objVideo.Description),",","") 
   arrVideo(1) = objVideo.AdapterRAM/1048576 
   arrVideo(2) = objVideo.DeviceID 
  End If 
 Next 
 If Err Then 
  GetVideoInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetVideoInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 GetVideoInfo = arrVideo 
 On Error Goto 0 
End Function 

'************************************************************************ 
'目的:获取网卡信息(使用Ethernet 802.3协议的网络适配器,即以太网网卡) 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为(网卡数量*6),0=网卡的数量 
'    取网卡的6种属性: 
'    1      2       3      4 
'    Description IPAddress(0) MACAddress IPXVirtualNetNumber 
'    型号     IP      MAC     内部网络号 
'    5        6 
'    NetConnectionID DeviceID 
'    接口名称     设备标识符 
'************************************************************************ 
Function GetNetworkInfo(objConnection) 
 Dim objNetworks, objNetwork, objNetworks_2, objNetwork_2, Num 
 Dim Tmp 
 Redim arrNetwork(0) 
 Num = 0 
 On Error Resume Next 
 Set objNetworks = objConnection.InstancesOf("Win32_NetworkAdapter") 
 If Err Then 
  GetNetworkInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetNetworkInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objNetworks.Count 
 If Err Then 
  GetNetworkInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetNetworkInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Set objNetworks_2 = objConnection.InstancesOf("Win32_NetworkAdapterConfiguration") 
 If Err Then 
  GetNetworkInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetNetworkInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objNetworks_2.Count 
 If Err Then 
  GetNetworkInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetNetworkInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For Each objNetwork In objNetworks 
  If objNetwork.Manufacturer <> "Microsoft" And Not Isnull(objNetwork.MACAddress) Then 
   Num = Num + 1 
   Redim Preserve arrNetwork(Num*6) 
   arrNetwork(Num*6-5) = objNetwork.Description 
   arrNetwork(Num*6-3) = Replace(objNetwork.MACAddress,":","-") 
   arrNetwork(Num*6-0) = objNetwork.DeviceID 
   arrNetwork(Num*6-1) = objNetwork.NetConnectionID 
   If Err.Number = 438 Then 
    arrNetwork(Num*6-1) = "未检测到" '2000系统不支持NetConnectionID属性 
    Err.Clear 
   End If 
   For Each objNetwork_2 In objNetworks_2 
    If objNetwork_2.Index = objNetwork.Index Then 
     arrNetwork(Num*6-4) = objNetwork_2.IPAddress(0) 'IPAddress属性返回结果是数组 
     arrNetwork(Num*6-2) = objNetwork_2.IPXVirtualNetNumber 
     Exit For 
    End If 
   Next 
  End If 
 Next 
 If Err Then 
  GetNetworkInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetNetworkInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 If Num = 0 Then 
  Redim Preserve arrNetwork(6) 
 End If 
 arrNetwork(0) = Num 
 GetNetworkInfo = arrNetwork 
 On Error Goto 0 
End Function 

'*********************************************************** 
'目的:获取声卡信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限2 
'   取声卡的3种属性: 
'   0      1       2 
'   ProductName Manufacturer DeviceID 
'   型号     厂商      设备标识符 
'*********************************************************** 
Function GetSoundInfo(objConnection) 
 Dim objSounds, objSound 
 Dim Tmp 
 Dim arrSound(2) 
 On Error Resume Next 
 Set objSounds = objConnection.InstancesOf("Win32_SoundDevice") 
 If Err Then 
  GetSoundInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetSoundInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objSounds.Count 
 If Err Then 
  GetSoundInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetSoundInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For Each objSound In objSounds 
  arrSound(0) = Replace(objSound.ProductName,",","") 
  arrSound(1) = Replace(objSound.Manufacturer,",","") 
  arrSound(2) = objSound.DeviceID 
 Next 
 If Err Then 
  GetSoundInfo = "错误编号:" & CStr(Err.Number) & _ 
          ",错误原因:" & CStr(Err.Description) & _ 
          ",错误来源:" & CStr(Err.Source) & " By GetSoundInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 GetSoundInfo = arrSound 
 On Error Goto 0 
End Function 


'***************************************************************** 
'目的:获取集成设备的信息 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为(集成设备数量*3),0=集成设备的数量 
'    取集成设备的3种属性: 
'    1       2      3 
'    Description  DeviceType  Enabled 
'    设备描述    类型     是否启用 
'***************************************************************** 
Function GetOnBoardInfo(objConnection) 
 Dim objOnBoards, objOnBoard, Num 
 Redim arrOnBoard(0) 
 Num = 0 
 On Error Resume Next 
 Set objOnBoards = objConnection.InstancesOf("Win32_OnBoardDevice") 
 If Err Then 
  GetOnBoardInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetOnBoardInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 arrOnBoard(0) = objOnBoards.Count 
 If Err Then 
  GetOnBoardInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetOnBoardInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For Each objOnBoard In objOnBoards 
  Num = Num + 1 
  Redim Preserve arrOnBoard(Num*3) 
  arrOnBoard(Num*3-2) = Replace(objOnBoard.Description,",","") 
  Select Case objOnBoard.DeviceType 
   Case 1 :arrOnBoard(Num*3-1) = "其它设备" 
   Case 2 :arrOnBoard(Num*3-1) = "未知设备" 
   Case 3 :arrOnBoard(Num*3-1) = "显示设备" 
   Case 4 :arrOnBoard(Num*3-1) = "SCSI设备" 
   Case 5 :arrOnBoard(Num*3-1) = "以太网设备" 
   Case 6 :arrOnBoard(Num*3-1) = "令牌环网设备" 
   Case 7 :arrOnBoard(Num*3-1) = "声音设备" 
  End Select 
  arrOnBoard(Num*3-0) = objOnBoard.Enabled 
 Next 
 If Err Then 
  GetOnBoardInfo = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetOnBoardInfo Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 If Num = 0 Then 
  Redim Preserve arrOnBoard(3) 
 End If 
 GetOnBoardInfo = arrOnBoard 
 On Error Goto 0 
End Function 

'*********** 
'排序硬件信息 
'*********** 
Function Sort(FilePath) 
 Dim ReadFile, Num, OutputFile, Item, A, B, strA, strB, Tmp 
 Redim arrRead(0) 
 Set ReadFile = FSO.OpenTextFile(FilePath) 
 Do Until ReadFile.AtEndOfStream 
  Num = ReadFile.Line 
  Redim Preserve arrRead(Num) 
  arrRead(Num-1) = ReadFile.ReadLine 
 Loop 
 Set ReadFile = Nothing 
 For A = 1 To Ubound(arrRead) - 2 
  For B = A + 1 To Ubound(arrRead) - 1 
   If Not Strcomp(arrRead(A),arrRead(B)) Then 
    Tmp = arrRead(A) 
    arrRead(A) = arrRead(B) 
    arrRead(B) = Tmp 
   End If 
  Next 
 Next 
 Set OutputFile = FSO.OpenTextFile(FSO.GetBaseName(FilePath) & "_已排序." & _ 
          FSO.GetExtensionName(FilePath),2,True) 
 For Each Item In arrRead 
  OutputFile.Writeline Item 
 Next 
 Set OutputFile = Nothing 
End Function 

'******************************************************************** 
'目的:获取IDE控制器使用的访问受控设备的协议 
'输入:SWbemLocator对象ConnectServer方法连接到远程主机的实例 
'返回:数组,上限为(IDE控制器数量*2),0=IDE控制器数量 
'    取2种属性: 
'    1     2 
'    DeviceID  ProtocolSupported 
'    设备标识符 控制协议 
'******************************************************************** 
Function GetIDEProtocol(objConnection) 
 Dim objIDEProtocol, IDEItem, Num 
 Dim Tmp 
 Redim arrIDE(0) 
 Num = 0 
 On Error Resume Next 
 Set objIDEProtocol = objConnection.InstancesOf("Win32_IDEController") 
 If Err Then 
  GetIDEProtocol = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetIDEProtocol Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 Tmp = objIDEProtocol.Count 
 If Err Then 
  GetIDEProtocol = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetIDEProtocol Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 For Each IDEItem In objIDEProtocol 
  'Msgbox IDEItem.DeviceID & vbCrLf & IDEItem.ProtocolSupported 
  Num = Num + 1 
  Redim Preserve arrIDE(Num*2) 
  arrIDE(Num*2-1) = IDEItem.DeviceID 
  Select Case IDEItem.ProtocolSupported 
   Case 1 :arrIDE(Num*2) = "Other" 
   Case 2 :arrIDE(Num*2) = "Unknown" 
   Case 3 :arrIDE(Num*2) = "EISA" 
   Case 4 :arrIDE(Num*2) = "ISA" 
   Case 5 :arrIDE(Num*2) = "PCI" 
   Case 6 :arrIDE(Num*2) = "ATA/ATAPI" 
   Case 7 :arrIDE(Num*2) = "Flexible Diskette" 
   Case 8 :arrIDE(Num*2) = "1496" 
   Case 9 :arrIDE(Num*2) = "SCSI Parallel Interface" 
   Case 10 :arrIDE(Num*2) = "SCSI Fibre Channel Protocol" 
   Case 11 :arrIDE(Num*2) = "SCSI Serial Bus Protocol" 
   Case 12 :arrIDE(Num*2) = "SCSI Serial Bus Protocol-2 (1394)" 
   Case 13 :arrIDE(Num*2) = "SCSI Serial Storage Architecture" 
   Case 14 :arrIDE(Num*2) = "VESA" 
   Case 15 :arrIDE(Num*2) = "PCMCIA" 
   Case 16 :arrIDE(Num*2) = "Universal Serial Bus" 
   Case 17 :arrIDE(Num*2) = "Parallel Protocol" 
   Case 18 :arrIDE(Num*2) = "ESCON" 
   Case 19 :arrIDE(Num*2) = "Diagnostic" 
   Case 20 :arrIDE(Num*2) = "I2C" 
   Case 21 :arrIDE(Num*2) = "Power" 
   Case 22 :arrIDE(Num*2) = "HIPPI" 
   Case 23 :arrIDE(Num*2) = "MultiBus" 
   Case 24 :arrIDE(Num*2) = "VME" 
   Case 25 :arrIDE(Num*2) = "IPI" 
   Case 26 :arrIDE(Num*2) = "IEEE-488" 
   Case 27 :arrIDE(Num*2) = "RS232" 
   Case 28 :arrIDE(Num*2) = "IEEE 802.3 10BASE5" 
   Case 29 :arrIDE(Num*2) = "IEEE 802.3 10BASE2" 
   Case 30 :arrIDE(Num*2) = "IEEE 802.3 1BASE5" 
   Case 31 :arrIDE(Num*2) = "IEEE 802.3 10BROAD36" 
   Case 32 :arrIDE(Num*2) = "IEEE 802.3 100BASEVG" 
   Case 33 :arrIDE(Num*2) = "IEEE 802.5 Token-Ring" 
   Case 34 :arrIDE(Num*2) = "ANSI X3T9.5 FDDI" 
   Case 35 :arrIDE(Num*2) = "MCA" 
   Case 36 :arrIDE(Num*2) = "ESDI" 
   Case 37 :arrIDE(Num*2) = "IDE" 
   Case 38 :arrIDE(Num*2) = "CMD" 
   Case 39 :arrIDE(Num*2) = "ST506" 
   Case 40 :arrIDE(Num*2) = "DSSI" 
   Case 41 :arrIDE(Num*2) = "QIC2" 
   Case 42 :arrIDE(Num*2) = "Enhanced ATA/IDE" 
   Case 43 :arrIDE(Num*2) = "AGP" 
   Case 44 :arrIDE(Num*2) = "TWIRP (two-way infrared)" 
   Case 45 :arrIDE(Num*2) = "FIR (fast infrared)" 
   Case 46 :arrIDE(Num*2) = "SIR (serial infrared)" 
   Case 47 :arrIDE(Num*2) = "IrBus" 
  End Select 
 Next 
 If Err Then 
  GetIDEProtocol = "错误编号:" & CStr(Err.Number) & _ 
           ",错误原因:" & CStr(Err.Description) & _ 
           ",错误来源:" & CStr(Err.Source) & " By GetIDEProtocol Function" 
  Err.Clear 
  On Error Goto 0 
  Exit Function 
 End If 
 If Num = 0 Then 
  Redim Preserve arrIDE(2) 
 End If 
 arrIDE(0) = Num 
 GetIDEProtocol = arrIDE 
 On Error Goto 0 
End Function 
  
 '******************************************************************************************* 
 'Version:3.1 
 '   调整错误处理方法,错误信息输出到LogFile文件,可以查看扫描失败原因 
 '     如果出现“RPC 服务器不可用”错误,是因为远程主机没开机 
 '     如果出现“RPC 服务器不可用”之外的错误,可能是由于正在运行的程序造成,请你把此信息告诉我 
 '     重启后再次扫描就可以排除非“RPC 服务器不可用。”的错误 
 '     如果扫描到的硬件信息为空,应该是驱动问题(或BIOS不完善),请自行解决 
 'Version:3.0 
 '   增加输出BIOS的发行日期,和主板信息放在一起 
 'Version:2.9 
 '   修正所有GetInfo过程遇错的处理方法,避免返回的数组上限不符合输出要求导致脚本报错。 
 '     之所以为出现这种情况,是因为Win32类检索不到硬件或连接到Win32类失败; 
 '     原来判断是否出现Err,忽略了检索不到硬件的情况(连接成功无Err,Count为0) 
 '     检索不到硬件多数是因为驱动没装好 
 'Version:2.8 
 '   增加GetIDEProtocol过程,获取IDE控制器使用的协议,只是增加了代码,没有调用 
 '   计划增加检索其它存储器控制器的过程 
 'Version:2.7 
 '   检索硬盘/显卡/网卡/声卡的过程增加 DeviceID 属性(设备标识符) 
 '     此属性不被输出,用于脚本内部判断 
 'Version:2.6 
 '   原来输出搜索到的第一个硬盘 
 '   改为输出搜索到的第一个InterfaceType属性为IDE的硬盘的信息 
 'Version:2.5 
 '   增加Sort过程,排序硬件信息 
 'Version:2.4 
 '   调整输出信息的分类,同类信息尽可能的只使用一个逗号分隔,以便导入xls后在同一列 
 '   查询到的硬件信息如果是空或0,有可能是相关驱动不完善或未定义此信息,也可能是未安装驱动 
 '   因为WMI查询就代表了系统知道这些硬件的详细信息,查不到信息就是系统不知道 
 '   系统不知道硬件的详细信息,代表着性能可能有所缺失,建议找个好驱动安装 
 '   值得注意的是主板驱动 
 '   (为了更容易理解,此版本的升级信息被编辑过) 
 'Version:2.3 
 '   取消2.2版增加输出的硬盘接口类型 
 '     由于STAT也归于IDE接口,这会导致误解 
 '     PS:脚本只输出搜索到的第一个硬盘 
 'Version:2.2 
 '   GetMemoryInfo过程增加MemoryType、FormFactor、TypeDetail三个属性 
 '     输出增加内存类型、封装类型 
 '     输出增加硬盘容量、接口类型 
 'Version:2.1 
 '   GetOSInfo过程增加去掉Caption属性中带有的逗号“,”的代码 
 '     原因:在检测2003系统时,读取到的Caption属性,带有逗号“,” 
 '     这会影响输出,因为输出是以逗号“,”为分隔符的 
 'Version:2.0 B5发布版 
 '   GetNetworkInfo过程改为使用MACAddress属性非空、 
 '     Manufacturer属性非"Microsoft"判断网卡 
 'Version:2.0 Beta4 
 '   GetNetworkInfo过程使用NetConnectionStatus属性判断网络适配器 
 '     NetConnectionStatus属性表明连接状态(2000系统不支持此属性) 
 '     物理网络适配器才具有此状态(包括停用状态在内) 
 'Version:2.0 Beta3 
 '   GetNetworkInfo过程增加一个判断 
 '     忽略读取IPAddress(0)时会产生Err类型数据的适配器(对战平台) 
 'Version:2.0 Beta2 
 '   GetOSInfo过程原来使用的Name、ServicePackMajorVersion属性 
 '     改为使用Caption、CSDVersion属性 
 '   所有GetInfo过程增加错误处理代码,避免正在扫描的时候 
 '     脚本遇到运行时错误导致脚本退出 
 'Version:2.0 Beta1 
 '   增加扫描失败记录,再次运行脚本只读取失败记录,忽略配置信息 
 'Version:1.1 
 '   GetNetworkInfo过程增加一个判断 
 '     忽略NetConnectionID属性(接口名称)为空的适配器 
 'Version:1.0 
 '   初始版本 
 '*******************************************************************************************

代码二:

Set wmi=GetObject("winmgmts:\\")
Set board=wmi.instancesof("win32_baseboard")
For Each b In board
msg="主板:"&b.Manufacturer&vbTab&b.product&vbTab&Chr(13)
Next
msg=msg&Chr(13)&"---"+Chr(13)
Set cpus=wmi.instancesof("win32_processor")
msg=msg&"CPU 特征:"+Chr(13)
For Each cpu In cpus
msg=msg+cpu.deviceid&vbTab&cpu.name&Chr(13) _
&vbtab&cpu.SocketDesignation&vbtab&cpu.CurrentClockSpeed&"MHz"&vbtab&cpu.l2cachesize&"Kb_L2"&Chr(13)
Next
msg=msg&Chr(13)&"---"+Chr(13)
Set mem=wmi.instancesof("win32_physicalmemory")
msg=msg&"内存容量:"+Chr(13)
For Each  m In mem
msg=msg&m.tag&space(10)&m.capacity&+Chr(13)
Next
Set mem=wmi.instancesof("win32_computersystem")
For Each m In mem
msg=msg&"内存总容量:"&Round((m.totalphysicalmemory/1024^2),2)&"M"+Chr(13)
Next
msg=msg&Chr(13)&"---"+Chr(13)
Set display=wmi.instancesof("Win32_videocontroller")
msg=msg&"显示系统:"+Chr(13)
For Each   video In display
msg=msg&video.deviceid&vbTab&video.name&Chr(13)
Next
msg=msg&Chr(13)&"---"+Chr(13)

Set disks=wmi.instancesof("win32_diskdrive")
msg=msg&"硬盘容量:"+Chr(13)
For Each d In disks
If int(d.size/(1024^3))=0 Then 
n=Round(d.size/(1024^2),2)&"M"
Else
n=Round(d.size/(1024^3),2)&"G"
End If
msg=msg+d.deviceid&"   空间为: "&n&Chr(13)
Next
msg=msg&Chr(13)&"---"+Chr(13)

MsgBox msg,0,"电脑基本特征"

效果图:

加载全部内容

相关教程
猜你喜欢
用户评论