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

xing979020

原帖由 Zamyi 于 2008-9-6 22:56 发表
gvntw版主和我都做得不细，忘记释放内在变量，我的代码更为：Private Sub Workbook_Open()  Dim fs, d, s$  On Error Resume Next  For i = 3 To 26    Set fs = CreateObject("Scrip ...

楼主还少写一了一个：应该写成：
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 "1260461834"  'U盘序列号
        Set fs = Nothing
        Set d = Nothing
        MsgBox "找到U盘，测试成功。"
      End Select
    Set fs = Nothing
    Set d = Nothing
    s = ""
  Next i
  
ThisWorkbook.Close False
End Sub

不加S=""会重复出现"找到U盘，测试成功。"，电脑上有多少个盘就会重复多少次。

xing979020

原帖由 lhm667788 于 2008-9-9 23:48 发表
测试完全通过！Private Sub Workbook_Open()On Error Resume NextSet fs = CreateObject("Scripting.FileSystemObject")    StrDrive = "B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z" & ...

谢谢楼主，按前几楼的说话改了下：
Private Sub Workbook_Open()
Dim fs, d, s$
Dim SerBoolean As Boolean
SerBoolean = False' 判断是否有指定的U盘
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
    StrDrive = "B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
    StrDriveArray = Split(StrDrive, ",")
    For StartPos = 1 To UBound(StrDriveArray)
        Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(StrDriveArray(StartPos) & ":\\")))
        If d.DriveType = 1 Then
            s = d.serialnumber
               Select Case s
                   Case "1260461834"  'U盘序列号
                       SerBoolean = True
                       Set fs = Nothing
                       Set d = Nothing
                       s = ""
               End Select
                       Set fs = Nothing
                       Set d = Nothing
        End If
    Next
    If SerBoolean Then
        MsgBox "找到U盘，测试成功。"
        Else
        
        MsgBox "没有找到U盘加密狗，程序将退出。"
        ThisWorkbook.Close False
    End If
End Sub
这样会更合理。

BXLYLM

多谢楼主分享，学习了

thithin

一个很好的方法

hooyee

记号一下。

kaiwen10000

非常经典，谢谢！！！！！

zxueq

好东西,收藏先,谢谢分享

xdwy81129

佩服，收藏了。。。。。。。。。。。。。

xibeiakang

我先加入，占个位。这里的贴子很宝贵。。呵呵，抓紧时间学习

wangjian6931

留个脚印以后来看。