获取硬件ID

loquat

CPU ID两种方法：

1. Public Function GetCpuIdwmi() As String               '只返回CPU0
   
2. GetCpuIdwmi = GetObject("winmgmts:").ExecQuery("Select ProcessorID From Win32_Processor")("Win32_Processor.DeviceID='CPU0'", 1).ProcessorID
   
3. End Function

复制代码

1. Private s1 As Long, s2 As Long, s3 As Long, s4 As Long
   
2. 
   
3. Private Function GetStrFromPtr(ByVal Ptr As Long) As String    '从指针得到字符串
   
4. Dim Buffer() As Byte                                  'GetCpuID函数使用
   
5. Dim lpSize As Long
   
6. lpSize = lstrlenW(Ptr) * 2
   
7. If lpSize <> 0 Then
   
8.     ReDim Buffer(lpSize)
   
9.     CopyMemory VarPtr(Buffer(0)), Ptr, lpSize
   
10.     GetStrFromPtr = Buffer
    
11. End If
    
12. End Function
    
13. Private Function GetHex(ByRef inByte() As Byte) As String    '将字节数据以十六进制字符串输出
    
14. Dim i As Long, j() As String, k As Long               'GetCpuID函数使用
    
15. ReDim j(UBound(inByte))
    
16. For i = 0 To UBound(j)
    
17.     j(i) = "00"
    
18.     RSet j(i) = CStr(Hex(inByte(i)))
    
19. Next
    
20. ReDim Preserve j(UBound(j) - 2)
    
21. GetHex = Replace(Join(j(), "-"), " ", "0")
    
22. End Function
    
23. Private Function Int2Hex(Value As Long, n As Long) As String    'GetCpuID函数使用
    
24. Dim tmp1 As String, tmp2 As String, i As Long
    
25. tmp1 = Right("0000000" + Hex(Value), n)
    
26. For i = 0 To Len(tmp1) / 2 - 1
    
27.     tmp2 = tmp2 + Mid(tmp1, Len(tmp1) - 1 - 2 * i, 2)
    
28. Next i
    
29. Int2Hex = tmp2
    
30. End Function
    
31. Private Function hFormat(s As String) As String       'GetCpuID函数使用
    
32. Dim str1 As String
    
33. Dim n As Long
    
34. n = 8 - Len(s)
    
35. If n = 0 Then
    
36.     str1 = s
    
37. Else
    
38.     str1 = s
    
39.     For i = 1 To n
    
40.         str1 = "0" & str1
    
41.     Next i
    
42. End If
    
43. hFormat = str1
    
44. End Function
    
45. Public Function GetCpuId() As String
    
46. mm:
    
47. Dim Code As String, Exec() As Byte
    
48. Dim tmp_Addr As Long
    
49. Dim str1 As String, str2 As String, str3 As String, str4 As String
    
50. Code = "B80000000033D20FA28915" & Int2Hex(VarPtr(s1), 8) & "A3" & Int2Hex(VarPtr(s2), 8) & "B80100000033C933D20FA28915" & Int2Hex(VarPtr(s3), 8) & "890D" & Int2Hex(VarPtr(s4), 8) & "C3"
    
51. ReDim Exec(Len(Code) / 2 - 1)
    
52. For i = 0 To Len(Code) / 2 - 1
    
53.     Exec(i) = Int("&H" & Mid(Code, i * 2 + 1, 2))
    
54. Next
    
55. tmp_Addr = VirtualAllocEx(-1, ByVal 0&, UBound(Exec) + 1, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    
56. WriteProcessMemory -1, ByVal tmp_Addr, ByVal VarPtr(Exec(0)), UBound(Exec) + 1, ByVal 0&
    
57. CreateRemoteThread -1, ByVal 0&, 0, ByVal tmp_Addr, ByVal 0&, ByVal 0&, ByVal 0&
    
58. If s1 = 0 Then GoTo mm                                '获取有错，返回重新获取
    
59. GetCpuId = hFormat(Hex(s1)) & hFormat(Hex(s2)) & hFormat(Hex(s3)) & hFormat(Hex(s4))
    
60. End Function

复制代码

loquat

获取BIOS ID

1. Public Function GetBIOSwmi() As String()              '返回BIOS列表
   
2. Dim arrBIOS As String, aCount&
   
3. Dim objWMIService As Object, BIOSs, objItem
   
4. Set objWMIService = GetObject("winmgmts:").ExecQuery("Select * from Win32_BIOS", , 48)
   
5. For Each objItem In objWMIService
   
6.     arrBIOS = arrBIOS & Trim(objItem.SerialNumber) & ","
   
7. Next
   
8. GetBIOSwmi = Split(arrBIOS, ",")
   
9. End Function

复制代码

loquat

GetHDD

1. Private Function GetHDDwmi()                          '效率很低，仅存档
   
2. Dim arrHDD As String, aCount&
   
3. Dim objWMIService As Object, BIOSs, objItem
   
4. Set objWMIService = GetObject("winmgmts:").InstancesOf("Win32_PhysicalMedia")
   
5. For Each objItem In objWMIService
   
6.     arrHDD = arrHDD & Trim(objItem.SerialNumber) & ","
   
7. Next
   
8. GetHDDwmi = Split(arrHDD, ",")
   
9. End Function

复制代码

loquat

网卡地址：

1. Public Function GetMAC() As String()                  '返回网卡列表
   
2. '原创：loquat
   
3. '虽然效率很低，但是可跨平台且稳定
   
4. Dim ws, aNum%, arr, brr, Temp
   
5. Dim nCount%, i%, MacAddress() As String, n%           '当前正在使用/激活的网卡个数
   
6. Set ws = CreateObject("WScript.Shell")                'Shell对象wshom.ocx，用于后台执行cmd命令
   
7. ws.Run Environ$("comspec") & " /c ipconfig /all | findstr " & Chr(34) & "物理地址. IPv4" & Chr(34) & " > C:\tmpMAC.txt", 0, True    '遍历获取Word文件，并列表到临时文件，同步方式
   
8. aNum = FreeFile()                                     '空闲文件号
   
9. Open "C:\tmpMAC.txt" For Input As #aNum
   
10. brr = StrConv(InputB(LOF(aNum), aNum), vbUnicode)
    
11. arr = Split(brr, vbCrLf)                              '将遍历结果从文件读取到数组中
    
12. Close #aNum
    
13. ws.Run Environ$("comspec") & " /c del /q /s " & Chr(34) & "C:\tmpMAC.txt" & Chr(34), 0, False    '删除临时文件，异步方式
    
14. ReDim Preserve arr(0 To UBound(arr) - 1)
    
15. If InStr(1, brr, "IPv4") Then
    
16.     nCount = UBound(arr)
    
17. Else
    
18.     nCount = UBound(arr) + 1
    
19. End If
    
20. n = 0
    
21. ReDim MacAddress(0 To nCount - 1)
    
22. For i = 0 To UBound(arr)
    
23.     If InStr(1, arr(i), "IPv4") Then                  '当前网卡排到最前
    
24.         n = n + 1
    
25.         Temp = MacAddress(n - 1)                      '当有多个激活网卡时，排在前几列
    
26.         MacAddress(n - 1) = "+" & MacAddress(i - 1)   '目前已经激活的网卡在前面带上“+”
    
27.         MacAddress(i - 1) = Temp
    
28.     Else
    
29.         If n = 0 Then
    
30.             MacAddress(i) = Trim$(Split(arr(i), ":")(1))
    
31.         Else
    
32.             MacAddress(i - n) = Trim$(Split(arr(i), ":")(1))
    
33.         End If
    
34.     End If
    
35. Next i
    
36. GetMAC = MacAddress
    
37. End Function

复制代码

loquat

希望大神能分享一些好的函数进来

高玉甫

对于VBA我是一窍不通，请问楼主，您的代码有何用途？能否附加使用说明？既然是分享，那就要使广大贫下中农都要有所觉悟，否则，阳春白雪，岂不和者盖寡？

loquat

高玉甫 发表于 2017-1-28 00:46
对于VBA我是一窍不通，请问楼主，您的代码有何用途？能否附加使用说明？既然是分享，那就要使广大贫下中农 ...

获取硬件ID，用于开发的插件绑定用户硬件。
一机一码。

liucqa

在管理员和非管理员权限启动excel，看看你的代码结果是否相同

dongdonggege

大侠，请问vba能否获取cpu温度、风扇转速？