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

分享一下!

向各位高手学习!

向各位Excel专家学者致敬!

常数	值	描述
Unknown	0	无法确定驱动器类型。
Removable	1	可移动媒体驱动器，包括软盘驱动器和其他多种存储设备。
Fixed	2	固定（不可移动）媒体驱动器，包括所有硬盘驱动器（包括可移动的硬盘驱动器）。
Remote	3	网络驱动器，包括网络上任何位置的共享驱动器。
CDROM	4	CD-ROM 驱动器，不区分只读和可读写的 CD-ROM 驱动器。
RAMDisk	5	RAM 磁盘，在本地计算机中占用一块“随机存取内存”(RAM) 虚拟为磁盘驱动器。

  磁盘的排列顺序为A: B: C: D: E: F: G: 等，软驱是在前面，接着是硬盘、光驱、U盘，它们的类型分别是 1、2、4、1，现在的计算机都有硬盘和光驱，可以判定，最后一个盘的类型为1，就是U盘。

反正我是测试过的， U 盘不一定是最后一个。

而且还不算“先插优盘，后插移动硬盘”，我这里说的“移动硬盘”是用“笔记本硬盘”+“移动硬盘盒”组成的。还有 5寸盘的硬盘+移动硬盘盒  组成的盘符。这样得道的盘符排列，能得到最后一个盘符是 U盘吗？

是有这个问题。

那你就用7楼的代码试试，不会有任何问题的。

    移动硬盘的类型是 2 ，网络盘的类型是 3

厉害啊！原来还可以这样！

测试完全通过！

Private Sub Workbook_Open()
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
            s = 682417999 'U盘序列号
            Exit Sub
        End If
    Next
    If s = "" Then
        MsgBox "找不到密钥盘，系统将退出。"
        ThisWorkbook.Close False
    End If
End Sub

下面是检查U盘序列号的代码

Sub 检查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(StrDriveArray(StartPos))
        If d.DriveType = 1 Then
            s = d.serialnumber
            Exit For
        End If
    Next
    If s <> "" Then
        MsgBox "U盘序列号:" & s
    Else
        MsgBox "没有找到U盘!"
    End If
End Sub