Visual Basic Programmer'…arterly (Limited Edition)/Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso/code/ch27code/exchange.bas

BASIC Source File | 1995-08-01 | 22.7 KB | 473 lines

Attribute VB_Name = "basExchange"
'*********************************************************************
' EXCHANGE.BAS: Used to manually exchange data with other windows.
'*********************************************************************
Option Explicit
Option Compare Text
'*********************************************************************
' The API functions we are using in this module require us to define
' two new types.
'*********************************************************************
#If Win32 Then
Private Type PointAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#Else

Private Type PointAPI
    x As Integer
    y As Integer
End Type

Private Type RECT
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
End Type
#End If
'*********************************************************************
' Mouse Capture
'*********************************************************************
#If Win32 Then
Private Declare Function SetCapture& Lib "user32" (ByVal hWnd As Long)
Public Declare Function GetCapture Lib "user32" () As Long
Private Declare Sub ReleaseCapture Lib "user32" ()
#Else
Private Declare Function SetCapture Lib "User" (ByVal hWnd%) As Integer
Public Declare Function GetCapture Lib "User" () As Integer
Private Declare Sub ReleaseCapture Lib "User" ()
#End If
'*********************************************************************
' Window Information
'*********************************************************************
#If Win32 Then
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
    (ByVal hWnd&, ByVal lpClassName$, ByVal nMaxCount As Long) As Long
#Else
Private Declare Function GetClassName Lib "User" (ByVal hWnd%, ByVal _
    lpClassName$, ByVal nMaxCount%) As Integer
#End If
'*********************************************************************
' Window Coordinates, Points and Handles
'*********************************************************************
#If Win32 Then
Private Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, _
    lpPoint As PointAPI)
Private Declare Sub GetWindowRect Lib "user32" (ByVal hWnd As Long, _
    lpRect As RECT)
Private Declare Function WindowFromPoint Lib "user32" (ByVal _
    ptScreenX As Long, ByVal ptScreenY As Long) As Long
#Else
Private Declare Sub ClientToScreen Lib "User" (ByVal hWnd%, lpPoint _
    As PointAPI)
Private Declare Sub GetWindowRect Lib "User" (ByVal hWnd%, lpRect As RECT)
Private Declare Function WindowFromPoint% Lib "User" (ByVal ptScreen&)
#End If

'*********************************************************************
' Window Device Contexts
'*********************************************************************
#If Win32 Then
Private Declare Function GetWindowDC& Lib "user32" (ByVal hWnd As Long)
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
    ByVal hdc As Long) As Long
#Else
Private Declare Function GetWindowDC Lib "User" (ByVal hWnd%) As Integer
Private Declare Function ReleaseDC% Lib "User" (ByVal hWnd%, ByVal hdc%)
#End If
'*********************************************************************
' Brushes and Painting
'*********************************************************************
#If Win32 Then
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex&)
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle&, _
    ByVal nWidth&, ByVal crColor&) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, _
    ByVal nDrawMode As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc&, ByVal X1&, _
    ByVal Y1&, ByVal X2&, ByVal Y2&) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
#Else
Private Declare Function GetStockObject% Lib "GDI" (ByVal nIndex%)
Private Declare Function CreatePen Lib "GDI" (ByVal nPenStyle%, _
    ByVal nWidth%, ByVal crColor&) As Integer
Private Declare Function SetROP2 Lib "GDI" (ByVal hdc As Integer, _
    ByVal nDrawMode As Integer) As Integer
Private Declare Function Rectangle Lib "GDI" (ByVal hdc%, ByVal X1%, _
    ByVal Y1%, ByVal X2%, ByVal Y2%) As Integer
Private Declare Function SelectObject Lib "GDI" (ByVal hdc%, _
    ByVal hObject%) As Integer
Private Declare Function DeleteObject% Lib "GDI" (ByVal hObject%)
#End If
'*********************************************************************
' Misc. API Functions
'*********************************************************************
#If Win32 Then
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 SetFocusAPI Lib "user32" Alias "SetFocus" _
    (ByVal hWnd As Long) As Long
Private Declare Sub InvalidateRect Lib "user32" (ByVal hWnd&, _
    lpRect As Any, ByVal bErase As Long)
Private Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex&)
#Else
Private Declare Function GetSystemMetrics% Lib "User" (ByVal nIndex%)
Private Declare Function SendMessage Lib "User" (ByVal hWnd%, ByVal _
    wMsg As Integer, ByVal wParam%, lParam As Any) As Long
Private Declare Function SetFocusAPI Lib "User" Alias "SetFocus" _
    (ByVal hWnd%) As Integer
Private Declare Sub InvalidateRect Lib "User" (ByVal hWnd%, lpRect _
    As Any, ByVal bErase%)
#End If
'*********************************************************************
' Private API Constants
'*********************************************************************
Private Const WM_USER = &H400
Private Const WM_SETTEXT = &HC
'*********************************************************************
' This function communicates with the main form to send or receive
' text to or from a window.
'*********************************************************************
Public Function CaptureWindows(Mode$, FormName As Form, x!, y!, _
                                            ByVal SendText$) As String
#If Win32 Then
    Dim res&, retStr$, pt As PointAPI, wrd&, FormHwnd&, CurHwnd&
    Static PrevScaleMode%, LasthWnd&
#Else
    Dim res%, retStr$, pt As PointAPI, wrd&, FormHwnd%, CurHwnd%
    Static PrevScaleMode%, LasthWnd%
#End If

   FormHwnd = FormName.hWnd

   Select Case Mode
    Case "Start"
       '*************************************************************
       ' Set the scalemode to pixels.
       '**************************************************************
       PrevScaleMode = FormName.ScaleMode
       FormName.ScaleMode = vbPixels
       '**************************************************************
       ' Turn on the PointMode and mouse capture.
       '**************************************************************
        FormName.Visible = False
        If SetCapture(FormHwnd) Then Screen.MousePointer = vbUpArrow
        CaptureWindows = "Start"

    Case "Move"
        If GetCapture() Then
            '**********************************************************
            ' Store the current points into a POINTAPI struct.
            '**********************************************************
            pt.x = x
            pt.y = y
            '**********************************************************
            ' Change coordinates in pt into screen coordinates.
            '**********************************************************
            ClientToScreen FormHwnd, pt
        #If Win32 Then
            '**********************************************************
            ' Get the window that is under the mouse pointer.
            '**********************************************************
            CurHwnd = WindowFromPoint(pt.x, pt.y)
        #Else
            '**********************************************************
            ' Convert the points into a WORD, so they may be used later
            '**********************************************************
            wrd = CLng(pt.y) * &H10000 Or pt.x
            '**********************************************************
            ' Get the window that is under the mouse pointer.
            '**********************************************************
            CurHwnd = WindowFromPoint(wrd)
        #End If
            '**********************************************************
            ' Only redraw if there is a new active window.
            '**********************************************************
            If CurHwnd <> LasthWnd Then
                '******************************************************
                ' If there is a LasthWnd, then restore it.
                '******************************************************
                If LasthWnd Then InvertTracker LasthWnd
                '******************************************************
                ' Draw an border around the current window, and
                ' remember the last hWnd.
                '******************************************************
                InvertTracker CurHwnd
                LasthWnd = CurHwnd
            End If
        End If

    Case "End"
        '**************************************************************
        ' Restore the last window's border, and refresh the screen
        ' to remove any ghosts that may have appeared.
        '**************************************************************
        RefreshScreen
        '**************************************************************
        ' Exchange the data, and return a result.
        '**************************************************************
        CaptureWindows = ExchangeData(LasthWnd, SendText)
        '**************************************************************
        ' Clear the public variable to indicate that there is
        ' no LasthWnd because ALL windows are restored.
        '**************************************************************
        LasthWnd = 0
        '**************************************************************
        ' If the form has the capture, then release it.
        '**************************************************************
        If GetCapture() = FormHwnd Then ReleaseCapture
        '**************************************************************
        ' Restore ScaleMode and the MousePointer.
        '**************************************************************
        FormName.ScaleMode = PrevScaleMode
        FormName.Visible = True
        Screen.MousePointer = vbDefault
   End Select

End Function
'*********************************************************************
' This is the magic cookie of this module. It takes a handle and
' sends or receives text to and from standard windows controls.
'*********************************************************************
Public Function ExchangeData(ByVal TaskHandle&, PasteText$) As String
#If Win32 Then
    Dim i&, res&, buffer$, retStr$, LastIdx&, CtrlType$
    Const LB_GETTEXT = &H189
    Const LB_GETTEXTLEN = &H18A
    Const LB_GETCOUNT = &H18B
    Const CB_GETLBTEXT = &H148
    Const CB_GETLBTEXTLEN = &H149
    Const CB_GETCOUNT = &H146
    Const WM_GETTEXT = &HD
#Else
    Dim i%, res%, buffer$, retStr$, LastIdx%, CtrlType$
    Const LB_GETTEXT = WM_USER + 10
    Const LB_GETTEXTLEN = WM_USER + 11
    Const LB_GETCOUNT = WM_USER + 12
    Const CB_GETLBTEXT = WM_USER + 8
    Const CB_GETLBTEXTLEN = WM_USER + 9
    Const CB_GETCOUNT = WM_USER + 6
    Const WM_GETTEXT = &HD
#End If
    '*****************************************************************
    ' Find out the class type of the control.
    '*****************************************************************
    CtrlType = GetClass(TaskHandle)
    '*****************************************************************
    ' If it is a combo box, then use combo functions to communciate.
    '*****************************************************************
    If InStr(CtrlType, "Combo") Then
        '*************************************************************
        ' Find out how many items are in the combo box.
        '*************************************************************
        LastIdx = SendMessage(TaskHandle, CB_GETCOUNT, 0, 0&) - 1
        '*************************************************************
        ' Iterate through the combo to retrieve every item.
        '*************************************************************
        For i = 0 To LastIdx
            '*********************************************************
            ' Find out how long the current item is, and build a
            ' buffer large enough to hold it.
            '*********************************************************
            buffer = Space(SendMessage(TaskHandle, CB_GETLBTEXTLEN, _
                                                           i, 0&) + 1)
            '*********************************************************
            ' Prevent overflow errors.
            '*********************************************************
            If Len(retStr) + Len(buffer) - 1 > 32000 Then Exit For
            '*********************************************************
            ' Get the item from the combo box.
            '*********************************************************
            res = SendMessage(TaskHandle, CB_GETLBTEXT, i, ByVal buffer)
            '*********************************************************
            ' Trim the null terminator, and append it to retStr.
            '*********************************************************
            retStr = retStr & Left(buffer, res) & vbCrLf
        Next i
        '*************************************************************
        ' Return your results to the calling proceedure, and exit.
        '*************************************************************
        ExchangeData = retStr
        Exit Function
    '*****************************************************************
    ' If it is a list box, then use list functions.
    '*****************************************************************
    ElseIf InStr(CtrlType, "List") Then
        '*************************************************************
        ' Find out how many items are in the list box.
        '*************************************************************
        LastIdx = SendMessage(TaskHandle, LB_GETCOUNT, 0, 0&) - 1
        '*************************************************************
        ' Iterate through the list to retrieve every item.
        '*************************************************************
        For i = 0 To LastIdx
            '*********************************************************
            ' Find out how long the current item is, and build a
            ' buffer large enough to hold it.
            '*********************************************************
            buffer = Space(SendMessage(TaskHandle, LB_GETTEXTLEN, _
                                                           i, 0&) + 1)
            '*********************************************************
            ' Prevent overflow errors.
            '*********************************************************
            If Len(retStr) + Len(buffer) - 1 > 32000 Then Exit For
            '*********************************************************
            ' Get the item from the list box.
            '*********************************************************
            res = SendMessage(TaskHandle, LB_GETTEXT, i, ByVal buffer)
            '*********************************************************
            ' Trim the null terminator, and append it to retStr.
            '*********************************************************
            retStr = retStr & Left(buffer, res) & vbCrLf
        Next i
        '*************************************************************
        ' Return your results to the calling proceedure, and exit.
        '*************************************************************
        ExchangeData = retStr
        Exit Function
    '*****************************************************************
    ' Otherwise, try WM_GETTEXT and WM_SETTEXT.
    '*****************************************************************
    Else
        '*************************************************************
        ' If paste text is empty, then retrieve text text.
        '*************************************************************
        If PasteText = "" Then
            '*********************************************************
            ' Build a huge buffer, and get it.
            '*********************************************************
            retStr = Space(32000)
            res = SendMessage(TaskHandle, WM_GETTEXT, Len(retStr), _
                                                         ByVal retStr)
            '*********************************************************
            ' Keep all text to the left of the null terminator.
            '*********************************************************
            ExchangeData = Left(retStr, res)
            Exit Function
        '*************************************************************
        ' Otherwise, send text to the window.
        '*************************************************************
        Else
            '*********************************************************
            ' If the window is an edit box, then paste text to it.
            ' Otherwise don't. This prevents you from changing the
            ' captions of labels, buttons, etc...
            '*********************************************************
            If InStr(CtrlType, "Edit") Or InStr(CtrlType, "Text") Then
                '*****************************************************
                ' Put the text into the window, and activate it.
                '*****************************************************
                SendMessage TaskHandle, WM_SETTEXT, 0, ByVal PasteText
                SetFocusAPI TaskHandle
                '*****************************************************
                ' Return the num of chars pasted.
                '*****************************************************
                ExchangeData = Format(Len(PasteText))
            Else
                ExchangeData = Format(0)
            End If
            Exit Function
        End If
    End If
    '*****************************************************************
    ' If you got here, then this function is unsucessful.
    '*****************************************************************
    ' I use an obscure return string that I'll recognize, to keep my
    ' code from getting confused with valid return values.
    '*****************************************************************
    ExchangeData = "Error:" & String(10, "~")

End Function
'*********************************************************************
' Returns the class name of a window.
'*********************************************************************
Private Function GetClass(ByVal TaskHandle&) As String
Dim res&, Classname$
    '*****************************************************************
    ' Get the class name of the window.
    '*****************************************************************
    Classname = Space$(32000)
    res = GetClassName(TaskHandle, Classname, Len(Classname))
    GetClass = Left$(Classname, res)
End Function
'*********************************************************************
' Draws an inverted hatched line on two sizes of a window.
'*********************************************************************
#If Win32 Then
Private Sub InvertTracker(hwndDest As Long)
    Dim hdcDest&, hPen&, hOldPen&, hOldBrush&
    Dim cxBorder&, cxFrame&, cyFrame&, cxScreen&, cyScreen&
#Else
Private Sub InvertTracker(hwndDest As Integer)
    Dim hdcDest%, hPen%, hOldPen%, hOldBrush%
    Dim cxBorder%, cxFrame%, cyFrame%, cxScreen%, cyScreen%
#End If
Const NULL_BRUSH = 5
Const R2_NOT = 6
Const PS_INSIDEFRAME = 6
Dim rc As RECT
    '*****************************************************************
    ' Get some windows dimensions.
    '*****************************************************************
    cxScreen = GetSystemMetrics(0)
    cyScreen = GetSystemMetrics(1)
    cxBorder = GetSystemMetrics(5)
    cxFrame = GetSystemMetrics(32)
    cyFrame = GetSystemMetrics(33)
    '*****************************************************************
    ' Get the Device Context for the current window.
    '*****************************************************************
    hdcDest = GetWindowDC(hwndDest)
    '*****************************************************************
    ' Get the size of the window.
    '*****************************************************************
    GetWindowRect hwndDest, rc
    '*****************************************************************
    ' Create a new pen and select it (and a stock brush) into the
    ' device context.
    '*****************************************************************
    SetROP2 hdcDest, R2_NOT
    hPen = CreatePen(PS_INSIDEFRAME, 3 * cxBorder, RGB(0, 0, 0))
    '*****************************************************************
    ' Get the size of the window.
    '*****************************************************************
    hOldPen = SelectObject(hdcDest, hPen)
    hOldBrush = SelectObject(hdcDest, GetStockObject(NULL_BRUSH))
    '*****************************************************************
    ' Draw a box around the selected window.
    '*****************************************************************
    Rectangle hdcDest, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top
    '*****************************************************************
    ' Restore the old brush and pen.
    '*****************************************************************
    SelectObject hdcDest, hOldBrush
    SelectObject hdcDest, hOldPen
    '*****************************************************************
    ' Release the Device Context back to its owner.
    '*****************************************************************
    ReleaseDC hwndDest, hdcDest
    '*****************************************************************
    ' Delete the hatched brush.
    '*****************************************************************
    DeleteObject hPen
End Sub
'*********************************************************************
' Force the entire screen to be repainted immediately.
'*********************************************************************
Private Sub RefreshScreen()
    InvalidateRect 0, 0&, True
End Sub