Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal Hkey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As String, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As String, lpcbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
'************注册表操作子过程*************'
Private Sub SetSZ(Hkey As Long, Keypath As String, Keyname As String, Keyvalue As String) '
i = RegOpenKey(Hkey, Keypath, keyid)
j = RegSetValueEx(keyid, Keyname, 0&, &H1, ByVal Keyvalue, Len(Keyvalue))
End Sub
Private Sub CRSZ(Hkey As Long, Keypath As String)
h = RegCreateKey(Hkey, Keypath, keyid)
End Sub
Private Sub SetDWORD(Hkey As Long, Keypath As String, Keyname As String, Keyvalue As Long)
i = RegOpenKey(Hkey, Keypath, keyid)
j = RegSetValueEx(keyid, Keyname, 0&, &H4, Keyvalue, Len(Keyvalue))
End Sub
'*****************************************'
Private Sub Command1_Click()
If Text1 = "" Or Text2 = "" Then
ElseIf Text1 <> Text2 Then
MsgBox "两次密码不一致!", 0 + vbExclamation, "系统提示"
ElseIf Len(Text1) < 6 Then
MsgBox "密码太短!", 0 + vbExclamation, "系统提示"
Else
comm = Command() '接收传参
Call JIAMI(comm) '这是传递的参数
End If
End Sub
Private Sub Command3_Click()
comm = Command()
Call Dkmm(comm)
End Sub
Private Sub Form_Load()
'*****关联程序***
Call CRSZ(HKEY_CLASSES_ROOT, "Folder\shell\JiaMi")
Call CRSZ(HKEY_CLASSES_ROOT, "Folder\shell\JiaMi\Command")
Call SetSZ(HKEY_CLASSES_ROOT, "Folder\shell\JiaMi\Command", "", "C:\windows\ " & "+m %1") '加密关联
Call CRSZ(HKEY_CLASSES_ROOT, "Folder\shell\JieMi")
Call CRSZ(HKEY_CLASSES_ROOT, "Folder\shell\JieMi\Co
mmand")
Call SetSZ(HKEY_CLASSES_ROOT, "Folder\shell\JieMi", "", "文件夹解密(&O) ")
Call SetSZ(HKEY_CLASSES_ROOT, "Folder\shell\JieMi\Command", "", "C:\windows\ " & "-m %1") '解密关联
'****************
On Error Resume Next
App.TaskVisible = False
If App.PrevInstance Then End
comm = Command()
'***************判断是否可加密*************
If Left(comm, 2) = "+m" Then
Me.Caption = "文件夹加密"
If Right(comm, 1) = "\" Then
i = MsgBox("不能给盘符加密！", 0 + vbExclamation, "系统提示")
If i = 1 Then End
End If
If Right(comm, 1) = "." Then
i = MsgBox("该文件夹已加密！", 0 + vbCritical, "系统警告")
If i = 1 Then End
End If
If Trim(Right(comm, 1)) = "" Then
i = MsgBox("不能给系统文件夹加密！", 0 + vbCritical, "系统警告")
If i = 1 Then End
End If
Text3.Visible = False
Command1.Enabled = True
Command3.Visible = False
ElseIf Left(comm, 2) = "-m" Then
Me.Caption = "文件夹解密"
If Right(comm, 1) <> "." Then MsgBox "对不起，该文件夹不能解密！", 0 + vbExclamation, "系统提示": End
'*****************************************
Command1.Visible = False
Command3.Enabled = True
Command2.Enabled = True
Label1(0).Visible = False
Label1(1).Visible = True
Label2.Visible = False
Text1.Visible = False
Text2.Visible = False
ElseIf comm = "" Then
Me.Visible = False
MsgBox "文件夹加密功能已开启，请用鼠标右键加密文件夹！", 0 + vbExclamation, "系统提示"
On Error Resume Next '复制本身
FileCopy App.Path + IIf(Right(App.Path, 1) = "\", "", "\") + App.EXEName + ".exe", "C:\WINDOWS\"
End
End If
Command2.Visible = False
End Sub
Function JIAMI(jia) '加密操作 **********核心***************
Mypath = Mid(jia, 4)
i = 1
Do While Left(Right(Mypath, i), 1) <> "\"
Myname = Left(Right(Mypath, i), 1) & Myname
i = i + 1
Loop
On Error Resume Next
If Right(Myname, 1) = "." Then MsgBox "该文件夹已加密", 0 + vbCritical, "系统提示"
Newpath = Left(Mypath, Len(Mypath) - Len(Myname))
MkDir Newpath & ".' '" & Myname & "' '..\"
SetAttr Mypath, vbHidden + vbSystem
Call Bcmm(Mypath)
Name Mypath As Newpath & ".' '" & Myname & "' '...\" & Myname '这就是用 name 指命 进行移位
l = MsgBox("加密成功!", 0 + vbExclamation, "系统提示"): End
End Function
Function Bcmm(pa) '存放密码 '把密码存放到 desktop_.ini里面
On Error Resume Next
SetAttr pa & "\desktop_.ini", vbNormal
Kill pa & "\desktop_.ini"
Open pa & "\desktop_.ini" For Output As #1
Print #1, Text2
Close #1
SetAttr pa & "\desktop_.ini", vbHidden + vbSystem
End Function
怎么对文件夹加密Function Dkmm(pa) '解密操作
On Error Resume Next
SetAttr "c:\windows\desktop_.ini", vbNormal
Kill "c:\windows\desktop_.ini"
Mypath = Mid(pa, 4)
If Right(Mypath, 2) <> "'." Then MsgBox "对不起，该文件夹不能解密！", 0 + vbCritical, "系统提示": End
i = 1
Do While Left(Right(Mypath, i), 1) <> "\
"
Myname = Left(Right(Mypath, i), 1) & Myname
i = i + 1
Loop
Newpath = Left(Mypath, Len(Mypath) - Len(Myname))
On Error GoTo 3:
Name Mypath & "..\" & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8) & "\desktop_.ini" As "c:\windows\desktop_.ini"
Open "c:\windows\desktop_.ini" For Input As #1 '读取密码
Do While Not EOF(1)
mima = mima + Input(1, #1)
Loop
Close #1
On Error Resume Next
Name "c:\windows\desktop_.ini" As Mypath & "..\" & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8) & "\desktop_.ini"
If Text3 <> Left(mima, Len(mima) - 2) Then
MsgBox "对不起，密码错误！", 0 + vbCritical, "系统提示"
Text3 = ""
Text3.SetFocus
Exit Function
Else
On Error Resume Next '解密文件夹**********核心*************** 这是解密的核心
Name Mypath & "..\" & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8) As Newpath & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8)
3:
RmDir Mypath & ".\"
SetAttr Newpath & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8), vbSystem + vbReadOnly
SetAttr Newpath & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8) & "\desktop_.ini", vbNormal
Kill Newpath & Left(Right(Myname, Len(Myname) - 4), Len(Myname) - 8) & "\desktop_.ini"
MsgBox "解密成功！", 0 + vbExclamation, "系统提示": End
End If
End Function
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Command1_Click
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Call Command3_Click
End Sub
发布评论