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

lhm667788

U盘密钥盘的问题,应该引起山菊花和清风超级版主的关注,提供更好更完善的解决方案,更安全的代码.

zlunzhang

这个也有一个问题，如果设置禁用宏的话，好像就不起作用了

caicanwu911

还可以这样？

maditate

Excel本身不安全。

nicehunnt

不管咋样，这都是一个不错的想法和建议！学习中！

jolly5668

创意不错。学习

firefox444

U盘序列号可以更改的，而且很容易，用量产工具就，想改成什么就是什么。

lhm667788

QUOTE:

以下是引用Zamyi在2008-9-10 15:30:00的发言：

说到加密,就连加密狗也给人家破解得彻彻底底,象广联达,外面的复制狗满天飞,我用的是免狗版。加密狗在这里是什么也检测不到的。这个程序只是对人家开发的宏程序进行一丁点的保护，如果要保护文档，直接启用密码好了。45楼的思路好，修改下更完善：

Private Sub Workbook_Open()

  Dim fs, d, dc, s$

  Set fs = CreateObject("Scripting.FileSystemObject") 

  Set dc = fs.Drives

  For Each d In dc

    s = d.serialnumber

    Select Case s

      Case "1084165300"       '硬盘序列
  

        Set dc = Nothing

        Set fs = Nothing

        Exit Sub

      Case "1222130052"        'U盘序列
  

        Set dc = Nothing

        Set fs = Nothing

        Exit Sub

      End Select

    Set dc = Nothing

  Next

  Set fs = Nothing

  MsgBox "找不到正确U盘，系统将退出！"

  ThisWorkbook.Close False

End Sub 

   在我的笔记本上运行出错.

ni57

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

密钥盘制作附件

深度2008贺岁版xp系统自带的office2003版

测试上述“密钥盘制作附件”，结果如下：

1.出现提示窗口，要插入U盘，否则不能进入文件；

2.插入U盘后，可以正常打开和保存、关闭该文件，当再次打开该文件时，则不需要插入U盘了

3.将该文件的位置移动后，需要重新插入一次U盘，才可以重新进入

4.问题是：用什么U盘都可以打开该文件，起不到密钥盘的效果，没有加密的作用了

搞不懂！！！

jjtlzx

学习了!