[摘抄]VBA的⼀些应⽤（U盘序列号作密码，定时删除⽂件等
操作）
注：本⽂只摘抄原⽂的⼀部分
不做技术了，但是经常⽤EXCEL处理数据，今天到点有意思的东西，记录之，以后就⽤这⽅法来保密⾃⼰的信息，唬唬其他⼈吧。
1-19⽤U盘系列号做⼯作薄打开密码
Private Sub Workbook_Open()
visual basic还有人用Call U盘锁代码
End Sub
Sub U盘锁代码()
Dim fs, d, s$
On Error Resume Next
For i = 3 To 26 ‘26个字母
Set fs = CreateObject("scripting.filesystemobjEct")
Set d = fs.getdrive(Chr(64 + i) & ":")
s = d.SERIALNUMBER ‘取得驱动器的系列号
Select Case s
Case "134374432" 'U盘系列号
MsgBox "成功打开"
Exit Sub
End Select
Set fs = Nothing
Set d = Nothing
Next
ThisWorkbook.Close False
End Sub
注释1：
注释2：
Workbook.Close ⽅法 ：关闭对象。
语法：表达式.Close(SaveChanges, Filename, RouteWorkbook)
表达式 ⼀个代表 Workbook 对象的变量。
参数
名称 必选/可选 数据类型 描述
SaveChanges 可选 Variant 如果⼯作簿中没有改动，则忽略此参数。如果⼯作簿中有改动但⼯作簿显⽰
在其他打开的窗⼝中，则忽略此参数。如果⼯作簿中有改动且⼯作簿未显⽰在任何其他打开的窗⼝中，则由此参数指定是否应保存更改。如果设为 True，则保存对⼯作簿所做的更改。如果⼯作簿尚未命名，则使⽤ FileName。如果省略 Filename，则要求⽤户提供⽂件名。
Filename 可选 Variant 以此⽂件名保存所做的更改。
RouteWorkbook 可选 Variant 如果⼯作簿不需要传送给下⼀个收件⼈（没有传送名单或已经传送），则忽略此参数。否则，Microsoft Excel 根据此参数的值传送⼯作簿。如果设为 True，则将⼯作簿传送给下⼀个收件⼈。如果设为 False，则不发送⼯作簿。如果忽略，则要求⽤户确认是否发送⼯作簿。
说明：从 Visual Basic 关闭⼯作簿并不运⾏该⼯作簿中的任何 Auto_Close 宏。使⽤ RunAutoMacros ⽅法可运⾏⾃动关闭宏。
⽰例：此⽰例关闭 Book1.xls，并放弃所有对此⼯作簿的更改。
Visual Basic for Applications
Workbooks("BOOK1.XLS").Close SaveChanges:=False
获取所有磁盘序列
Sub 获取所有磁盘序列号()
Dim fs, d, aa As String, b As String, c As String
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For i = 1 To 26
bb:
aa = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
b = Mid(aa, i, 1)
Set d = fs.getdrive(fs.GetDriveName(fs.GetAbsolutePathName(b & ":")))
If Err.Number = 68 Then
s = b & "：盘未准备好"
Err.Clear
GoTo aa
End If
Select Case d.DriveType
Case 0: t = "Unknown"
Case 1: t = "Removable"
Case 2: t = "Fixed"
Case 3: t = "Network"
Case 4: t = "CD-ROM"
Case 5: t = "RAM Disk"
End Select
s = "磁盘: " & d.DriveLetter & " 类型:" & t & " 序列号: " & d.SERIALNUMBER
aa:
c = c & s & Chr(10)
Next i
MsgBox c, 64, "andysky提⽰你"
End Sub
改进型U盘锁保护
Sub U盘锁()
Dim fs, s$
On Error Resume Next
Set fs = CreateObject("scripting.filesystemobjEct")
For Each DRI In fs.DRIVES
s = DRI.SERIALNUMBER
If s = "134374432" Then 'U盘系列号
MsgBox "打开成功"
Set fs = Nothing
Exit Sub
End If
Next
Set fs = Nothing
MsgBox "打开失败"
ThisWorkbook.Close False
End Sub
1.10⽤程序打开指定⽂件夹
Sub 打开指定⽂件夹()
Dim Ret
Ret = Shell(＂＂ & ThisWorkbook.Path & "\A\", vbNormalFocus)
End Sub
Shell 函数：执⾏⼀个可执⾏⽂件，返回⼀个 Variant (Double)，如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。 语法：Shell(pathname[,windowstyle])
Shell 函数的语法含有下⾯这些命名参数：
部分 描述
pathname 必要参数。Variant (String)，要执⾏的程序名，以及任何必需的参数或命令⾏变量，可能还包括⽬录或⽂件夹，以及驱动器。在Macintosh中，可以使⽤MacID函数来指定⼀个应⽤程序的署名⽽不是
名称。下⾯的例⼦使⽤了Microsoft Word的署名: Shell
MacID("MSWD")
Windowstyle 可选参数。Variant (Integer)，表⽰在程序运⾏时窗⼝的样式。如果 windowstyle 省略，则程序是以具有焦点的最⼩化窗⼝来执⾏的。在Macintosh（系统7.0或更⾼）中，windowstyle仅决定当应⽤程序运⾏时是否获得焦点。
windowstyle 命名参数有以下这些值：
常量 值 描述
vbHide 0 窗⼝被隐藏，且焦点会移到隐式窗⼝。常数vbHide在Macintosh平台不可⽤。
VbNormalFocus 1 窗⼝具有焦点，且会还原到它原来的⼤⼩和位置。
VbMinimizedFocus 2 窗⼝会以⼀个具有焦点的图标来显⽰。
VbMaximizedFocus 3 窗⼝是⼀个具有焦点的最⼤化窗⼝。
VbNormalNoFocus 4 窗⼝会被还原到最近使⽤的⼤⼩和位置，⽽当前活动的窗⼝仍然保持活动。
VbMinimizedNoFocus 6 窗⼝会以⼀个图标来显⽰。⽽当前活动的的窗⼝仍然保持活动。
说明
如果 Shell 函数成功地执⾏了所要执⾏的⽂件，则它会返回程序的任务 ID。任务 ID 是⼀个唯⼀的数值，⽤来指明正在运⾏的程序。如果Shell 函数不能打开命名的程序，则会产⽣错误。
在Macintosh中，vbNormalFocus、vbMinimizedFocus和vbMaximizedFocus都将应⽤程序置于前台；vbHide、vbNoFocus、vbMinimizeFocus都将应⽤程序置于后台。
注意 缺省情况下，Shell 函数是以异步⽅式来执⾏其它程序的。也就是说，⽤ Shell 启动的程序可能还没有完成执⾏过程，就已经执⾏到Shell 函数之后的语句。
1.14定时“⾃杀”的Excel⽂件
Private Sub Workbook_Open()
If Now() >= #9/15/2006# Then ‘时间格式必须在前后加“#”号
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
Application.Quit
End If
End Sub
Workbook.ChangeFileAccess ⽅法 ：更改⼯作簿的访问权限。本⽅法需要从磁盘加载⼯作簿的更新版本。
语法：表达式.ChangeFileAccess(Mode, WritePassword, Notify)
表达式 ⼀个代表 Workbook 对象的变量。
参数
名称 必选/可选 数据类型 描述
Mode 必选 XlFileAccess 指定新的访问模式。
WritePassword 可选 Variant 如果⽂件设置了写保护并且 Mode 为 xlReadWrite，则指定写保护密码。如果⽂件没有密码或 Mode 为xlReadOnly，则忽略此参数。
Notify 可选 Variant 如果该值为 True（或省略该参数），则当⽆法⽴即访问⽂件时通知⽤户。
说明：如果以只读模式打开⽂件，则不可独占访问此⽂件。如果将此⽂件从只读更改为可读写，Microsoft Excel 必须载⼊该⽂件的新副本以确认在以只读模式打开该⽂件后没有进⾏过更改。
⽰例：本⽰例将活动⼯作簿设为只读。
Visual Basic for Applications
ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
1.15限制Excel⽂件使⽤的次数
Private Sub Workbook_Open()
AAA = GetSetting(appname:="MyApp", section:="Startup", key:="使⽤次数", Default:=1)
MsgBox "你还可以使⽤的次数为" & (20 - AAA) & "次，请尽快和作者联系!"
If AAA = 20 Then
DeleteSetting "MyApp", "Startup"
MsgBox "系统将被删除，感谢您的试⽤!再见"
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ThisWorkbook.Close False
End If
AAA = AAA + 1
SaveSetting "MyApp", "Startup", "使⽤次数", AAA
End Sub
参见实例三_54
1.18只能⾃已电脑上使⽤的Excel⽂件
Private Sub Workbook_Open()
Application.ScreenUpdating = False
On Error GoTo 100
Workbooks.Open ThisWorkbook.Path & "/验证.XLS" ActiveWorkbook.Close False
Exit Sub
100:
MsgBox "你⽆法使⽤该⽂件，请与⽂件作者联系" ThisWorkbook.Close False
Application.ScreenUpdating = True
End Sub
禁⽤了宏⾃动关闭⼯作薄
Function MY()
End Function
=ERROR(FALSE)
=RUN("MY")
=IF(ISERROR($A$3))
=GOTO($A$11)
=END.IF()
=ERROR(TRUE)
=RETURN()
=ALERT("对不起!由于禁⽤了宏，本⽂件将⾃动关闭!",3) =FILE.CLOSE(FALSE)
=RETURN()
发表评论