send info between apps

[yrwyddfa]

'************************************************************************************************
'* Name             Function SubClass
'*
'* Author           
'*
'* Purpose          This function instructs Windows to redirect the Window Procedure of a
'*                  given control to a custom procedure.
'*
'*                  The function creates (sets) a property of the given Wnd called 'OldWndProc'
'*                  This ensures that the window retains it's own state with regard to its
'*                  original Window Procedure.
'*
'* Parameters       --> hWnd        LONG       The handle of the window to be subclassed
'*                  --> lpfnNew     LONG       Address of function of which to redirect the
'*                                             the standard WndProc too.
'*
'* Version  14/02/2002          Created
'*
'************************************************************************************************
Public Function SubClass(hwnd As Long, lpfnNew As Long) As Boolean
 
    Dim lpfnOld As Long
    Dim fSuccess As Boolean
    
    '*************************************************************
    '* If we haven't set the property for this window before . . .
    '*************************************************************
    If (GetProp(hwnd, OLDWNDPROC) = 0) Then
    
        '*****************************************
        '* Redirect Windows Proc to New Proc . . .
        '*****************************************
        lpfnOld = SetWindowLong(hwnd, GWL_WNDPROC, lpfnNew)
        
        '**********************************************************
        '* Set Old Proc Address to the property of the window . . .
        '**********************************************************
        If lpfnOld Then
            fSuccess = SetProp(hwnd, OLDWNDPROC, lpfnOld)
        End If
        
    End If
  
    '*************************************
    '* Did we subclass successfully . . .
    '*************************************
    If fSuccess Then
        SubClass = True
    Else
        '*************************************************
        '* If we have the old proc address,
        '* and still have failed, remove redirection . . .
        '*************************************************
        If lpfnOld Then
            Call UnSubClass(hwnd)
        End If
        
        '* Oh **** !!
        MsgBox "Unable to successfully subclass " & hwnd, vbCritical
        
    End If
  
End Function
 
 
'************************************************************************************************
'* Name             Function UnSubClass
'*
'* Author           
'*
'* Purpose          This function removes the OldWndProc property of the hWnd, and resets the
'*                  Window Procedure back to the original.
'*
'*                  See Function SubClass
'*
'* Parameters       --> hWnd        LONG       The handle of the window to be subclassed
'*
'* Version  14/02/2002           Created
'*
'************************************************************************************************
Public Function UnSubClass(hwnd As Long) As Boolean
 
    Dim lpfnOld As Long
  
    '**********************************
    '* Can we get Window property . . .
    '**********************************
    lpfnOld = GetProp(hwnd, OLDWNDPROC)
    
    '*************************************************************
    '* If we have property, remove it, and return Window Proc to
    '* original . . .
    '*************************************************************
    If lpfnOld Then
        If RemoveProp(hwnd, OLDWNDPROC) Then
            UnSubClass = SetWindowLong(hwnd, GWL_WNDPROC, lpfnOld)
        End If
    End If
 
End Function
 
 
'************************************************************************************************
'* Name             Function GridWndProc
'*
'* Author          
'*
'* Purpose          SubClass function for Windows Procedure redirection. Use only for the
'*                  FlexGrid.
'*
'*                  See Function SubClass
'*
'* Parameters       --> See MSDN Documentation
'*
'* Version  14/02/2002           Created
'*
'************************************************************************************************
Public Function NewWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
    Dim uCDS As COPYDATASTRUCT
    Dim uData() As Byte
    Dim oPb As PropertyBag
    
    Select Case uMsg
        
        Case WM_COPYDATA
            
            '*************************************
            '* Retrieve Copy Data Structure . . .
            '*************************************
            CopyMemory uCDS, ByVal lParam, Len(uCDS)
            ReDim uData(uCDS.cbData)
            CopyMemory uData(0), ByVal uCDS.lpData, uCDS.cbData
            
            Set oPb = New PropertyBag
            oPb.Contents = uData
            
            Select Case uCDS.dwData
                Case BM_CURRENCY
                    gEnv.CurrencyCode = oPb.ReadProperty("Code")
                    gEnv.CurrencyExchange = oPb.ReadProperty("ExchangeRate")
                    
            End Select
            
            Set oPb = Nothing
            
    End Select
  
    '************************************************************
    '* Carry on processing in the original Window Procedure . . .
    '************************************************************
    NewWndProc = CallWindowProc(GetProp(hwnd, OLDWNDPROC), hwnd, uMsg, wParam, lParam)
 
    
End Function

and an example of how to send . . .

Private Sub SendCurrency(lHWnd As Long, uCurrency As CURRENCY_EX)
 
    On Error GoTo ERR_SendCurrency
    
    Dim oPacket As PropertyBag
    Dim uCopyData As COPYDATASTRUCT
    Dim Stream() As Byte
    
    Set oPacket = New PropertyBag
    
    With oPacket
    
        .WriteProperty ("Code"), uCurrency.Code
        .WriteProperty ("Description"), uCurrency.Description
        .WriteProperty ("ExchangeRate"), uCurrency.ExchangeRate
        .WriteProperty ("Format"), uCurrency.Format
        .WriteProperty ("IsValid"), uCurrency.IsValid
        
        Stream = .Contents
        
    End With
    
    With uCopyData
        .dwData = BM_CURRENCY
        .cbData = UBound(Stream) - LBound(Stream) + 1
        .lpData = VarPtr(Stream(LBound(Stream)))
    End With
    
    SendMessageA lHWnd, WM_COPYDATA, 0&, uCopyData
    
    Set oPacket = Nothing
    Exit Sub
    
ERR_SendCurrency:
    Set oPacket = Nothing
End Sub