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

mingg

学习

gyzzf

发现一个严重问题，禁用宏，则完全失去了保密作用。所以说前面所有代码都不能算加密成功，还需进一步改进。

gyzzf

可不可以考虑这样的思路：加一行代码先将整个工作薄的IsAddin属性设置为True,这样禁用宏后也不能看到工作表的内容，当检测到密匙盘后再将整个工作薄的IsAddin属性设置为False然后退出宏。

winniegreen

  有人用Excel宏表函数来强行要求启用宏，记得是在本论坛里面见过，但具体宏表函数我忘了。
  另外，我发现VBA密码难以保护（工程加密之后，可以被工具破解掉），不知道如何解决。

gvntw

Excel的保护功能本来就很脆弱，只能防新手，不要强求太多，呵呵。

winniegreen

  如果用VB等写DLL来加载（记得好像论坛中有一个帖子有Thisworkbook_Open中动态加载DLL的样例），也同样可能被破解；如果用.Net的OBA来写DLL，则照样可能被Reflector等工具破解。
  附：我公司目前以Office二次开发为主。帖子http://club.excelhome.net/dispbbs.asp?boardid=2&replyid=1516881&id=347068&page=1&skin=0&Star=1相应的程序，已经基本完工（从9月1日开始动手），但现在遇到的一个很大的问题就是如何防止破解。如果解决这个问题，那么可以在几天后提供一个功能简化版（比如，三级部门、十人以下可免费），然后给大家分享其中的一些思路和算法。

gyzzf

QUOTE:

以下是引用gvntw在2008-9-10 14:25:00的发言：
Excel的保护功能本来就很脆弱，只能防新手，不要强求太多，呵呵。

 版主说的不无道理。但我觉得这种加密确实脆弱得有点过（破解问题不在考虑之内），应该再往深处开发，理由有二：1、只怕连新手也防不了，我就是个新手呀，呵呵；2、越是没接触过VBA（一点也不懂）人，在打开工作表时越是乱点，因不知宏是何东西（还以为是病毒）而点“禁用宏”。

用U盘作密匙盘的思路确实很不错，如果进一步完善解决了这些问题，则是非常实用的。呵呵，科学就是要严谨。

winniegreen

QUOTE:

以下是引用gyzzf在2008-9-10 14:57:00的发言：

 版主说的不无道理。但我觉得这种加密确实脆弱得有点过（破解问题不在考虑之内），应该再往深处开发，理由有二：1、只怕连新手也防不了，我就是个新手呀，呵呵；2、越是没接触过VBA（一点也不懂）人，在打开工作表时越是乱点，因不知宏是何东西（还以为是病毒）而点“禁用宏”。

用U盘作密匙盘的思路确实很不错，如果进一步完善解决了这些问题，则是非常实用的。呵呵，科学就是要严谨。

  能点“禁用宏”，说明那台电脑上的Excel等已经将宏安全性从“高”或“非常高”降到了“中”，那么就可以采用数字签名（有两类签名，一类是免费的，微软提供的，但可能被伪造；另外一类是收费的，微软有提供一些签名提供商列表），只要有一次点击了总是信任，就不会再出现是否启用宏的提示了（即使之后将宏安全性调整为“高”也没有关系，但若调整为“非常高”，也不能使用）。
  更可怕的是，有一些客户，听到宏就想到“宏病毒”，然后就总是试图坚决地“将宏安全性设置为非常高或高”。
  用U盘作密匙盘的思路，的确非常棒，我之后也会参考，但总觉得最核心的代码保护缺陷没解决之前，很可能把密匙盘给“晾”在一边，直接破解后加几个单引号，谈笑间“盾牌”灰飞烟灭。

Zamyi

说到加密,就连加密狗也给人家破解得彻彻底底,象广联达,外面的复制狗满天飞,我用的是免狗版。加密狗在这里是什么也检测不到的。这个程序只是对人家开发的宏程序进行一丁点的保护，如果要保护文档，直接启用密码好了。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 

Zamyi

 

Public Sub 读磁盘序列()

  Dim fs, d, dc, s$

  Set fs = CreateObject("Scripting.FileSystemObject")

  On Error Resume Next

  Set dc = fs.Drives

  For Each d In dc

    s = d.serialnumber

    i = i + 1

    Cells(i, 1) = d.Path

    Cells(i, 2) = d.serialnumber

    Cells(i, 3) = d.drivertype

    Next

  Set dc = Nothing

  Set fs = Nothing

End Sub