Attribute VB_Name = "MsgLink"

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
          (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++©Rd+
'
'                              MsgLink
'
'       To receive messages you must call Hook and therefore must
'       also call Unhook when terminating.
'
'       To send messages only you need not call Hook (or Unhook).
'       This avoids an unneccessary hook to subclass the window
'       procedure.
'
        Private Const MAX_MESSAGES_IN_EACH_QUEUE As Long = 50
'
'       Use error handlers in all procedures that make calls to
'       these functions. If these functions receive invalid
'       arguments they will raise errors to let you know!
'
'       MessageNotify is fired immediately after the calling
'       process has disconnected. You must add code to handle
'       messages received in this sub.
'
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
          (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
          (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
           lParam As Any) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
          (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal wMsg As Long, _
           ByVal wParam As Long, ByRef lParam As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
          (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
           ByVal nIDEvent As Long, ByVal uElapseMilliseconds As Long, _
           ByVal lpTimerFunc As Long) As Long

Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, _
           ByVal nIDEvent As Long) As Long

Private Const GWL_WNDPROC = (-4&)
Private Const WM_COPYDATA = &H4A&
Private Const WM_TIMER = &H113&

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

Private m_PrevWndProc As Long
Private m_Src_hWnd As Long

Private Type MSGINFO
    hWndSrc As Long
    vbDataType As Integer
    idMsgFlag As Integer
    vMsgData As Variant
End Type

Private msgs(1 To MAX_MESSAGES_IN_EACH_QUEUE) As MSGINFO
Private m_Idx As Long

Private Type TwoInts
    lo As Integer
    hi As Integer
End Type

Private Type OneLong
    dw As Long
End Type

' Used to pass UDT arrays
Private m_yaUDT() As Byte

Option Explicit

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' The curly thing here is yet another window hook - but they are
' legal if they unhook in exactly the reverse order they hooked.

Private Function CallbackProc(ByVal hWnd As Long, ByVal wMsg As Long, _
                 ByVal wParam As Long, ByRef lParam As Long) As Long
    ' CallbackProc sub-window proc
    On Error GoTo SkipErr 'safe as, right?
    Select Case wMsg
        Case WM_COPYDATA: Call MessageReceiver(wParam, lParam)
        Case WM_TIMER:    Call MessageNotify(wParam)
    End Select
SkipErr:
    ' This MUST be done
    CallbackProc = CallWindowProc(m_PrevWndProc, hWnd, wMsg, wParam, lParam)

    If (Err) Then Beep: Debug.Print "MsgLink.CallbackProc Error #"; Err; " - "; Err.Description
End Function

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub Hook(ByVal Me_hWnd As Long)
    If (Me_hWnd = 0&) Then Err.Raise 5
    m_Src_hWnd = Me_hWnd
    m_PrevWndProc = SetWindowLong(Me_hWnd, GWL_WNDPROC, AddressOf CallbackProc)
End Sub

Public Sub Unhook()
    If (m_Src_hWnd) Then
        Call SetWindowLong(m_Src_hWnd, GWL_WNDPROC, m_PrevWndProc)
        m_Src_hWnd = 0&
    End If
End Sub

Public Function GetTargetHandle(WindowCaption As String, Optional ClassName As String) As Long
    If LenB(ClassName) Then
        GetTargetHandle = FindWindow(ClassName, WindowCaption)
    Else
        GetTargetHandle = FindWindow(vbNullString, WindowCaption)
    End If
End Function

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'  MessageNotify
'
'   This sub is fired immediately after the calling process has
'   disconnected. You must add code to handle messages received.
'
'   Note - incoming messages that you pass to common functions
'   can hit simultaneously, so if you use static or global
'   variables you may get erroneous results (or worse).
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub MessageNotify(ByVal Id As Long)
    Call KillTimer(m_Src_hWnd, Id)

    Dim str As String: str = vbCrLf & "Msg From: " & msgs(Id).hWndSrc & _
                             vbCrLf & "Msg Flag: " & msgs(Id).idMsgFlag

    Select Case msgs(Id).vbDataType
        Case vbByte
            Dim y As Byte: y = msgs(Id).vMsgData

            MsgBox "Byte Data: " & y & str, , "Received by " & m_Src_hWnd

        Case vbBoolean
            Dim f As Boolean: f = msgs(Id).vMsgData

            MsgBox "Boolean Data: " & f & str, , "Received by " & m_Src_hWnd

        Case vbInteger
            Dim i As Integer: i = msgs(Id).vMsgData

            MsgBox "Integer Data: " & i & str, , "Received by " & m_Src_hWnd

        Case vbLong
            Dim l As Long: l = msgs(Id).vMsgData

            MsgBox "Long Data: " & l & str, , "Received by " & m_Src_hWnd

        Case vbSingle
            Dim r As Single: r = msgs(Id).vMsgData

            MsgBox "Single Data: " & r & str, , "Received by " & m_Src_hWnd

        Case vbDouble
            Dim d As Double: d = msgs(Id).vMsgData

            MsgBox "Double Data: " & d & str, , "Received by " & m_Src_hWnd

        Case vbCurrency
            Dim c As Currency: c = msgs(Id).vMsgData

            MsgBox "Currency Data: " & c & str, , "Received by " & m_Src_hWnd

        Case vbDate
            Dim dt As Date: dt = msgs(Id).vMsgData

            MsgBox "Date Data: " & dt & str, , "Received by " & m_Src_hWnd

        Case vbString
            Dim s As String: s = msgs(Id).vMsgData



  AlertErr.StackAdd "MsgLink.MessageNotify"

    If (LenB(s) <> 0) Then frmZipSearch.DisplayNewPath s

  AlertErr.StackRemove


            'MsgBox "String Data: " & s & str, , "Received by " & m_Src_hWnd

        Case vbUserDefinedType
            Dim yUDT() As Byte: yUDT = msgs(Id).vMsgData

            MsgBox "UDT Data: yUDT(0 To " & UBound(yUDT) & ")" & str & _
                   vbCrLf & vbCrLf & "Dim udt As YourUDT" & vbCrLf & _
                   "CopyMemory udt, yUDT(0), LenB(udt)", , "Received by " & m_Src_hWnd

            ' Call YourSub(yUDT)

            ' Sub YourSub(yaUDT() As Byte)
            '     Dim udt As YourUDT
            '     CopyMemory udt, yaUDT(0), LenB(udt)
            '     ...

        Case Is > vbArray

            Select Case msgs(Id).vbDataType - vbArray
                Case vbByte
                    Dim ay() As Byte: ay = msgs(Id).vMsgData

                    MsgBox "Byte Array: ay(0 To " & UBound(ay) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbBoolean
                    Dim af() As Boolean: af = msgs(Id).vMsgData

                    MsgBox "Boolean Array: af(0 To " & UBound(af) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbInteger
                    Dim ai() As Integer: ai = msgs(Id).vMsgData

                    MsgBox "Integer Array: ai(0 To " & UBound(ai) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbLong
                    Dim al() As Long: al = msgs(Id).vMsgData

                    MsgBox "Long Array: al(0 To " & UBound(al) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbSingle
                    Dim ar() As Single: ar = msgs(Id).vMsgData

                    MsgBox "Single Array: ar(0 To " & UBound(ar) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbDouble
                    Dim ad() As Double: ad = msgs(Id).vMsgData

                    MsgBox "Double Array: ad(0 To " & UBound(ad) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbCurrency
                    Dim ac() As Currency: ac = msgs(Id).vMsgData

                    MsgBox "Currency Array: ac(0 To " & UBound(ac) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbDate
                    Dim aDt() As Date: aDt = msgs(Id).vMsgData

                    MsgBox "Date Array: aDt(0 To " & UBound(aDt) & ")" & _
                            str, , "Received by " & m_Src_hWnd

                Case vbUserDefinedType
                    Dim cBytes As Long: cBytes = msgs(Id).vMsgData

                    ' We use a byte array to pass UDT arrays
                    ' Use msgs(id).idMsgFlag to identify which UDT
                    ' LenUDT = LenB(WhichUDT)
                    ' LenArr = cBytes \ LenUDT

                    MsgBox "UDT Array Data: m_yaUDT(0 To " & cBytes - 1 & ")" & _
                           str & vbCrLf & vbCrLf & _
                           "LenArr = cBytes \ LenB_UDT" & vbCrLf & _
                           "Dim udtArr(0 To LenArr - 1) As WhichUDT" & vbCrLf & _
                           "CopyMemory udtArr(0), m_yaUDT(0), cBytes", , _
                           "Received by " & m_Src_hWnd
        End Select
    End Select
    ' Reset array element after message has been raised
    msgs(Id).hWndSrc = 0&
    msgs(Id).vbDataType = 0&
    msgs(Id).idMsgFlag = 0&
    msgs(Id).vMsgData = vbEmpty
End Sub

Public Sub SendString(ByVal Target_hWnd As Long, sMessage As String, Optional ByVal flag As Integer = &HFFFF)
    If (Target_hWnd = 0&) Then Err.Raise 5
    If LenB(sMessage) = 0& Then Err.Raise 5
    If (IsWindow(Target_hWnd)) Then
        Dim cds As COPYDATASTRUCT

        ' Use a byte array to preserve Unicode
        Dim aBuf() As Byte
        aBuf = sMessage

        cds.dwData = MakeLong(vbString, flag) ' String Data mode
        cds.cbData = LenB(sMessage) ' Unicode
        cds.lpData = VarPtr(aBuf(0))

        Call SendMessage(Target_hWnd, WM_COPYDATA, m_Src_hWnd, cds)
    End If
End Sub

Public Sub SendNumeric(ByVal Target_hWnd As Long, nMessage As Variant, Optional ByVal flag As Integer = &HFFFF)
    If (Target_hWnd = 0&) Then Err.Raise 5
    If (IsWindow(Target_hWnd)) Then
        Dim cds As COPYDATASTRUCT
        Dim vbDataType As Integer

        vbDataType = VarType(nMessage)

        Select Case vbDataType
            Case vbByte     ' Byte Data
                Dim y As Byte: y = nMessage

                cds.cbData = 1& 'LenB(y)
                cds.lpData = VarPtr(y)

            Case vbBoolean  ' Boolean Data
                Dim f As Boolean: f = nMessage

                cds.cbData = 2& 'LenB(f)
                cds.lpData = VarPtr(f)

            Case vbInteger  ' Integer Data
                Dim i As Integer: i = nMessage

                cds.cbData = 2&
                cds.lpData = VarPtr(i)

            Case vbLong     ' Long Data
                Dim l As Long: l = nMessage

                cds.cbData = 4&
                cds.lpData = VarPtr(l)

            Case vbSingle   ' Single Data
                Dim r As Single: r = nMessage

                cds.cbData = 4&
                cds.lpData = VarPtr(r)

            Case vbDouble   ' Double Data
                Dim d As Double: d = nMessage

                cds.cbData = 8&
                cds.lpData = VarPtr(d)

            Case vbCurrency ' Currency Data
                Dim c As Currency: c = nMessage

                cds.cbData = 8&
                cds.lpData = VarPtr(c)

            Case vbDate     ' Date Data
                Dim dt As data: dt = nMessage

                cds.cbData = 8&
                cds.lpData = VarPtr(dt)

        End Select
        cds.dwData = MakeLong(vbDataType, flag)

        Call SendMessage(Target_hWnd, WM_COPYDATA, m_Src_hWnd, cds)
    End If
End Sub

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'  SendUDT
'              Dim udt As YourUDT
'
'              Dim yaUDT(1 To LenB(udt)) As Byte
'              CopyMemory yaUDT(1), udt, LenB(udt)
'           or
'              Dim yaUDT(0 To LenB(udt) - 1) As Byte
'              CopyMemory yaUDT(0), udt, LenB(udt)
'
'              Call SendUDT(Target_hWnd, yaUDT)
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub SendUDT(ByVal Target_hWnd As Long, yaUDT() As Byte, Optional ByVal flag As Integer = &HFFFF)
    If (Target_hWnd = 0&) Then Err.Raise 5
    If (IsWindow(Target_hWnd)) Then
        Dim cds As COPYDATASTRUCT, lb As Long

        lb = LBound(yaUDT)

        cds.dwData = MakeLong(vbUserDefinedType, flag) ' UDT Data mode
        cds.cbData = UBound(yaUDT) - lb + 1&
        cds.lpData = VarPtr(yaUDT(lb))

        Call SendMessage(Target_hWnd, WM_COPYDATA, m_Src_hWnd, cds)
    End If
End Sub

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'  SendArray
'          Accepts an array of fixed-length data types.
'          String, Variant and UDT arrays not supported.
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub SendArray(ByVal Target_hWnd As Long, aArray As Variant, Optional ByVal flag As Integer = &HFFFF)
    If (Target_hWnd = 0&) Then Err.Raise 5
    If (IsWindow(Target_hWnd)) Then
        Dim cds As COPYDATASTRUCT, lb As Long
        Dim vbDataType As Integer

        vbDataType = VarType(aArray)

        If ((vbDataType And vbArray) = vbArray) Then
            lb = LBound(aArray)

            cds.dwData = MakeLong(vbDataType, flag)
            cds.cbData = UBound(aArray) - lb + 1&
            cds.lpData = VarPtr(aArray(lb))

            Call SendMessage(Target_hWnd, WM_COPYDATA, m_Src_hWnd, cds)
        Else
            Err.Raise 5
        End If
    End If
End Sub

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'  SendArrayUDTs
'          Accepts arrays of any fixed-length user defined type.
'          Use the flag argument to identify which UDT.
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub SendArrayUDTs(ByVal Target_hWnd As Long, ByVal VarPtr_ArrLB As Long, ByVal cLenArr As Long, ByVal cLenUDT As Long, Optional ByVal flag As Integer = &HFFFF)
    If (Target_hWnd = 0&) Then Err.Raise 5
    If (IsWindow(Target_hWnd)) Then
        Dim cds As COPYDATASTRUCT
        Dim vbDataType As Integer

        vbDataType = vbUserDefinedType Or vbArray

        cds.dwData = MakeLong(vbDataType, flag)
        cds.cbData = cLenArr * cLenUDT
        cds.lpData = VarPtr_ArrLB

        Call SendMessage(Target_hWnd, WM_COPYDATA, m_Src_hWnd, cds)
    End If
End Sub

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' End Public Functions

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub MessageReceiver(ByVal hWnd_Src As Long, ByRef pStruct As Long)
    ' Called by CallbackProc, don't Break or End in here
    On Error GoTo SkipErr

    Dim cds As COPYDATASTRUCT
    Dim vbDataType As Integer
    Dim idMsgFlag As Integer

    m_Idx = (m_Idx Mod MAX_MESSAGES_IN_EACH_QUEUE) + 1&
    msgs(m_Idx).hWndSrc = hWnd_Src

    Call CopyMemory(cds, pStruct, LenB(cds))

    Call SplitLong(cds.dwData, vbDataType, idMsgFlag)

    msgs(m_Idx).vbDataType = vbDataType
    msgs(m_Idx).idMsgFlag = idMsgFlag

    If ((vbDataType And vbArray) = vbArray) Then
        Call ArrayHandler(vbDataType - vbArray, cds.lpData, cds.cbData)
    Else
        Select Case vbDataType
            Case vbByte     ' Byte Data
                Dim y As Byte
                Call CopyMemory(y, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = y

            Case vbBoolean  ' Boolean Data
                Dim f As Boolean
                Call CopyMemory(f, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = f

            Case vbInteger  ' Integer Data
                Dim i As Integer
                Call CopyMemory(i, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = i

            Case vbLong     ' Long Data
                Dim l As Long
                Call CopyMemory(l, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = l

            Case vbSingle   ' Single Data
                Dim r As Single
                Call CopyMemory(r, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = r

            Case vbDouble   ' Double Data
                Dim d As Double
                Call CopyMemory(d, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = d

            Case vbCurrency ' Currency Data
                Dim c As Currency
                Call CopyMemory(c, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = c

            Case vbDate     ' Date Data
                Dim dt As Date
                Call CopyMemory(dt, ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = dt

            Case vbString   ' String Data
                ' We use a byte array to combat string conversion
                Dim yaBuf() As Byte, s As String
                ReDim yaBuf(0 To cds.cbData - 1) As Byte
                Call CopyMemory(yaBuf(0), ByVal cds.lpData, cds.cbData)
                s = yaBuf
                msgs(m_Idx).vMsgData = s

            Case vbUserDefinedType ' UDT Data
                ' We use a byte array to pass UDTs
                Dim yUDT() As Byte
                ReDim yUDT(0 To cds.cbData - 1) As Byte
                Call CopyMemory(yUDT(0), ByVal cds.lpData, cds.cbData)
                msgs(m_Idx).vMsgData = yUDT
        End Select
    End If

    ' Return sub before passing on message
    Call SetTimer(m_Src_hWnd, m_Idx, 1&, 0&)

SkipErr:
    If (Err) Then Beep: Debug.Print "MsgLink.MessageReceiver Error #"; Err; " - "; Err.Description
End Sub

Private Sub ArrayHandler(ByVal DataType As Long, ByVal pArray As Long, ByVal LenArray As Long)
    ' Called by CallbackProc, don't Break or End in here
    On Error GoTo SkipErr
    Dim CopyLen As Long

    Select Case DataType
        Case vbByte     ' Byte Array
            Dim y() As Byte
            CopyLen = LenArray
            ReDim y(0 To LenArray - 1) As Byte
            Call CopyMemory(y(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = y()

        Case vbBoolean  ' Boolean Array
            Dim f() As Boolean
            CopyLen = 2 * LenArray
            ReDim f(0 To LenArray - 1) As Boolean
            Call CopyMemory(f(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = f()

        Case vbInteger  ' Integer Array
            Dim i() As Integer
            CopyLen = 2 * LenArray
            ReDim i(0 To LenArray - 1) As Integer
            Call CopyMemory(i(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = i()

        Case vbLong     ' Long Array
            Dim l() As Long
            CopyLen = 4 * LenArray
            ReDim l(0 To LenArray - 1) As Long
            Call CopyMemory(l(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = l()

        Case vbSingle   ' Single Array
            Dim r() As Single
            CopyLen = 4 * LenArray
            ReDim r(0 To LenArray - 1) As Single
            Call CopyMemory(r(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = r()

        Case vbDouble   ' Double Array
            Dim d() As Double
            CopyLen = 8 * LenArray
            ReDim d(0 To LenArray - 1) As Double
            Call CopyMemory(d(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = d()

        Case vbCurrency ' Currency Array
            Dim c() As Currency
            CopyLen = 8 * LenArray
            ReDim c(0 To LenArray - 1) As Currency
            Call CopyMemory(c(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = c()

        Case vbDate     ' Date Array
            Dim dt() As Date
            CopyLen = 8 * LenArray
            ReDim dt(0 To LenArray - 1) As Date
            Call CopyMemory(dt(0), ByVal pArray, CopyLen)
            msgs(m_Idx).vMsgData = dt()

        Case vbUserDefinedType ' UDT Array
            ' We use a byte array to pass UDT arrays
            ReDim m_yaUDT(0 To LenArray - 1) As Byte
            Call CopyMemory(m_yaUDT(0), ByVal pArray, LenArray)
            msgs(m_Idx).vMsgData = LenArray
    End Select

SkipErr:
    If (Err) Then Beep: Debug.Print "MsgLink.ArrayHandler Error #"; Err; " - "; Err.Description
End Sub

Private Sub SplitLong(ByVal DWord As Long, vbDataType As Integer, idMsgFlag As Integer)
    Dim LoHi As TwoInts
    Dim Both As OneLong
    Both.dw = DWord
    LSet LoHi = Both
    vbDataType = LoHi.lo
    idMsgFlag = LoHi.hi
End Sub

Private Function MakeLong(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    Dim LoHi As TwoInts
    Dim Both As OneLong
    LoHi.lo = LoWord
    LoHi.hi = HiWord
    LSet Both = LoHi
    MakeLong = Both.dw
End Function
'                                                             :›)
