Access编程交流网
  • 设为首页|收藏本站|繁体中文|手机版
  •     
  • Access培训-Access开发平台-Access行业开发

  • 首页
  • 资讯
  • 技巧
  • 源码
  • 行业
  • 资源
  • 活动
  • 关于

技巧

ACCESS数据库

启动/设置/选项/背景

修复/压缩

安全/加密/解密

快捷键

版本升级/其它等

数据表

命名方式/设计规范

表设计

查询

Sql语言基础

选择查询

更新查询

删除查询

追加查询

生成表查询

交叉表查询

SQL特定查询

查询参数

查询综合应用

界面/窗体/控件

标签

文本框

命令按钮

组合框/列表框

选项组/复选框/选项按钮

选项卡

子窗体

窗体本身/综合应用

其它

报表打印

报表设计

高级报表

模块/函数/VBA/API/系统

VBA基础

内置函数

调试/跟踪/Debug

模块/类模块

API/COM/系统相关

字符数字日期

网络通信游戏

加密解密安全

文件处理

经典算法

宏/菜单/工具栏/功能区

宏/脚本

菜单/工具栏

功能区/Ribbon

图表/图形/图像/多媒体

图表

图形/图像

音频

视频/动画

DAO/链接表/ADO/ADP

DAO/链接表/ODBC

ADO/RDO

ADP

ActiveX/第三方控件/插件

Treeview树控件

ListView列表控件

Toolbar工具栏控件

微软其它控件

Dbi-Tech

CodeJock

Grid++Report

FastReport

ComponentOne

加载项/插件/Addin

OFFICE集成/导入导出/交互

Excel导入导出/交互

Word导入导出/交互

PPT交互

Outlook控制/邮件

Text文本文件/INI/CSV

PDF/SWF/XML格式

CAD格式

Sharepoint/其它Office

SqlServer/其它数据库

表

视图

存储过程/触发器

函数

用户/权限/安全

调试/维护

SqlServer其它/综合

发布/打包/文档/帮助

开发版/运行时

打包/发布/部署

开发文档/帮助制作

Access完整行业系统

采购管理系统

销售管理系统

仓库管理系统

人力资源管理HRM

CRM管理系统

MRP/ERP管理系统

BRP/流程优化

其它管理系统

心得/经验/绝招
其它/杂项
Excel技巧

Excel应用与操作

Excel开发编程

Word技巧

Word应用与操作

Word开发编程

Outlook技巧

Outlook应用与操作

Outlook开发编程

热门文章

  • 解决同时装Office 2..
  • 真正隐藏表和删除隐藏表的几..
  • (技巧)大型事务处理期间出..
  • 用SSMA升迁工具移植Ac..
  • Access VBA获取U..
  • Access"智库"培训-..

最新文章

  • Access工程名称与文件..
  • 用SSMA升迁工具移植Ac..
  • 如何判断Access数据库..
  • Access VBA获取U..
  • Access2007及Ac..
  • 真正隐藏表和删除隐藏表的几..

联系方式

Access交流网(免费Access交流)

QQ:18449932 

网  址:www.access-cn.com

当前位置:首页 > 技巧 > ACCESS数据库 > 版本升级/其它等
版本升级/其它等

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中国

发布人:achao  
分享到:
点击次数:  更新时间:2017-04-13 17:23:53  【打印此页】  【关闭】
上一条:API获取网卡地址  下一条:快速获取Excel文件所有工作表表名



相关文章

  • • Access工程名称与文件名称的区别
  • • 用SSMA升迁工具移植Acceses到SQL Server的几点问题
  • • 如何判断Access数据库是运行在正常完整版本(Full Access)还是运行时版本(Access Runtime)
  • • Access2007及Access2010加载Dll错误的多种解决办法
  • • 真正隐藏表和删除隐藏表的几种技巧
  • • 解决同时装Office 2003、2007和2010 版本切换总发生重新配置的办法
  • • 您启动 Access 2010 时,配置过程需要很长时间

热门文章

  • [2017-04-13] Access VBA获取U盘(优盘)机器码系列号及U盘开发的各种代码access数据库
  • [2014-04-18] Access"智库"培训--高效设计 敏捷开发 之一(Office免费公开课)access数据库
  • [2015-01-13] 您启动 Access 2010 时,配置过程需要很长时间access数据库
  • [2014-12-12] (技巧)大型事务处理期间出现 超过文件共享锁计数 解决办法access数据库
  • [2017-07-29] 用SSMA升迁工具移植Acceses到SQL Server的几点问题access数据库
  • [2015-01-13] 解决同时装Office 2003、2007和2010 版本切换总发生重新配置的办法access数据库

热门产品

公司动态|在线留言|在线反馈|友情链接|会员中心|站内搜索|网站地图

中山市天鸣科技发展有限公司 版权所有 1999-2023 粤ICP备10043721号

QQ:18449932

Access应用 Access培训 Access开发 Access平台

access|数据库|access下载|access教程|access视频|access软件

Powered by MetInfo 5.3.12 ©2008-2025  www.metinfo.cn