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

gvntw

QUOTE:

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

我试了一下，死循环。

死循环是因为没插入U盘，你可以修改一下，提示用户插入U盘，如：

msg=Msgbox("系统检测无U盘，单击是，插入U盘重试，单击否，退出程序",vbyesno,"提示")

if msg=vbyes then

goto 1

else

thisworkbook.close false

end if

yfxpzq

那么又如何快速得到自己电脑的硬盘的序列号呀？如何快速得到自己U盘的序列号？

kxpc

QUOTE:

以下是引用yfxpzq在2008-9-6 17:14:00的发言：
那么又如何快速得到自己电脑的硬盘的序列号呀？如何快速得到自己U盘的序列号？

Sub sn()

    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) & ":")
    Cells(i, 1) = Chr(64 + i) & ":  " & d.serialnumber
    Next i

End Sub

kxpc

QUOTE:

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

死循环是因为没插入U盘，你可以修改一下，提示用户插入U盘，如：

msg=Msgbox("系统检测无U盘，单击是，插入U盘重试，单击否，退出程序",vbyesno,"提示")

if msg=vbyes then

goto 1

else

thisworkbook.close false

end if

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

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

下面的附件已加密：

tM3qMtuV.rar (6.33 KB, 下载次数: 1084)

2008-9-6 19:56 上传

点击文件名下载附件

[此贴子已经被作者于2008-9-6 19:56:59编辑过]

panjiahe

学习了

yfxpzq

QUOTE:

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

Sub sn()

    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) & ":")
    Cells(i, 1) = Chr(64 + i) & ":  " & d.serialnumber
    Next i

End Sub

我把得到的SN写入

Dim fs, d, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(ThisWorkbook.Path)))
    s = d.serialnumber    '磁盘序列号
    If s = -223748628 Then Exit Sub '要使用的电脑磁盘序列号

我的没有Exit Sub 呀？是不是磁盘序列号得错了？？？（C、D、E、F填哪个磁盘的序列号呀？）

maditate

U盘是你的，你在U盘中随便加一个什么文件，只要VBA在U盘里找不到这个文件就自动关闭文件不就结了，何必去搞的那么复杂。关键的问题是如何加强Excel的本身的安全性，不过这不是你我能解决的。

[此贴子已经被作者于2008-9-6 19:35:30编辑过]

baoshishang

这个不错,有用的.

luanyu6688

不错,学习了,

lhm667788

真是好东西呀！很实用的，收藏了！