Access VBA获取U盘(优盘)机器码系列号及U盘开发的各种代码

一、用U盘加密你的软件：

    一般U盘不具备加密功能，虽然U盘和专业加密狗外形有些相似，但是内部完全不一样，U盘只是一个存储器芯片和简单附属电路，而现在智能卡加密狗都具有一个单独的CPU或者加密芯片，可以执行相当复杂加密算法。
　　有软件开发商有这样一种需求，就是使用U盘发布软件同时，想要节约成本，防止U盘中软件被复制，但又不想再购买昂贵加密狗，因此想要把软件绑定在U盘上执行，当U盘拔下来的时候，软件就不能正常运行，和我先前介绍的绑定硬件指纹相似，使用绑定U盘的方式加密软件。
　　在对软件安全不是特别在意的情况下，可以在软件中采用绑定U盘内部ID的方式来实现这种加密，先使用程序将U盘的ID读出来，然后根据这个ID生成License文件，当解密者将U盘内的文件复制到其他电脑的时候，软件执行过程中读取U盘ID失败，因此就无法校验License。
　　通常情况下两个U盘的ID是不相同的，因此即使将软件复制到另外一个U盘，软件执行的时候，根据U盘ID验证License，也会出现不匹配的现象，这样就实现了软件绑定U盘的加密方式。
　　需要指出的是，这种U盘加密并不算安全，大多数U盘厂商有内部量产工具，可以修改U盘的内部ID号码，这就存在了复制U盘的可能性，但对于普通用户来说，通常没有修改U盘内部ID的能力，因此也具有一定的加密性。
　　这个加密方法中，读取U盘ID号的函数的VB源代码如下所示：
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colItems = objWMIService.ExecQuery("Select * From Win32_USBHub")
    For Each objItem In colItems
        a = objItem.DeviceID
        If InStr(a, "VID") Then b = Split(a, "\")
        USB_ID = b(UBound(b))
    Next
摘自月光博客

二、获取盘符和卷标

Private Sub Command1_Click()   
    Dim fso As Object, drv As Object   
    Set fso = CreateObject("Scripting.FileSystemObject")   
    For Each drv In fso.Drives   
       If drv.DriveType = 1 Then
        Print drv.DriveLetter & ":", drv.VolumeName   
    Next
End Sub

Private Declare Function GetVolumeInformation Lib "kernel32" _
    Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
    ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
    lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
    lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
    ByVal nFileSystemNameSize As Long) As Long
Private Function GetSerial(ByVal nDrive As String) As String
Dim aa As Long
Dim VolName As String
Dim fsysName As String
Dim VolSeri As Long
Dim Sysflag As Long, Maxlen As Long
VolName = String(255, 0)
fsysName = String(255, 0)
aa = GetVolumeInformation(nDrive, VolName, 256, VolSeri, Maxlen, Sysflag, fsysName, 256)
GetSerial = Hex(VolSeri)
End Function

If GetDriveType(DriveID) = 2 Then
        '取到了U盘
    msgbox GetSerial(DriveID)     取到了U盘序列号码
End If

Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Sub Command1_Click()
Dim StrDrive As String
Dim DriveID As String
Dim i As Integer
Dim m As Long
StrDrive = String(100, Chr$(0)) '初始化盘符串
m = GetLogicalDriveStrings(100, StrDrive) '返回盘符串
For i = 1 To 100 Step 4 '注意这里是4
    DriveID = Mid(StrDrive, i, 3) '枚举盘符
    If DriveID = Chr$(0) & Chr(0) & Chr(0) Then Exit For '没有盘符,即时退出循环
    If GetDriveType(DriveID) = 2 Then
        '取到了U盘
    End If
Next i
End Sub

三、取U盘(优盘）硬件序列号（机器码）

Sub aa()
  Dim objWMIService As Object
  Dim colItems As Object
  Dim objitem As Object
  Dim a, b, c, d, e, U_Dist
  Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
  Set colItems = objWMIService.InstancesOf("Win32_USBHub") 'ExecQuery("Select * From Win32_USBHub")
  I = 1
  For Each objitem In colItems
    a = objitem.DeviceID
    If a Like "*VID*" Then
      b = Split(a, "\")
      c = Split(b(UBound(b) - 1), "&")
      d = Split(c(UBound(c) - 1), "_")
      e = Split(c(UBound(c)), "_")
      U_Dist = d(UBound(d)) + e(UBound(e)) + b(UBound(b))
      ttx = U_Dist
      Cells(I, 1) = U_Dist
      I = I + 1
    End If
  Next   
End Sub

Sub bb()
Dim WMILocator As New SWbemLocator '定义一个指向WMI的指针
Dim WMIServices As SWbemServices
Dim WMIObjectSet As SWbemObjectSet
Dim WMIObject As SWbemObject
Dim I As Long
'Sheet1.Cells.Clear
Set WMIServices = WMILocator.ConnectServer(".", "root\CIMV2") '可以省略，写上是为了更好理解参数的使用
Set WMIObjectSet = WMIServices.InstancesOf("Win32_USBHub")
I = 1
With Sheet1
    For Each WMIObject In WMIObjectSet
        .Range("a" & I).value = "U盘" & I
        .Range("b" & I).value = WMIObject.DeviceID '物理序列号添加到B列
        I = I + 1
    Next
End With
Set WMIObject = Nothing
Set WMIObjectSet = Nothing
End Sub

四、取U盘物理序列号核心代码

On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colitems = objWMIService.execquery("Select * From Win32_USBHub")
For Each objitem In colitems
a = objitem.deviceID 'U盘识别为:USB\VID_09A6&PID_800\20040418154911-00，故用VID判别
If a Like "输入我的U盘的物理序列号这样可以认到我的U盘" Then b = Split(a, "\")
CC = b(UBound(b)) '上句亦可:If InStr(a, "VID") Then b = Split(a, "\"): MsgBox b(UBound(b))
取U盘盘符
Set colitems = objWMIService.execquery("Select * From Win32_LogicalDiskToPartition")
upanname = objitem.dependent
uname = Split(upanname, "=")
d = uname(UBound(uname))
d = Mid(d, 2, 2)
研究下，现把这两个代码合起来。让他取完了物理序列号然后认出来所在盘符

五、多硬盘中确定某个分区所对应序号

Private Sub Form_Load()
  On Error Resume Next
  Dim objWMIService As Object
  Dim colDevices As Object
  Dim objDevice As Object
   strComputer = "."
  Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
  Set colDevices = objWMIService.execquery _
        ("Select * From Win32_DiskDrive")
    For Each objDevice In colDevices
      Debug.Print objDevice.Caption        '磁盘名称
      Debug.Print objDevice.Index          '磁盘在系统中的 INDEX
      Debug.Print objDevice.INTERFACETYPE  '磁盘接口类型
    Next objDevice
  Set colDevices = objWMIService.execquery _
        ("Select * From Win32_LogicalDiskToPartition")
    For Each objDevice In colDevices
      Debug.Print objDevice.Antecedent
      Debug.Print objDevice.Dependent
    Next   
End Sub   ''对扩展分区无法判断

六、取U盘的相关硬件信息

'WMI 呀 开篇就说了
Private Sub Form_Load()
  On Error Resume Next
  Dim objWMIService As Object
  Dim colDevices As Object
  Dim objDevice As Object
  strComputer = "."
  Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
  Set colDevices = objWMIService.execquery _
        ("Select * From Win32_DiskDrive")
    For Each objDevice In colDevices
      Debug.Print objDevice.Caption        '磁盘名称
      Debug.Print objDevice.Index          '磁盘在系统中的 INDEX
      Debug.Print objDevice.INTERFACETYPE  '磁盘接口类型
      Debug.Print objDevice.Partitions     '磁盘分区数
    Next objDevice
end sub

Option Explicit
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Sub Form_Load()
  GetDiskPartition "c:"
  GetDiskPartition "d:"
  GetDiskPartition "e:"
  GetDiskPartition "f:"
  GetDiskPartition "g:"
  GetDiskPartition "h:"
End Sub
Function GetDiskPartition(ByVal DiskStr As String)
  On Error Resume Next
  Dim lp As String * 255
  Dim m As Long, n As Long
  m = QueryDosDevice(DiskStr, lp, 255)
  n = Val(Mid(lp, 23, m - 23))
  If m = 0 Or n = 0 Then Exit Function
  Dim objWMIService As Object
  Dim colDevices As Object
  Dim objDevice As Object
  Dim strComputer As String

  strComputer = "."
  m = 0
  Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
  Set colDevices = objWMIService.execquery _
        ("Select * From Win32_DiskDrive")
    For Each objDevice In colDevices
      m = m + objDevice.Partitions  '磁盘分区数
      If n <= m Then
        Debug.Print objDevice.Index + 1 & ":" & n - m + objDevice.Partitions
        Exit For
      End If
    Next objDevice
End Function

七、其它方法 读取优盘(U盘）系列号

Public Function GetUDiskID() As String
    '****
    '*Function:读取优盘物理序列号
    '*Author:张旋(zxsoft)
    '****
    On Error Resume Next
    Dim objWMIService As Object
    Dim colDevices As Object
    Dim objdevice As Object
    Dim UDiskID As String
    Dim isUDisk As Boolean
    Dim objUsbDevice As Object
    Dim colUSBDevices As Object
    isUDisk = False
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colDevices = objWMIService.ExecQuery _
        ("Select * From Win32_USBControllerDevice")
    Dim ret
    For Each objdevice In colDevices
        Set colUSBDevices = objWMIService.ExecQuery _
            ("Select * From Win32_PnPEntity Where DeviceID = '" & Split(Replace(objdevice.Dependent, Chr(34), ""), "=")(1) & "'")
        For Each objUsbDevice In colUSBDevices
            If Left(objUsbDevice.DeviceID, 8) = "STORAGE\" Then
                GetUDiskID = UDiskID
                Exit Function
            End If
            If Left(objUsbDevice.DeviceID, 8) = "USB\VID_" Then
                UDiskID = Split(objUsbDevice.DeviceID, "\")(2)
                If InStr(UDiskID, "&") > 0 Then
                    ret = Split(UDiskID, "&")
                    UDiskID = ret(UBound(ret) - 2)
                End If
            End If
        Next
    Next
    GetUDiskID = "U-Disk-Not-Found"
End Function


八、更专业access加密狗 保护你的软件版权： 请联系 Office中国