最近把以前写的一个小程序PClock做了一次更新，以前的程序是程序运行后系统界面锁定，需输入密码方能解锁。这次更新后的效果是，程序运行以后在后台监视空闲的时间（键盘和鼠标无动作），当空闲的时间等于设定时间时Windows系统界面锁定。
就是这么一个小功能的更新，花了我3天的时间，主要原因是走了不少的弯路。在差不多要放弃的时候让我找到了解决的方法。
程序的界面和功能没有太大的改变，以下是程序的ChangeLog：
1、程序的名称从PClock改为PcLocker
2、程序转为后台运行，当系统空闲时锁定Windows系统，类似于进入屏幕保护程序
3、改变了禁用任务管理器的方式
4、实现了手工无法修改配置文件
5、优化并精简了代码
6、程序适用于Windows XP、Windows 7，其他的系统没有测试
7、初始密码123，程序默认空闲启动时间为10分钟，默认随机自启动关闭
源程序的下载地址：点我
下面就是整个程序的源码，主要包括1个模块module1.bas，1个主程序窗口MainForm.frm，1个设置窗口setform.frm
主程序窗口MainForm.frm的代码如下，程序的主要功能集中在此。
'计算空闲时间Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As LongPrivate Declare Function EnableWindow Lib "user32" (ByVal hWnd As Integer, ByVal aBOOL As Integer) As IntegerPrivate Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Integer) As IntegerPrivate Declare Function GetMenu Lib "user32" (ByVal hWnd As Integer) As IntegerPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long'常量声明Const SWP_NOMOVE = &H2 '保持当前位置（x和y设定将被忽略）Const SWP_NOSIZE = &H1 '保持当前大小（cx和cy会被忽略）Const HWND_TOPMOST = -1Const HWND_NOTOPMOST = -2Const flags = SWP_NOMOVE Or SWP_NOSIZE'使用GetLastInputInfo来检测键盘、鼠标无动作Private Declare Function GetLastInputInfo Lib "user32" (plii As LASTINPUTINFO) As BooleanPrivate Declare Function GetTickCount Lib "kernel32" () As LongPrivate Type LASTINPUTINFO cbSize As Long dwTime As LongEnd TypePrivate Sub Form_Load() If App.PrevInstance = True Then '用APP对象的PrevInstance属性，防止同时运行屏幕保护程序的两个实例 Unload Me Exit Sub End If Timer1.Interval = 1000 '读取配置信息 Call GetConfig '打开配置文件,防止手工修改 FileName = App.Path + "\CONFIG" Open FileName For Binary As #99End SubPrivate Sub BntOk_Click() If (Text1.Text = password) Then ' 卸载钩子 UnhookWindowsHookEx lHook Timer1.Enabled = True Me.Visible = False Text1.Text = "" Timer2.Enabled = False Else Label2.Visible = True Label2.Caption = "输入密码不正确，请重新输入！" Text1.Text = "" Text1.SetFocus End IfEnd SubPrivate Sub BntEmpty_Click() Text1.Text = ""End Sub'显示主程序界面Private Sub ShowForm() ' 安装钩子 lHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CallKeyHookProc, App.hInstance, 0) '如果更改的背景文件不存在，或者文件目录为空，则显示默认背景 If (filedir <> "" And Dir(filedir) <> "") Then '开始的时候使用的是改变窗口的默认背景，这样的话这个背景不会被拉伸，只能保持默认大小，舍弃 Me.Picture = LoadPicture(filedir) '现在使用image控件来实现 Image1.Width = Screen.Width Image1.Height = Screen.Height '这里把窗口设为全屏，因为image 要随着窗口变化 Top = 0 Left = 0 Me.Width = Screen.Width Me.Height = Screen.Height Me.Image1.Visible = False Me.Image1.Picture = LoadPicture(filedir) Me.AutoRedraw = True Me.PaintPicture Image1.Picture, 0, 0, Me.ScaleWidth, Me.ScaleHeight End If Me.Show 'setFocus前面须有这个 '设置窗口在最上面 Dim Ok Ok = SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, flags) '设置全屏 Top = 0 Left = 0 Me.Width = Screen.Width Me.Height = Screen.Height '设置输入框的位置 Frame1.Top = Screen.Height - Frame1.Height Frame1.Left = Screen.Width - Frame1.Width Label2.Left = Frame1.Left Label2.Top = Frame1.Top - Label2.Height Label2.Width = Frame1.Width Label2.Visible = False Text1.SetFocus '禁用alt+ctrl+delete 'Open Environ$("WinDir") & "\system32\taskmgr.exe" For Binary As #1 Timer1.Enabled = False Timer2.Enabled = True Text1.SetFocusEnd Sub'设置窗口Private Sub BntSet_Click() If (Text1.Text = password) Then ' 卸载钩子 UnhookWindowsHookEx lHook Me.Visible = False Text1.Text = "" setform.Show Timer1.Enabled = True Else Label2.Visible = True Label2.Caption = "输入密码不正确，请重新输入！" Text1.Text = "" Text1.SetFocus End IfEnd Sub'回车之后的动作Private Sub Text1_KeyPress(KeyAscii As Integer) ' Text1 响应回车键 If KeyAscii = 13 Then If (Text1.Text = password) Then ' 卸载钩子 UnhookWindowsHookEx lHook Me.Visible = False Text1.Text = "" Timer1.Enabled = True Timer2.Enabled = False Else Label2.Visible = True Label2.Caption = "输入密码不正确，请重新输入！" Text1.Text = "" Text1.SetFocus End If End IfEnd Sub'当空闲时间大于IntervalTime时，调用ShowFormPrivate Sub Timer1_Timer() Dim lii As LASTINPUTINFO lii.cbSize = Len(lii) If GetLastInputInfo(lii) Then If (GetTickCount - lii.dwTime)/60000 > IntervalTime Then Call ShowForm End If End IfEnd Sub'禁用任务管理器Private Sub Timer2_Timer() Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHideEnd Sub设置窗口setform.frm的代码，包括密码设置、背景图片设置、开机自启动设置和空闲启动时间设置。
Dim change As BooleanPrivate Sub Command1_Click() '先读出密码 passwordstr = password FileName = App.Path + "\CONFIG" '配置文件路径 '验证密码 If Text1.Text = passwordstr And Text3.Text = Text2.Text Then NewPassword = Encode(Text2.Text) change = SetConfig(NewPassword, 0) '设置以后重新读取配置文件 Call GetConfig If (change = True) Then MsgBox "口令修改成功" Else If Text2.Text <> Text3.Text Then MsgBox "两次口令输入不一致，请重新输入" Else MsgBox "旧口令错，请重新输入" End If End IfEnd SubPrivate Sub Command2_Click() Unload MeEnd SubPrivate Sub Command3_Click() Set w = CreateObject("wscript.shell") w.regwrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe" MsgBox "已经设置为开机自启动"End SubPrivate Sub Command4_Click() Set w = CreateObject("wscript.shell") w.regdelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName MsgBox "已经取消开机自启动"End SubPrivate Sub Command5_Click() CommonDialog1.Filter = "jpg|*.jpg" CommonDialog1.ShowOpen filedir = CommonDialog1.FileName If (filedir <> "") Then change = True change = SetConfig(filedir, 2) '设置以后重新读取配置文件 Call GetConfig If (change = True) Then MsgBox "背景替换成功"End SubPrivate Sub Command6_Click() change = SetConfig("", 2) '设置以后重新读取配置文件 Call GetConfig If (change = True) Then MsgBox "已恢复为默认背景"End SubPrivate Sub Command7_Click() Unload MeEnd SubPrivate Sub IntervalBnt_Click() change = SetConfig(setform.IntervalTxt.Text, 1) '设置以后重新读取配置文件 Call GetConfig If (change = True) Then MsgBox "修改成功"End Sub模块module1.bas代码，主要是禁用键盘和加密函数。
Option ExplicitPublic Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As IntegerPublic Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As LongPublic Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As LongPublic Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As LongPublic Const HC_ACTION = 0Public Const WM_KEYDOWN = &H100Public Const WM_KEYUP = &H101Public Const WM_SYSKEYDOWN = &H104Public Const WM_SYSKEYUP = &H105Public Const VK_TAB = &H9Public Const VK_CONTROL = &H11Public Const VK_ESCAPE = &H1BPublic Const VK_DELETE = &H2EPublic Const WH_KEYBOARD_LL = 13Public Const LLKHF_ALTDOWN = &H20'禁用键盘的功能键Public Type KBDLLHOOKSTRUCT vkCode As Long scanCode As Long flags As Long time As Long dwExtraInfo As LongEnd TypePublic lHook As LongDim p As KBDLLHOOKSTRUCTDim key() As Byte'全局变量Public password As StringPublic IntervalTime As IntegerPublic filedir As StringPublic FileName As String'键盘钩子Public Function CallKeyHookProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim fEatKeystroke As Boolean If (ncode = HC_ACTION) Then If wParam = WM_KEYDOWN Or wParam = WM_SYSKEYDOWN Or wParam = WM_KEYUP Or wParam = WM_SYSKEYUP Then CopyMemory p, ByVal lParam, Len(p) fEatKeystroke = _ ((p.vkCode = VK_TAB) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _ ((p.vkCode = VK_ESCAPE) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _ ((p.flags And LLKHF_ALTDOWN) <> 0) Or _ ((p.vkCode = VK_ESCAPE) And ((GetKeyState(VK_CONTROL) And &H8000) <> 0)) Or _ ((p.vkCode = 91) Or (p.vkCode = VK_ESCAPE) Or (p.vkCode = 92) Or (p.vkCode = 93)) '判断是否按下了：TAB+ALT、Esc+ALT、Alt(Alt+F4)、Esc+Ctrl、左右 Win 和徽标键\Esc End If End If If fEatKeystroke Then ' 设置为 1 可以屏蔽按键 CallKeyHookProc = 1 Else CallKeyHookProc = CallNextHookEx(0, ncode, wParam, ByVal lParam) End IfEnd FunctionSub initkey() '这里为密匙，建议定义的复杂些，我这里仅仅是个示例 ReDim key(9) key(0) = 12 key(1) = 43 key(2) = 53 key(3) = 67 key(4) = 78 key(5) = 82 key(6) = 91 key(7) = 245 key(8) = 218 key(9) = 190 End Sub Function Encode(ByVal s As String) As String '加密 On Error GoTo myerr initkey Dim buff() As Byte buff = StrConv(s, vbFromUnicode) Dim i As Long, j As Long Dim k As Long k = UBound(key) + 1 For i = 0 To UBound(buff) j = i Mod k buff(i) = buff(i) Xor key(j) Next Dim mstr As String mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" Dim outstr As String Dim temps As String For i = 0 To UBound(buff) k = buff(i) \ Len(mstr) j = buff(i) Mod Len(mstr) temps = Mid(mstr, j + 1, 1) + Mid(mstr, k + 1, 1) outstr = outstr + temps Next Encode = outstr Exit Functionmyerr: Encode = "" End Function Function Decode(ByVal s As String) As String '解密 On Error GoTo myerr initkey Dim i As Long, j As Long Dim k As Long, n As Long Dim mstr As String mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" Dim outstr As String Dim temps As String If Len(s) Mod 2 = 1 Then Decode = "" Exit Function End If Dim t1 As String Dim t2 As String Dim buff() As Byte Dim m As Long m = 0 For i = 1 To Len(s) Step 2 t1 = Mid(s, i, 1) t2 = Mid(s, i + 1, 1) j = InStr(1, mstr, t1) k = InStr(1, mstr, t2) n = j - 1 + (k - 1) * Len(mstr) ReDim Preserve buff(m) buff(m) = n m = m + 1 Next k = UBound(key) + 1 For i = 0 To UBound(buff) j = i Mod k buff(i) = buff(i) Xor key(j) Next Decode = StrConv(buff, vbUnicode) Exit Functionmyerr: Decode = ""End Function'配置信息'定义变量，password密码，IntervalTime空闲时间Function GetConfig() Dim s As String, t() As String, a As String FileName = App.Path + "\CONFIG" '如果文件不存在，则创建文件 If Dir(FileName) = "" Then Open FileName For Output As #1 '打开顺序文件，我们可以使用Open语句 a = Encode("123") + vbCrLf + "10" + vbCrLf 'vbCrLf为回车 Print #1, a '写数据 Close #1 '关闭文件 '隐藏文件 'SetAttr FileName, vbSystem Or vbHidden End If Open FileName For Binary As #11 s = Input(LOF(11), #11) Close #11 t = Split(s, vbCrLf) password = Decode(t(0)) IntervalTime = t(1) '第三行是2，第四行是3，类推 filedir = t(2)End FunctionFunction SetConfig(ByVal Value As String, ByVal Weizhi As Integer) As Boolean Close #99 '关闭打开的配置文件 FileName = App.Path + "\CONFIG" Dim s As String, t() As String Open FileName For Binary As #123 s = Input(LOF(123), #123) Close #123 t = Split(s, vbCrLf) t(Weizhi) = Value '第三行是2，第四行是3，类推 s = Join(t, vbCrLf) Kill FileName Open FileName For Binary As #11 Put #11, , s Close #11 SetConfig = True Open FileName For Binary As #99 '打开配置文件,防止手工修改End Function
没有评论:
发表评论