I wrote applications in VB6, and an Outlook VSTO addin (in VB.NET) that communicate directly with the VB6 App.
Based on email in Outlook, I wanted to send information to be shown in the VB6 app.
2 ways to do it
1) communication with files (and the VB6 pool for the files), but it is not the best way to do it.
2) Using IPC (Inter Process Communication) where the VSTO send a message to the VB6 App.
So here is the code of the VSTO addin that send a message to the VB6 App
And here is the code in VB6 App that manage the reception of the message
For that, I use Subclassing.
NB : It is not working in IDE, only in compiled app
Add a module for Subclassing and paste the code (coming from wqweto)
In the main Form
add the declaration
In the Form_load
Add the procedure
Create a new module that will contains the code for managing IPC messages
Finally a sampleshowing how to send a message from the VSTO addin to the VB6 Application
Based on email in Outlook, I wanted to send information to be shown in the VB6 app.
2 ways to do it
1) communication with files (and the VB6 pool for the files), but it is not the best way to do it.
2) Using IPC (Inter Process Communication) where the VSTO send a message to the VB6 App.
So here is the code of the VSTO addin that send a message to the VB6 App
Code:
Imports System.Runtime.InteropServices
Friend Module Module_Communication
Private Const WM_COPYDATA As Integer = &H4A
<StructLayout(LayoutKind.Sequential)>
Private Structure COPYDATASTRUCT
Public dwData As IntPtr
Public cbData As Integer
Public lpData As String
End Structure
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Unicode)>
Private Function FindWindow(
ByVal lpClassName As String,
ByVal lpWindowName As String) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Private Function SendMessage(
ByVal hWnd As HandleRef,
ByVal Msg As UInteger,
ByVal wParam As IntPtr,
ByRef lParam As COPYDATASTRUCT) As IntPtr
End Function
Public Function IPC_MyApp_SendText(sData As String) As Long
Dim cds As COPYDATASTRUCT
Dim wParam As IntPtr = frmProgress.Handle
' *** Find App Window we want to send text to...
Dim Rx_Window As IntPtr
Rx_Window = FindWindow(vbNullString, "MyApp")
If Rx_Window <> IntPtr.Zero Then ' make sure window was found
Dim href As New HandleRef(frmProgress, Rx_Window)
cds.dwData = CType(3, IntPtr) ' NOTE: Using an indentifier of 3 for our MyApp Communication
cds.lpData = sData
cds.cbData = cds.lpData.Length + 1
Call SendMessage(href, WM_COPYDATA, wParam, cds)
GC.KeepAlive(frmProgress)
Return 1
Else
Return 0
End If
End Function
End ModuleFor that, I use Subclassing.
NB : It is not working in IDE, only in compiled app
Add a module for Subclassing and paste the code (coming from wqweto)
Code:
'=========================================================================
'
' MST Project (c) 2019 by wqweto@gmail.com
'
' The Modern Subclassing Thunk (MST) for VB6
'
' This project is licensed under the terms of the MIT license
' See the LICENSE file in the project root for more information
'
'=========================================================================
Option Explicit
DefObj A-Z
'Private Const MODULE_NAME As String = "mdModernSubclassing"
#Const ImplNoIdeProtection = (MST_NO_IDE_PROTECTION <> 0)
#Const ImplSelfContained = True
'=========================================================================
' API
'=========================================================================
Private Const SIGN_BIT As Long = &H80000000
Private Const PTR_SIZE As Long = 4
'--- for thunks
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const CRYPT_STRING_BASE64 As Long = 1
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryA" (ByVal pszString As String, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, pcbBinary As Long, Optional ByVal pdwSkip As Long, Optional ByVal pdwFlags As Long) As Long
Private 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
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcByOrdinal Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcOrdinal As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#If Not ImplNoIdeProtection Then
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
#End If
#If ImplSelfContained Then
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
#End If
'=========================================================================
' Functions
'=========================================================================
Public Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As frmMain
Const STR_THUNK As String = "6AAAAABag+oFV4v6ge9QEMEAgcekEcEAuP9EJAS5+QcAAPOri8LB4AgFuQAAAKuLwsHoGAUAjYEAq7gIAAArq7hEJASLq7hJCIsEq7iBi1Qkq4tEJAzB4AIFCIkCM6uLRCQMweASBcDCCACriTrHQgQBAAAAi0QkCIsAiUIIi0QkEIlCDIHqUBDBAIvCBTwRwQCri8IFUBHBAKuLwgVgEcEAq4vCBYQRwQCri8IFjBHBAKuLwgWUEcEAq4vCBZwRwQCri8IFpBHBALn5BwAAq4PABOL6i8dfgcJQEMEAi0wkEIkRK8LCEAAPHwCLVCQE/0IEi0QkDIkQM8DCDABmkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEg/gAfgPCBABZWotCDGgAgAAAagBSUf/gZpC4AUAAgMIIALgBQACAwhAAuAFAAIDCGAC4AUAAgMIkAA==" ' 25.3.2019 14:01:08
Const THUNK_SIZE As Long = 16728
Dim hThunk As Long
Dim lSize As Long
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If hThunk = 0 Then
Exit Function
End If
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
lSize = CallWindowProc(hThunk, ObjPtr(pObj), MethodParamCount, GetProcAddress(GetModuleHandle("kernel32"), "VirtualFree"), VarPtr(InitAddressOfMethod))
Debug.Assert lSize = THUNK_SIZE
End Function
Public Function InitSubclassingThunk(ByVal hWnd As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
Const STR_THUNK As String = "6AAAAABag+oFgepwEB4BV1aLdCQUg8YIgz4AdC+L+oHHABIeAYvCBQgRHgGri8IFRBEeAauLwgVUER4Bq4vCBXwRHgGruQkAAADzpYHCABIeAVJqGP9SEFqL+IvCq7gBAAAAqzPAq4tEJAyri3QkFKWlg+8YagBX/3IM/3cM/1IYi0QkGIk4Xl+4NBIeAS1wEB4BwhAAZpCLRCQIgzgAdSqDeAQAdSSBeAjAAAAAdRuBeAwAAABGdRKLVCQE/0IEi0QkDIkQM8DCDAC4AkAAgMIMAJCLVCQE/0IEi0IEwgQADx8Ai1QkBP9KBItCBHUYiwpS/3EM/3IM/1Eci1QkBIsKUv9RFDPAwgQAkFWL7ItVGIsKi0EshcB0OFL/0FqJQgiD+AF3VIP4AHUJgX0MAwIAAHRGiwpS/1EwWoXAdTuLClJq8P9xJP9RKFqpAAAACHUoUjPAUFCNRCQEUI1EJARQ/3UU/3UQ/3UM/3UI/3IQ/1IUWVhahcl1EYsK/3UU/3UQ/3UM/3UI/1EgXcIYAA==" ' 1.4.2019 11:41:46
Const THUNK_SIZE As Long = 452
Static hThunk As Long
Dim aParams(0 To 10) As Long
Dim lSize As Long
aParams(0) = ObjPtr(pObj)
aParams(1) = pfnCallback
#If ImplSelfContained Then
If hThunk = 0 Then
hThunk = pvThunkGlobalData("InitSubclassingThunk")
End If
#End If
If hThunk = 0 Then
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If hThunk = 0 Then
Exit Function
End If
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
Call DefSubclassProc(0, 0, 0, 0) '--- load comctl32
aParams(4) = GetProcByOrdinal(GetModuleHandle("comctl32"), 410) '--- 410 = SetWindowSubclass ordinal
aParams(5) = GetProcByOrdinal(GetModuleHandle("comctl32"), 412) '--- 412 = RemoveWindowSubclass ordinal
aParams(6) = GetProcByOrdinal(GetModuleHandle("comctl32"), 413) '--- 413 = DefSubclassProc ordinal
'--- for IDE protection
Debug.Assert pvGetIdeOwner(aParams(7))
If aParams(7) <> 0 Then
aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
End If
#If ImplSelfContained Then
pvThunkGlobalData("InitSubclassingThunk") = hThunk
#End If
End If
lSize = CallWindowProc(hThunk, hWnd, 0, VarPtr(aParams(0)), VarPtr(InitSubclassingThunk))
Debug.Assert lSize = THUNK_SIZE
End Function
Public Function CallNextSubclassProc(pSubclass As IUnknown, ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#If pSubclass Then '--- touch args
#End If
CallNextSubclassProc = DefSubclassProc(hWnd, wMsg, wParam, lParam)
End Function
Public Function InitHookingThunk(ByVal idHook As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
Const STR_THUNK As String = "6AAAAABag+oFgepwECQAV1aLdCQUg8YIgz4AdCqL+oHHOBIkAIvCBVQRJACri8IFkBEkAKuLwgWgESQAqzPAq7kJAAAA86WBwjgSJABSahj/UhBai/iLwqu4AQAAAKszwKuri3QkFKWlg+8Yi0oM/0IMgWIM/wAAAI0Eyo0EyI1MiDTHAf80JLiJeQTHQQiJRCQEi8ItOBIkAAXEESQAUMHgCAW4AAAAiUEMWMHoGAUA/+CQiUEQ/3QkEGoAUf90JBiLD/9RGIlHDItEJBiJOF5fuGwSJAAtcBAkAAUAFAAAwhAAi0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1FIsK/3IM/1Eci1QkBIsKUv9RFDPAwgQAkFWL7ItVCIsKi0EshcB0KlL/0FqJQgiD+AF3Q4sKUv9RMFqFwHU4iwpSavD/cST/UShaqQAAAAh1JVIzwFBQjUQkBFCNRCQEUP91FP91EP91DP9yEP9SFFlYWoXJdRGLCv91FP91EP91DP9yDP9RIF3CEACQ" ' 1.4.2019 11:43:54
Const THUNK_SIZE As Long = 5628
Static hThunk As Long
Dim aParams(0 To 10) As Long
Dim lSize As Long
aParams(0) = ObjPtr(pObj)
aParams(1) = pfnCallback
#If ImplSelfContained Then
If hThunk = 0 Then
hThunk = pvThunkGlobalData("InitHookingThunk")
End If
#End If
If hThunk = 0 Then
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If hThunk = 0 Then
Exit Function
End If
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
aParams(4) = GetProcAddress(GetModuleHandle("user32"), "SetWindowsHookExA")
aParams(5) = GetProcAddress(GetModuleHandle("user32"), "UnhookWindowsHookEx")
aParams(6) = GetProcAddress(GetModuleHandle("user32"), "CallNextHookEx")
'--- for IDE protection
Debug.Assert pvGetIdeOwner(aParams(7))
If aParams(7) <> 0 Then
aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
End If
#If ImplSelfContained Then
pvThunkGlobalData("InitHookingThunk") = hThunk
#End If
End If
lSize = CallWindowProc(hThunk, idHook, App.ThreadID, VarPtr(aParams(0)), VarPtr(InitHookingThunk))
Debug.Assert lSize = THUNK_SIZE
End Function
Public Function CallNextHookProc(pHook As IUnknown, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lPtr As Long
lPtr = ObjPtr(pHook)
If lPtr <> 0 Then
Call CopyMemory(lPtr, ByVal (lPtr Xor SIGN_BIT) + 12 Xor SIGN_BIT, PTR_SIZE)
End If
CallNextHookProc = CallNextHookEx(lPtr, nCode, wParam, lParam)
End Function
Public Function InitFireOnceTimerThunk(pObj As Object, ByVal pfnCallback As Long, Optional Delay As Long) As IUnknown
Const STR_THUNK As String = "6AAAAABag+oFgeogERkAV1aLdCQUg8YIgz4AdCqL+oHHBBMZAIvCBSgSGQCri8IFZBIZAKuLwgV0EhkAqzPAq7kIAAAA86WBwgQTGQBSahj/UhBai/iLwqu4AQAAAKszwKuri3QkFKWlg+8Yi0IMSCX/AAAAUItKDDsMJHULWIsPV/9RFDP/62P/QgyBYgz/AAAAjQTKjQTIjUyIMIB5EwB101jHAf80JLiJeQTHQQiJRCQEi8ItBBMZAAWgEhkAUMHgCAW4AAAAiUEMWMHoGAUA/+CQiUEQiU8MUf90JBRqAGoAiw//URiJRwiLRCQYiTheX7g0ExkALSARGQAFABQAAMIQAGaQi0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1HYtCDMZAEwCLCv9yCGoA/1Eci1QkBIsKUv9RFDPAwgQAi1QkBIsKi0EohcB0J1L/0FqD+AF3SYsKUv9RLFqFwHU+iwpSavD/cSD/USRaqQAAAAh1K4sKUv9yCGoA/1EcWv9CBDPAUFT/chD/UhSLVCQIx0IIAAAAAFLodv///1jCFABmkA==" ' 27.3.2019 9:14:57
Const THUNK_SIZE As Long = 5652
Static hThunk As Long
Dim aParams(0 To 9) As Long
Dim lSize As Long
aParams(0) = ObjPtr(pObj)
aParams(1) = pfnCallback
#If ImplSelfContained Then
If hThunk = 0 Then
hThunk = pvThunkGlobalData("InitFireOnceTimerThunk")
End If
#End If
If hThunk = 0 Then
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If hThunk = 0 Then
Exit Function
End If
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
aParams(4) = GetProcAddress(GetModuleHandle("user32"), "SetTimer")
aParams(5) = GetProcAddress(GetModuleHandle("user32"), "KillTimer")
'--- for IDE protection
Debug.Assert pvGetIdeOwner(aParams(6))
If aParams(6) <> 0 Then
aParams(7) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
aParams(8) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
End If
#If ImplSelfContained Then
pvThunkGlobalData("InitFireOnceTimerThunk") = hThunk
#End If
End If
lSize = CallWindowProc(hThunk, 0, Delay, VarPtr(aParams(0)), VarPtr(InitFireOnceTimerThunk))
Debug.Assert lSize = THUNK_SIZE
End Function
Property Get ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long) As Long
Dim lPtr As Long
lPtr = ObjPtr(pThunk)
If lPtr <> 0 Then
Call CopyMemory(ThunkPrivateData, ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, PTR_SIZE)
End If
End Property
Property Let ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long, ByVal lValue As Long)
Dim lPtr As Long
lPtr = ObjPtr(pThunk)
If lPtr <> 0 Then
Call CopyMemory(ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, lValue, PTR_SIZE)
End If
End Property
Public Function InitCleanupThunk(ByVal hHandle As Long, sModuleName As String, sProcName As String) As IUnknown
Const STR_THUNK As String = "6AAAAABag+oFgepQEDwBV1aLdCQUgz4AdCeL+oHHPBE8AYvCBcwQPAGri8IFCBE8AauLwgUYETwBq7kCAAAA86WBwjwRPAFSahD/Ugxai/iLwqu4AQAAAKuLRCQMq4tEJBCrg+8Qi0QkGIk4Xl+4UBE8AS1QEDwBwhAAkItEJAiDOAB1KoN4BAB1JIF4CMAAAAB1G4F4DAAAAEZ1EotUJAT/QgSLRCQMiRAzwMIMALgCQACAwgwAkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEdRL/cgj/UgyLVCQEiwpS/1EQM8DCBAAPHwA=" ' 25.3.2019 14:03:56
Const THUNK_SIZE As Long = 256
Static hThunk As Long
Dim aParams(0 To 1) As Long
Dim pfnCleanup As Long
Dim lSize As Long
#If ImplSelfContained Then
If hThunk = 0 Then
hThunk = pvThunkGlobalData("InitCleanupThunk")
End If
#End If
If hThunk = 0 Then
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If hThunk = 0 Then
Exit Function
End If
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
aParams(0) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
aParams(1) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
#If ImplSelfContained Then
pvThunkGlobalData("InitCleanupThunk") = hThunk
#End If
End If
If Left$(sProcName, 1) = "#" Then
pfnCleanup = GetProcByOrdinal(GetModuleHandle(sModuleName), Mid$(sProcName, 2))
Else
pfnCleanup = GetProcAddress(GetModuleHandle(sModuleName), sProcName)
End If
If pfnCleanup <> 0 Then
lSize = CallWindowProc(hThunk, hHandle, pfnCleanup, VarPtr(aParams(0)), VarPtr(InitCleanupThunk))
Debug.Assert lSize = THUNK_SIZE
End If
End Function
Private Function pvGetIdeOwner(hIdeOwner As Long) As Boolean
#If Not ImplNoIdeProtection Then
Dim lProcessId As Long
Do
hIdeOwner = FindWindowEx(0, hIdeOwner, "IDEOwner", vbNullString)
Call GetWindowThreadProcessId(hIdeOwner, lProcessId)
Loop While hIdeOwner <> 0 And lProcessId <> GetCurrentProcessId()
#End If
pvGetIdeOwner = True
End Function
#If ImplSelfContained Then
Private Property Get pvThunkGlobalData(sKey As String) As Long
Dim sBuffer As String
sBuffer = String$(50, 0)
Call GetEnvironmentVariable("_MST_GLOBAL" & App.hInstance & "_" & sKey, sBuffer, Len(sBuffer) - 1)
pvThunkGlobalData = Val(Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1))
End Property
Private Property Let pvThunkGlobalData(sKey As String, ByVal lValue As Long)
Call SetEnvironmentVariable("_MST_GLOBAL" & App.hInstance & "_" & sKey, lValue)
End Property
#End IfIn the main Form
add the declaration
Code:
Private m_pSubclass As IUnknownCode:
If Not InDesignMode() Then Set m_pSubclass = InitSubclassingThunk(hWnd, Me, InitAddressOfMethod(Me, 5).MyApp_Subclass(0, 0, 0, 0, 0))Add the procedure
Code:
Public Function MyApp_Subclass(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) As Long
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 10/02/2019
' * Time : 17:56
' * Module Name : frmMain
' * Module Filename : Main.frm
' * Procedure Name : MyApp_Subclass
' * Purpose :
' * Parameters :
' * ByVal hWnd As Long
' * ByVal wMsg As Long
' * ByVal wParam As Long
' * ByVal lParam As Long
' * Handled As Boolean
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
#If hWnd And wParam And Handled Then '--- touch args
#End If
Select Case wMsg
Case WM_COPYDATA
Call Communication_Received(lParam)
Handled = True
End Select
End FunctionCreate a new module that will contains the code for managing IPC messages
Code:
Option Explicit
Private Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Public Const WM_COPYDATA = &H4A
'' *** Copies a block of memory from one location to another.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Public Function StringItem(sDelimString As String, sDelim As String, ByVal lItemIndex As Long, Optional sDefault As String = vbNullString) As String
' #VBIDEUtils#***********************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 02/12/2001
' * Time : 15:28
' * Module Name : Lib_Module
' * Module Filename : Lib.bas
' * Procedure Name : StringItem
' * Purpose :
' * Parameters :
' * sDelimString As String
' * sDelim As String
' * ByVal lItemIndex As Long
' * Optional sDefault As String = vbNullString
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim asItems() As String
Dim lUbound As Long
asItems = Split(sDelimString, sDelim)
lUbound = UBound(asItems)
lItemIndex = lItemIndex - 1
If lUbound >= lItemIndex Then
StringItem = asItems(lItemIndex)
Else
StringItem = sDefault
End If
End Function
Sub Communication_Received(lParam As Long)
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 08/28/2019
' * Time : 13:23
' * Module Name : Communication_Module
' * Module Filename : Communication.bas
' * Procedure Name : Communication_Received
' * Purpose :
' * Parameters :
' * lParam As Long
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_Communication_Received
Dim cds As COPYDATASTRUCT
Dim buf(1 To 255) As Byte
Dim sMessage As String
Dim sCommand As String
dim sData as String
Call CopyMemory(cds, ByVal lParam, Len(cds))
Select Case cds.dwData
Case 1:
'MsgBox "got a 1"
Case 2:
'MsgBox "got a 2"
Case 3: ' *** VSTO Addin Communication
Call CopyMemory(buf(1), ByVal cds.lpData, cds.cbData)
sMessage = StrConv(buf, vbUnicode)
sMessage = Left$(sMessage, InStr(1, sMessage, Chr$(0)) - 1)
sCommand = StringItem(sMessage, ":", 1)
sData = StringItem(sMessage, ":", 2)
' *** We Manage the message
' *** and we do the needed work
Select Case sMessage
Case "ShowMessage"
Msgbox sData
Case "yyyy"
End Select
End Select
EXIT_Communication_Received:
On Error Resume Next
Exit Sub
' #VBIDEUtilsERROR#
ERROR_Communication_Received:
Resume EXIT_Communication_Received
End SubFinally a sampleshowing how to send a message from the VSTO addin to the VB6 Application
Code:
Call IPC_MyApp_SendText("ShowMessage:This is great")