VBA获取U盘、主板、CPU序列号和网卡MAC地址
上一篇 /
下一篇 2013-11-20 17:36:08
/ 个人分类:好经验转载
VBA获取U盘、主板、CPU序列号和网卡MAC地址
'方法1
Sub Auto_Open()
On Error Resume Next
Set fs =
CreateObject("Scripting.FileSystemObject")
StrDrive =
"B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
StrDriveArray =
Split(StrDrive, ",")
For StartPos = 1 To UBound(StrDriveArray)
Set d =
fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(StrDriveArray(StartPos) &
":\\")))
If d.DriveType = 1 Then
s = d.SerialNumber
Exit For
End
If
Next
If s <> "" Then
Range("Sheet1!d8") =
s
Else
Range("Sheet1!d8") = "系统未检测到U盘!"
End If
Set d =
Nothing
Set fs = Nothing
Call QueryOther
End Sub '方法2
Sub
DetectUdisk()
On Error Resume Next
Set bjWMIService =
GetObject("winmgmts:\\.\root\cimv2")
Set colDisks =
objWMIService.ExecQuery("Select * from Win32_LogicalDisk Where DriveType =
2")
For Each objDisk In colDisks
RemovableDrive = objDisk.DeviceID
If
CreateObject("Scripting.FileSystemObject").GetDrive(RemovableDrive).IsReady
Then
s =
CreateObject("Scripting.FileSystemObject").GetDrive(RemovableDrive).SerialNumber
Exit
For
End If
Next
If s <> "" Then
Range("Sheet1!d8") =
s
Else
Range("Sheet1!d8") = "系统未检测到U盘!"
End If
Call
QueryOther
End Sub
Sub QueryOther()
'2007.1.19 更新,获取主板序列号, CPUID, 网卡MAC地址
Set
bjWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems =
objWMIService.ExecQuery("Select SerialNumber From Win32_BIOS")
For Each
objItem In colItems
Range("Sheet1!E8") = objItem.SerialNumber
Exit
For
Next
Set colItems = Nothing
Set colItems = objWMIService.ExecQuery("Select * from
Win32_Processor")
For Each objItem In colItems
Range("Sheet1!F8") =
objItem.ProcessorId
Exit For
Next
Set colItems = Nothing
Set colItems =
objWMIService.ExecQuery("SELECT MACAddress FROM Win32_NetworkAdapter WHERE ((MACAddress Is Not NULL) AND (Manufacturer <> 'Microsoft'))")
For
Each objItem In colItems
Range("Sheet1!G8") = objItem.MACAddress
Exit
For
Next
Set colItems = Nothing
End Sub
收藏
举报
TAG: