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 objWMIService = 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 objWMIService =
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