VB 进程间通信，进程间发送字符串，不使用通信控件

3721

和大家交流技术，疏漏之处，欢迎指正。


Option Explicit
'*************************************************************************
'**模 块 名：接收数据
'**说    明：接收读取字符串数据
'**创 建 人：LionKing1990
'**日    期：2010年3月19日
'**版    本：V1.0
'**备    注：'部分API被我动过手术了 , 跟API浏览器里面不太一样
'*************************************************************************
'投递一条消息
Private Declare Function SendMessage Lib "user32" Alias " ostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'自定义的消息
Private Const WM_USER = &H400
Private Const Msg_GetAddress = WM_USER + 1
Private Const Msg_GetData = WM_USER + 2
Private Const Msg_AddressReady = WM_USER + 3
'HOOK,很方便
Private WithEvents Hook As cSubclass
'读写的字节数据
Private StrData() As Byte
Private Sub Hook_MsgCome(ByVal bBefore As Boolean, bHandled As Boolean, lReturn As Long, lng_hWnd As Long, uMsg As Long, wParam As Long, lParam As Long)
    If bBefore Then
        Select Case uMsg
            Case Msg_GetAddress
                ' wParam 请求者句柄
                ' lParam 申请的长度
                '重定义长度
                ReDim StrData(0 To lParam - 1)
                '给请求者发送一条信息，告知句柄及已初始化地址
                '       请求者句柄,消息名称,接收者句柄(自己),申请的内存地址
                SendMessage wParam, Msg_AddressReady, lng_hWnd, VarPtr(StrData(0))
            Case Msg_GetData
                ' wParam 地址
                ' lParam 长度
                Dim S As String
                '转换为Unicode编码字符串
                S = StrConv(StrData, vbUnicode)
                '输出
                Text1.Text = Text1.Text & vbNewLine & Time & ":" & S
        End Select
    End If
End Sub
'HOOK开始及结束
Private Sub Form_Load()
    Set Hook = New cSubclass
    Hook.AddWindowMsgs Me.hwnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Hook.DeleteWindowMsg Me.hwnd
End Sub

发送数据的窗体代码
Option Explicit
'*************************************************************************
'**模 块 名：发送数据
'**说    明：根据窗体标题确定发送对象,对其发送字符串
'**创 建 人：LionKing1990
'**日    期：2010年3月19日
'**版    本：V1.0
'**备    注：'部分API被我动过手术了 , 跟API浏览器里面不太一样
'*************************************************************************
'查找窗口及进程
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'其实是PostMessage,不需要立即返回,'投递一条消息
Private Declare Function SendMessage Lib "user32" Alias " ostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'读写进程
Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'自定义的消息
Private Const WM_USER = &H400
Private Const Msg_GetAddress = WM_USER + 1
Private Const Msg_GetData = WM_USER + 2
Private Const Msg_AddressReady = WM_USER + 3
'HOOK,很方便
Private WithEvents Hook As cSubclass
'消息处理
Private Sub Hook_MsgCome(ByVal bBefore As Boolean, bHandled As Boolean, lReturn As Long, lng_hWnd As Long, uMsg As Long, wParam As Long, lParam As Long)
If bBefore Then
    Select Case uMsg
    Case Msg_AddressReady
        '内存申请完毕,并得到地址,开始写入
        WriteData wParam, lParam
    Case Else
    End Select
End If
End Sub
'写入数据
Private Sub WriteData(ByVal hW As Long, ByVal Address As Long)
    Dim PID As Long
    Dim hP As Long
    Dim By() As Byte
    Dim nSize As Long
    Dim Rt As Long
    '取得PID
    GetWindowThreadProcessId hW, PID
    '打开进程
    hP = OpenProcess(PROCESS_ALL_ACCESS, False, PID)
    If hP = 0 Then MsgBox "打开失败": Exit Sub
    '字符串转换为字节数组
    By = StrConv(Text1.Text, vbFromUnicode)
    '获取长度
    nSize = UBound(By) + 1
    '写入内存
    Call WriteProcessMemory(hP, Address, By(0), nSize, Rt)
    '调试
    Debug.Print "需要写入"; nSize, "实际写入"; Rt
    '写入失败就不用再继续了
    If Rt = 0 Then Exit Sub
    '清除数据
    Erase By
    '重定义
    ReDim By(nSize)
    '读出,查看是否成功
    Call ReadProcessMemory(hP, Address, By(0), nSize, Rt)
    '调试
    Debug.Print "需要读妯"; nSize, "实际读出"; Rt
    Debug.Print StrConv(By, vbUnicode)
    '关闭进程句柄
    CloseHandle hP
    '一切正常,通知目标查看数据
    SendMessage hW, Msg_GetData, Address, ByVal nSize
End Sub
Private Sub Command1_Click()
    Dim hW As Long '句柄
    Dim nSize As Long
    Dim By() As Byte
    '查找窗口
    hW = FindWindow(vbNullString, "接收数据")
    If hW = 0 Then MsgBox "未找到窗口": Exit Sub
    '转换字符串
    By = StrConv(Text1.Text, vbFromUnicode)
    '取得字符串的字节大小
    nSize = UBound(By) + 1
    '发送信息,申请数据空间及空间地址
    '          句柄,消息名,请求方句柄(自己),需要的字节长度
    SendMessage hW, Msg_GetAddress, Me.hwnd, ByVal nSize
End Sub
'HOOK开始及结束
Private Sub Form_Load()
    Text1.Text = "作者 ionking1990"
    Set Hook = New cSubclass
    Hook.AddWindowMsgs Me.hwnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Hook.DeleteWindowMsg Me.hwnd
End Sub
'回车发送
Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then Command1_Click
End Sub

伤残

表示不懂、{:3_227:}

艺术就是爆炸

看不懂

胡子

表示不懂、{:3_227:}

wangdy

非常感谢