Dzwebs.Net

撰写电脑技术杂文十余年

VBA获取U盘、主板、CPU序列号和网卡MAC地址

Admin | 2008-5-6 18:38:16 | 被阅次数 | 10432

温馨提示!

如果未能解决您的问题,请点击搜索;登陆可复制文章,点击登陆

'方法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


网站备案号:

网站备案号:滇ICP备11001339号-7

版权属性:

Copyright 2007-2021-forever Inc. all Rights Reserved.

联系方式:

Email:dzwebs@126.com QQ:83539231