[分享]用U盘做加密狗,加密Excel文件(108楼有新代码!)

gljzyp

支持41楼和42楼意见,期待中.........

 

[em02]

lhm667788

QUOTE:

以下是引用gljzyp在2008-9-8 11:14:00的发言：

支持41楼和42楼意见,期待中.........

    支持！期待中…………

[此贴子已经被作者于2008-9-8 12:57:02编辑过]

tomyi

非常好的想法

不过,把程序改改,遍历各设备,会更好

Private Sub FindKey()
  Dim fs, dc, d, s$
 ' On Error Resume Next
 
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set dc = fso.Drives

  'DrivesCount = dc.Count
  
  For Each d In dc
  
    s = d.serialnumber
   
    Debug.Print d.Path, s
   
    Select Case s
      Case "-1330828335"  'U盘序列号
        Exit Sub
      End Select
  Next
 
  MsgBox "找不到U盘，系统将退出。"
 
  ThisWorkbook.Close False
 
End Sub

kxpc

QUOTE:

以下是引用tomyi在2008-9-8 14:32:00的发言：

非常好的想法

不过,把程序改改,遍历各设备,会更好

Private Sub FindKey()
  Dim fs, dc, d, s$
 ' On Error Resume Next
 
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set dc = fso.Drives

  'DrivesCount = dc.Count
  
  For Each d In dc
  
    s = d.serialnumber
   
    Debug.Print d.Path, s
   
    Select Case s
      Case "-1330828335"  'U盘序列号
        Exit Sub
      End Select
  Next
 
  MsgBox "找不到U盘，系统将退出。"
 
  ThisWorkbook.Close False
 
End Sub

   有下错误：

           运行时错误'71'

           磁盘未准备好

gljzyp

45楼:首句为:Private Sub Workbook_Open()测试通过

[此贴子已经被作者于2008-9-8 15:23:34编辑过]

hhzjxss

思路是想出来的，好程序就要好思路！[em17]

robby0516

QUOTE:

以下是引用lhm667788在2008-9-7 12:59:00的发言：

gvntw版主说的极对，下面是按gvntw版主提供的代码整理的，已测试通过。即人性化，又很和谐！

不过由于限制了U盘的类型（d.Drivetype=1），只能用U盘。

Private Sub Workbook_Open()
  On Error Resume Next
1:
  Set fs = CreateObject("Scripting.FileSystemObject")
  DrivesCount = fs.drives.Count
  Set d = fs.GetDrive(Chr(66 + DrivesCount))
  dt = d.drivetype
  sn = d.serialnumber
  If dt <> 1 Then
    msg = MsgBox("系统检测无U盘，单击是，插入U盘重试，单击否，退出程序", vbYesNo, "提示")
    If msg = vbYes Then
        GoTo 1
    Else
        ThisWorkbook.Close False
        Exit Sub
    End If
  Else
    If sn = 682417999 Then     'U盘序列号
        Exit Sub
    Else
        MsgBox "找不到密钥盘，系统将退出。"
        ThisWorkbook.Close False
    End If
  End If
End Sub

密钥盘制作附件

我下载了，然后序列号改为我的U盘的序列号，我在几台机子上使用过，但只有在一台机子上能用，不知道是为什么。这项技术是好的，但是还有个问题，即便是对工程加了密码，现在破解工程密码的软件到处都是，其中有一款软件叫VBApass，就可以解除工程密码，工程密码一旦解除，就可以随意改动序列号，甚至将加密程序删除，那就没用了，有没有更好的办法来加密工程，我觉得还是做动态链，但是比较复杂，研究了很久都没研究透彻，希望高手都研究研究加密工程！

富戈

QUOTE:

以下是引用gvntw在2008-9-6 14:59:00的发言：

请试试：

Sub dd()
1:
Set fs = CreateObject("Scripting.FileSystemObject")
DrivesCount = fs.drives.Count
Set d = fs.GetDrive(Chr(65 + DrivesCount)) '因为没有B盘，所以用65+
dt = d.DriveType
If dt > 1 Then
    MsgBox "没有U盘，请插入U盘再试"
    GoTo 1
End If
s = d.SerialNumber  'U盘SerialNumber
If s=…… Then……
End Sub

这个代码意思是判断最后一个盘符是不是“U盘”，这有缺陷。因为即使插入了优盘，也不一定优盘是最后一个盘符。而且要把 65 改为 66 才是最后一个盘符。

富戈

Microsoft® Visual Basic® Scripting Edition DriveType 常数

语言参考  启始页 | 版本 3

请参阅

---

仅当类型库包含以下常数定义，且在您的工程文件中已经显式引用该类型库后，才允许使用这些常数。对于 VBScript，必须在代码中显式声明这些常数。

常数	值	描述
Unknown	0	无法确定驱动器类型。
Removable	1	可移动媒体驱动器，包括软盘驱动器和其他多种存储设备。
Fixed	2	固定（不可移动）媒体驱动器，包括所有硬盘驱动器（包括可移动的硬盘驱动器）。
Remote	3	网络驱动器，包括网络上任何位置的共享驱动器。
CDROM	4	CD-ROM 驱动器，不区分只读和可读写的 CD-ROM 驱动器。
RAMDisk	5	RAM 磁盘，在本地计算机中占用一块“随机存取内存”(RAM) 虚拟为磁盘驱动器。

---

富戈

 如果有些恐龙时代的机器，还装有“软驱”的话，用 

Sub dd()
1:
Set fs = CreateObject("Scripting.FileSystemObject")
DrivesCount = fs.drives.Count
Set d = fs.GetDrive(Chr(66 + DrivesCount)) '因为没有B盘，所以用65+
dt = d.DriveType
If dt > 1 Then
    MsgBox "没有U盘，请插入U盘再试"
    GoTo 1
End If
s = d.SerialNumber  'U盘SerialNumber
If s=…… Then……

显然是不合适的。就算是 没有 软驱，最后一个盘符就一定为 U盘 吗？