Visual Basic Tips

アプリケーション間でメッセージの送受信(API)

長い間暫定版でしたが、先日”RtlMoveMemory”なる関数を見つけやっと実現することができました。

このサンプルの動作ですが、送信側のテキストボックスに文字列を入力すると、受信側のテキストボックスにリアルタイムに出力されます。

'/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_
'/_/
'/_/　送信側アプリケーション
'/_/
'/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_


Private Sub Text1_Change()
　　Dim hWndTo As Long
　　Dim sdtCOPYDATASTRUCT As COPYDATASTRUCT

　　sdtCOPYDATASTRUCT.dwData = 0
　　sdtCOPYDATASTRUCT.cbData = LenB(Text1.Text) + 1
　　If Text1.Text = "" Then
　　　　sdtCOPYDATASTRUCT.lpData = vbNullChar
　　Else
　　　　sdtCOPYDATASTRUCT.lpData = Text1.Text
　　End If
　　hWndTo = FindWindow(vbNullString, "受信フォーム")
　　If hWndTo <> 0 Then
　　　　Call SendMessage(hWndTo, WM_COPYDATA, Me.hwnd, sdtCOPYDATASTRUCT)
　　End If
End Sub

'-------------------------------------------------------
'Module
'-------------------------------------------------------
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const WM_COPYDATA = &H4A

Type COPYDATASTRUCT
　　dwData As Long
　　cbData As Long
　　lpData As String '※注意　送信先はString型にします。
End Type

'/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_
'/_/
'/_/　受信側アプリケーション
'/_/
'/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_


Private Sub Form_Activate()
　　Call Hook(Me.hwnd)
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
　　Call UnHook(Me.hwnd)
End Sub

'-------------------------------------------------------
' Module
'-------------------------------------------------------
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = (-4)

Public Declare 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 Long

Public Const WM_COPYDATA = &H4A

Public phWnd As Long

Public Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal iSize&)

Type COPYDATASTRUCT
　　dwData As Long
　　cbData As Long
　　lpData As Long
End Type

Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
　　Static bolWndProcCheck As Boolean
　　Dim str As String
　　Dim lngret As Long
　　Dim sdtCOPYDATASTRUCT As COPYDATASTRUCT

　　If Not bolWndProcCheck Then
　　　　bolWndProcCheck = True
　　　　Select Case uMsg
　　　　　　Case WM_COPYDATA
　　　　　　　　　Call memcpy(ByVal VarPtr(sdtCOPYDATASTRUCT), ByVal lParam&, LenB(sdtCOPYDATASTRUCT))
　　　　　　　　　str = String$(sdtCOPYDATASTRUCT.cbData, vbNullChar)
　　　　　　　　　Call memcpy(ByVal str, ByVal sdtCOPYDATASTRUCT.lpData, sdtCOPYDATASTRUCT.cbData)
　　　　　　　　　Form1.Text1.Text = str
　　　　End Select
　　　　bolWndProcCheck = False
　　End If
　　WndProc = CallWindowProc(phWnd, hwnd, uMsg, wParam, lParam)
End Function

Public Sub Hook(hwnd As Long)
　　phWnd = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WndProc)
End Sub

Public Sub UnHook(hwnd As Long)
　　Dim lngret As Long
　　If phWnd <> 0 Then
　　　　lngret = SetWindowLong(hwnd, GWL_WNDPROC, phWnd)
　　End If
End Sub


DownLoad vbtips096.lzh 4KB (VB6.0)