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

gvntw

QUOTE:

以下是引用kxpc在2008-9-6 17:46:00的发言：

这样修改后正常.(已测试通过)

Private Sub Workbook_Open()
  On Error Resume Next
  Set fs = CreateObject("Scripting.FileSystemObject")
  DrivesCount = fs.drives.Count
  Set d = fs.GetDrive(Chr(65 + DrivesCount))
  sn = d.serialnumber
  If sn = -1330828335 Then      'U盘序列号
     Exit Sub
  Else
     MsgBox "找不到密钥盘，系统将退出。"
     ThisWorkbook.Close False
  End If
End Sub

下面的附件已加密：

呵呵，我觉得用还是找不到U盘时用Goto循环一下好，免得自己忘了插入U盘，关闭文件后，再插入U盘，还得重新打开文件检测U盘，如果忘记插入U盘，看到提示，可以插入U盘，再点一下确定按钮，不必重新打开文件，这样显示更人性化一点。

Zamyi

gvntw版主和我都做得不细，忘记释放内在变量，我的代码更为：

Private Sub Workbook_Open()
  Dim fs, d, s$
  On Error Resume Next
  For i = 3 To 26
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(Chr(64 + i) & ":")
    s = d.serialnumber
    Select Case s
      Case "1222130052"  'U盘序列号
        Set fs = Nothing
        Set d = Nothing
        Exit Sub
      End Select
    Set fs = Nothing
    Set d = Nothing
  Next i
  MsgBox "找不到U盘，系统将退出。"
  ThisWorkbook.Close False
End Sub

hhzjxss

谢谢，值得学习，不过，解密只是相对的！

gyzzf

学习中

lhm667788

QUOTE:

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

呵呵，我觉得用还是找不到U盘时用Goto循环一下好，免得自己忘了插入U盘，关闭文件后，再插入U盘，还得重新打开文件检测U盘，如果忘记插入U盘，看到提示，可以插入U盘，再点一下确定按钮，不必重新打开文件，这样显示更人性化一点。

不错，这样是更人性化，更以人为本。

gljzyp

太好了,起码在我单位有用,谢谢了!

(当然也支持25楼的说)

lhm667788

QUOTE:

以下是引用gljzyp在2008-9-7 10:29:00的发言：

太好了,起码在我单位有用,谢谢了!

(当然也支持25楼的说)

在单位的电脑上，谁把你的excel文件或应用系统（如工资表之类）复制了，在其它机器上没有密钥盘就运行不了（该代码不仅对U 盘有效，对硬盘序列号也同样有效），给VBAProject加个密码，其它人打不开宏。

wengpicc

大开眼界,值得学习!

lhm667788

QUOTE:

以下是引用Zamyi在2008-9-6 22:56:00的发言：

gvntw版主和我都做得不细，忘记释放内在变量，我的代码更为：

Private Sub Workbook_Open()
  Dim fs, d, s$
  On Error Resume Next
  For i = 3 To 26
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(Chr(64 + i) & ":")
    s = d.serialnumber
    Select Case s
      Case "1222130052"  'U盘序列号
        Set fs = Nothing
        Set d = Nothing
        Exit Sub
      End Select
    Set fs = Nothing
    Set d = Nothing
  Next i
  MsgBox "找不到U盘，系统将退出。"
  ThisWorkbook.Close False
End Sub

更完美，更完善。

lhm667788

QUOTE:

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

呵呵，我觉得用还是找不到U盘时用Goto循环一下好，免得自己忘了插入U盘，关闭文件后，再插入U盘，还得重新打开文件检测U盘，如果忘记插入U盘，看到提示，可以插入U盘，再点一下确定按钮，不必重新打开文件，这样显示更人性化一点。

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

密钥盘制作附件

LAJp7kfG.rar (11.57 KB, 下载次数: 949)

2008-9-7 15:08 上传

点击文件名下载附件

[此贴子已经被作者于2008-9-7 15:09:50编辑过]