Jeff Webb, Mike McKelvy, Ronald Martinsen, Taylor Maxwell, Michael Regelski September 1995 Special Edition Using Visual Basic 4 - Chapter 27 1-56529-998-1 Computer Programming computer programming Visual Basic OLE database applications ODBC VB VBA API This book is an all-in-one reference that provides extensive coverage of every topic and technique for creating optimized and customized applications with Visual Basic.

Chapter 27

Integration with Other OLE Applications

Access, Excel, and Word are the most powerful Microsoft Office applications, so this book dedicates two informative chapters to each of these products. However, Microsoft also offers other powerful applications from that you might want to incorporate into your custom programs. None of these applications possesses enough power to warrant its own chapter, but collectively they warrant a brief discussion.

In this chapter, you learn how to do the following:

Connecting to OLE Automation Servers

You might think that once you've seen one OLE Automation server, you've seen them all. For the most part, this is true. Connecting to any OLE Automation server requires the same basic steps, but using the server and disconnecting isn't so easy. Every server has its own way of doing things, so you have to be careful. To demonstrate this point, this chapter introduces a simple text editor written in MFC (Microsoft Foundation Classes), called TextServer, that supports OLE Automation (see fig. 27.1). This chapter also introduces Talker, a sample Visual Basic program, to demonstrate the communication between a VB application and TextServer (see fig. 27.2).

Fig. 27.1

TextServer is a useful program that can serve as a OLE Automation testing tool for Visual Basic.

Fig. 27.2

Talker demonstrates that OLE Automation with TextServer is similar to Microsoft applications.

To demonstrate OLE Automation between a VB application and a typical non-Microsoft application (TextServer), this section discusses the steps required to write Talker. To begin this project, you first create an object variable that does not go out of scope. By doing so, you prevent yourself from accidentally losing your OLE Automation connection. Next, use CreateObject to establish a connection with TextServer. Listing 27.1 shows how you begin building Talker.

Listing 27.1 Establishing a Connection with TextServer

'*****************************************************************
' Create a object that won't go out of scope too early.
'*****************************************************************
Option Explicit
Private TextServer As Object
'*****************************************************************
' Loads the form and establishes a connection with TextServer.
'*****************************************************************
Private Sub Form_Load()
On Error Resume Next
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
'*************************************************************
' As this line demonstrates, all objects are created
' the same way.
'*************************************************************
Set TextServer = CreateObject("Text.Document")
If Err Then
'*********************************************************
' TextServer is not properly registered in the system
' registry, so register it.
'*********************************************************
RegisterTextServer
MsgBox "Please restart Talker now!", vbInformation
Unload Me
End If
LoadText
'*************************************************************
' Show is one of TextServer's OLE Automation commands.
' It causes TextServer to be activated and visible.
'*************************************************************
' NOTE: TextServer (and most OLE Automation apps) are
' invisible by default, so you must make them visible
' by some method if you want the user to see the
' application. If the user doesn't need to see the
' application, then it isn't necessary to make it
' visible.
'*************************************************************
TextServer.Show
End Sub

The first two buttons in the cmd control array simply send or receive text to or from TextServer. Listing 27.2 shows the necessary OLE Automation calls needed to accomplish this task.

Listing 27.2 Sending and Recieving Text to and from TextServer

'*****************************************************************
' Process command button clicks.
'*****************************************************************
Private Sub cmd_Click(Index As Integer)
Dim FindText$, ReplaceWith$
Select Case Index
Case 0 'Send Text to TextServer
'*****************************************************
' SetEditText takes 1 argument (a string). TextServer
' uses this string to populate its text box.
'*****************************************************
TextServer.SetEditText Text1
TextServer.Show
Case 1 'Get Text from TextServer
'*****************************************************
' GetEditText returns a string that contains
' the contents of TextServer's text box.
'*****************************************************
Text1 = TextServer.GetEditText()
...

The last button in the control array prompts the user for a word to find in TextServer's text window, and replaces every occurrence of that word with the another user-provided word. Next, the button calls TextServer's ReplaceAll function and displays TextServer to show the user the results of ReplaceAll. Listing 27.3 shows how to use TextServer's ReplaceAll method.

Listing 27.3 Using TextServer's ReplaceAll Method

...
Case 2 'Replace Every Occurrence of a Word
'*****************************************************
' ReplaceAll finds every occurrence of a word,
' and replaces it with a new word. After the replace
' is complete, the TextServer text box is updated to
' reflect the changes.
'*****************************************************
FindText = InputBox("Find What?")
If FindText = "" Then Exit Sub
ReplaceWith = InputBox("Replace With?")
If FindText = "" Then Exit Sub
TextServer.ReplaceAll FindText, ReplaceWith
TextServer.Show
End Select
End Sub

LoadText (see listing 27.4) simply opens SAMPLE.TXT from the directory in which the project or executable resides, loads all file's text, and inserts the text into the text box.

Listing 27.4 The LoadText Procedure

'*****************************************************************
' This procedure just loads the text box with some sample text.
'*****************************************************************
Private Sub LoadText()
Dim Source%, res$
Source = FreeFile
Open App.Path & "\sample.txt" For Input As Source
res = Input(LOF(Source), Source)
Text1 = res
Close Source
End Sub

When writing applications that depend on certain OLE applications being properly registered, you usually should write a procedure that automatically registers those applications. Your application need only run REGEDIT.EXE (included with Windows) with the OLE servers .REG file as the command-line argument.

The RegisterTextServer procedure (see listing 27.5) goes a step further by inserting the .REG file into a new procedure so that the application can customize and create the file while running. By doing so, RegisterTextServer ensures that a valid .REG file exists, even if the user accidentally deletes his or her own.

Listing 27.5 The RegisterTextServer Procedure

'*****************************************************************
' This procedure demonstrates how you can automatically register
' (or reregister) an application without any interaction
' from the user.
'*****************************************************************
Private Sub RegisterTextServer()
Dim sTemp$, Source%, RegFile$
'*************************************************************
' Since you'll need a bunch of hard returns, you'll want
' to cache them in a variable.
'*************************************************************
'*************************************************************
' The entire contents of sTemp were created by opening a .REG
' file in Notepad, and inserting text before and after each
' line. That text was then pasted into VB, and Notepad was
' closed without saving. In addition, any of the lines that
' pointed to the .EXE,were updated to reflect the path to
' the program (in this case App.Path).
'*************************************************************
sTemp = "REGEDIT" & vbCrLf
sTemp = sTemp & "; This .REG file is used to properly register
TextServer." & vbCrLf
sTemp = sTemp & "COleObjectFactory::UpdateRegistryAll." & vbCrLf
sTemp = sTemp & "" & vbCrLf
sTemp = sTemp & "HKEY_CLASSES_ROOT\.txt = Text.Document" & vbCrLf
'*************************************************************
' The next 2 lines are combined into one line in the file that
' points to the path where TEXTSVER.EXE is stored. If the
' system registry doesn't point to a vaild path, DDE
' connections will always fail unless TextServer is already
' running.
'*************************************************************
sTemp = sTemp & _
"HKEY_CLASSES_ROOT\Text.Document\shell\open\command = "
sTemp = sTemp & App.Path & "\TEXTSVER.EXE %1" & vbCrLf
sTemp = sTemp & _
"HKEY_CLASSES_ROOT\Text.Document\shell\open\ddeexec
= [open(""%1"")]" & vbCrLf
sTemp = sTemp & _
"HKEY_CLASSES_ROOT\Text.Document\shell\open\ddeexec
\application = TEXTSVER" & vbCrLf
sTemp = sTemp & "" & vbCrLf
sTemp = sTemp & _
"HKEY_CLASSES_ROOT\Text.Document = Text Document" & vbCrLf
sTemp = sTemp & "HKEY_CLASSES_ROOT\Text.Document\CLSID =
{F15017A0-8245-101B-95FE-00AA0030472F}" & vbCrLf
sTemp = sTemp & "" & vbCrLf
sTemp = sTemp & "HKEY_CLASSES_ROOT\CLSID\{F15017A0-8245-
101B-95FE-00AA0030472F} = Text Document" & vbCrLf
'*************************************************************
' Once again, the next two lines point to the path where
' TEXTSVER.EXE is stored. If the system registry doesn't point
' to a vaild path, CreateObject will always fail unless
' TextServer is already running.
'*************************************************************
sTemp = sTemp & "HKEY_CLASSES_ROOT\CLSID\{F15017A0-8245-101B-
95FE-00AA0030472F}\LocalServer = "
sTemp = sTemp & App.Path & "\TEXTSVER.EXE" & vbCrLf
sTemp = sTemp & "HKEY_CLASSES_ROOT\CLSID\{F15017A0-8245-101B-
95FE-00AA0030472F}\ProgId = Text.Document" & vbCrLf
'*************************************************************
' Create the .REG file on the end user's hard drive.
'*************************************************************
Source = FreeFile
RegFile = App.Path & "\TEXTSVER.REG"
'*************************************************************
' Clear the file
'*************************************************************
Open RegFile For Output As Source
Close Source
'*************************************************************
' Create the .REG file
'*************************************************************
Open RegFile For Binary As Source
Put Source, , sTemp
Close Source
'*************************************************************
' Run RegEdit with the .REG file to automatically register it.
' If the app was already registered, your file will update the
' registry with any changes.
'*************************************************************
Shell "regedit.exe /s " & RegFile, vbMinimizedNoFocusEnd Sub

The RegisterTextServer procedure in listing 27.5 demonstrates how you can create and register an OLE application on the fly. Even if the user doesn't have the .REG file, your application will run because it creates its own. If your OLE application doesn't have an .REG file, it probobly can register itself, so the preceding step is unnecessary.

You can access all OLE Automation servers in a manner similar to that demonstrated in the Talker example. This is important to know, because new OLE Automation servers are being released every month.

For a more detailed discussion on communicating with OLE Automation servers, see Chapter 18, "Creating Objects."

Using Microsoft's OLE Miniservers

You might have noticed that Microsoft has several programs in the MSAPPS subdirectory of your Windows directory. One or more Microsoft applications use these programs to provide some special feature such as a ClipArt manager. However, if you ever try to run one of these programs directly, you get a message that tells you that you can run the program only from within a host application. This is because these small programs are OLE miniservers, which run only if an OLE host application (such as Word or your Visual Basic application) calls them. This section explains you how you can use these handy miniservers in your Visual Basic applications.

You cannot redistribute these miniservers. Therefore, your programs should use them only if they are already installed on the user's system. Otherwise, your application must handle this situation gracefully.

Although the exact number is always changing, Microsoft currently distributes seven OLE miniservers. Table 27.1 lists each miniserver, along with the application with which it is bundled.

Table 27.1 Microsoft's OLE Miniservers

Miniserver Path from the MSAPPS Directory Application
ClipArt Gallery ..\ARTGALRY\ARTGALRY.EXE Publisher
Draw ..\MSDRAW\MSDRAW.EXE Works, Publisher
Equation Editor ..\EQUATION\EQNEDIT.EXE PowerPoint, Word
Graph ..\MSGRAPH5\GRAPH5.EXE Access, Word
Note-It ..\NOTE-IT\NOTE-IT.EXE Works
Organization Chart ..\ORGCHART\ORGCHART.EXE PowerPoint
WordArt ..\WORDART\WORDART2.EXE PowerPoint, Publisher, Word

Table 27.1 refers only to the 1994 versions of each application, so earlier versions might not include the listed miniserver. For more information on which miniserver the applications include, contact Microsoft Product Support Services.

To demonstrate how easy it is to use these miniservers in your applications, listing 27.6 presents a portion of the code for MINISERV.VBP, a program that uses the currently installed OLE miniservers in the OLE container control. This program contains seven OLE container controls on the form, with a miniserver embedded in each of the controls. When you run the program, it adds an item to a drop-down list box for each miniserver that exists on the system. This drop-down list box enables you to navigate between the available miniservers so that you can view and edit an object of each type of available miniserver.

Listing 27.6 Determining Which Miniservers Are Available

'*****************************************************************
' Only load miniservers that exist.
'*****************************************************************
Private Sub LoadList()
Dim MSAppsRoot$
With cboServers
.Clear
MSAppsRoot = Space(256)
MSAppsRoot = Left(MSAppsRoot, _
GetWindowsDirectory(MSAppsRoot, Len(MSAppsRoot)))
If Win95UI() Then
MSAppsRoot = _
"C:\Program Files\Common Files\Microsoft Shared\"
Else
MSAppsRoot = MSAppsRoot & "\msapps\"
End If
If FileExists(MSAppsRoot & "artgalry\artgalry.exe") Then
.AddItem "MS ClipArt"
.ItemData(.NewIndex) = 0
End If
#If Win16 Then
If FileExists(MSAppsRoot & "equation\eqnedit.exe") Then
#Else
If FileExists(MSAppsRoot & "equation\eqnedt32.exe") Then
#End If
.AddItem "MS Draw"
.ItemData(.NewIndex) = 1
End If
If FileExists(MSAppsRoot & "msdraw\msdraw.exe") Then
.AddItem "MS Equation Editor"
.ItemData(.NewIndex) = 2
End If
If FileExists(MSAppsRoot & "msgraph5\graph5.exe") Then
.AddItem "MS Graph"
.ItemData(.NewIndex) = 3
End If
If FileExists(MSAppsRoot & "note-it\note-it.exe") Then
.AddItem "MS Note-It"
.ItemData(.NewIndex) = 4
End If
If FileExists(MSAppsRoot & "orgchart\orgchart.exe") Then
.AddItem "MS Organization Chart"
.ItemData(.NewIndex) = 5
End If
#If Win16 Then
If FileExists(MSAppsRoot & "wordart\wordart2.exe") Then
#Else
If FileExists(MSAppsRoot & "wordart\wrdart32.exe") Then
#End If
.AddItem "MS WordArt"
.ItemData(.NewIndex) = 6
End If
End With
End Sub
'*****************************************************************
' Check to see if a file exists.
'*****************************************************************
Private Function FileExists(FileName$) As Boolean
On Error Resume Next
FileExists = IIf(Dir(FileName) = "", False, True)
End Function
'*****************************************************************
' Check to see if the user is running the Windows 95 shell.
'*****************************************************************
Private Function Win95UI() As Boolean
Dim lngWinVer As Long
lngWinVer = GetVersion() And &HFFFF&
Win95UI = IIf((lngWinVer And &HFF) + _
((lngWinVer And &HFF00) / 256) > 3.5, True, _
False)
End Function

Don't let the name fool you: miniservers are full-blown graphical applications. They consume as much memory and resources as most large-scale applications. If you do run out of system resources, you will get "Unable to Activate Object" or "Object Not Properly Registered" errors when you try to activate a miniserver.

Although listing 27.6 contains a fair amount of code, most of it is for cosmetic purposes. The most important element of this project occurs at design time, when you load your OLE custom controls from the available miniservers installed on your system.

Using Other Microsoft Applications in Your Applications

You've seen plenty information about integration with Access, Excel, and Word, but you may wonder about integration with other Microsoft applications. This section puts together a quick application that demonstrates how to use the OLE container control to display objects from five other Microsoft applications-Paintbrush, PowerPoint, Project, Sound Recorder, and Video for Windows (see fig. 27.3-27.7).

Fig. 27.3

Paintbrush is another Microsoft application that you can embed in your applications.

Fig. 27.4

PowerPoint is another Microsoft application that you can embed in your applications.

Fig. 27.5

Project is another Microsoft application that you can embed in your applications.

Fig. 27.6

Sound Recorder is another Microsoft application that you can embed in your applications.

Fig. 27.7

Video for Windows is another Microsoft application that you can embed in your applications.

This application's code (listing 27.7) is rather simple, because the OLE Container Control does most of the work. This application demonstrates how advantageous it is to own applications that support OLE, because you can easily use them to enhance your application's functionality.

Listing 27.7 FRMOBJ.FRM Takes Advantage Of Some Available OLE Servers

'*****************************************************************
' FRMOBJECT.FRM: Used to display an object and its verbs.
'*****************************************************************
Option Explicit
Private OLEObject As OLE
...
'*****************************************************************
' Execute a verb (verbs are from 1 to x, so you need to add 1).
'*****************************************************************
Private Sub cmdVerbs_Click(Index As Integer)
On Error Resume Next
OLEObject.DoVerb (Index + 1)
If Err Then MsgBox "Err = " & Format(Err) & ": " _
& Error, vbCritical
End Sub
'*****************************************************************
' This public method is used to display the form
' and to call necessary loading routines.
'*****************************************************************
Public Sub Display(obj As OLE)
Set OLEObject = obj
OLEObject.Visible = True
PrepareForm
Show vbModal
End Sub
'*****************************************************************
' Center the form and load the command buttons for its verbs.
'*****************************************************************
Public Sub PrepareForm()
Dim i As Integer
'*************************************************************
' Center the dialog.
'*************************************************************
Move (Screen.Width - Width) / 2, _
(Screen.Height - Height) / 2
'*************************************************************
' Create and label a command button on the form for each verb.
'*************************************************************
For i = 1 To OLEObject.ObjectVerbsCount - 1
'*********************************************************
' cmdVerbs(0) already exists, so skip it.
'*********************************************************
If i > 1 Then Load cmdVerbs(i - 1)
With cmdVerbs(i - 1)
If i > 1 Then
.Top = cmdVerbs(i - 2).Top _
+ cmdVerbs(i - 2).Height + 75
End If
.Caption = OLEObject.ObjectVerbs(i)
.Visible = True
End With
Next i
End Sub

Listing 27.7 includes three important procedures: the PrepareForm procedure, the Display method, and the cmdVerbs_Click event.

The PrepareForm procedure uses the .ObjectVerbCount property of the OLE container control to determine how many command buttons are to appear on the form. PrepareForm also uses the .ObjectVerbs property to set the button's caption. When the user clicks one of these buttons, the application invokes the DoVerb method.

The Display method enables a function from another form to specify which OLE container control should be used when displaying the form. By knowing which control to use, the form can then prepare itself (through PrepareForm) for use and display itself modally.

The cmdVerbs_Click event invokes a verb for the object in the visible OLE container control. This invocation is important because it enables the user to display, open, or edit the object.

Using Other Microsoft Applications That Don't Support OLE or DDE

If you want to use a Microsoft application that doesn't support OLE or DDE, your choices are limited to the following:

The next example program, shown in figures 27.8 and 27.9, demonstrates how to accomplish the first three alternatives. (I'll leave the last as an exercise for you.)

Fig. 27.8

The Stubborn program highlights the client area of any window on the screen.

Fig. 27.9

After you click on the desired window, the text from that window is inserted into the Stubborn program.

Figure 27.8 shows the 32-bit user interface of Stubborn, but figure 27.9 shows a totally different interface for the 16-bit version. Why? In Win32, the SetCapture API call requires the user to hold down the mouse while moving it over different processes. To force the user to do so, you design the user interface so that the user must drag an up-arrow pointer across the screen. When the user releases the mouse button, the operating system automatically calls ReleaseCapture for you.

In Win16, the behavior of SetCapture is exactly the opposite. SetCapture requires the user to press the mouse button down and then release it before the mouse pointer is captured. Once in "capture mode," the user can move the mouse around the screen without holding down the mouse button. After the user clicks on something, the operating system automatically calls ReleaseCapture for you. Figure 27.10 shows how you must design the 16-bit user interface to accommodate the 16-bit version of SetCapture.

Fig. 27.10

The 16-bit version of Stubborn requires a different user interface.

EXCHANGE.BAS (listing 27.8) is a good exercise in using the 16-and 32-bit Windows API to extend Visual Basic. The functions in this module enable an application to send or grab text to or from any window on the screen. The module starts by declaring the necessary API stuctures (or user-defined types) and function calls.

Listing 27.8 EXCHANGE.BAS, a Module for Exchanging Data Manually with Other Windows

'*****************************************************************
' 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

CaptureWindows (listing 27.9) is the most important function in the module because it contains the interface that enables the user to point and capture or exchange text from any window on the screen. The function gets the calling form's window handle (hWnd) and handles the Start, Move, and End events.

Listing 27.9 CaptureWindows enables users to point to the window of their choice

'*****************************************************************
' 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

Start (listing 27.10) performs some initialization steps and uses SetCapture to capture MouseMove events over the entire Windows desktop to the calling form.

Listing 27.10 The Start Event

...
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"

Move (listing 27.11) uses WindowFromPoint to determine the handle of the window under the mouse pointer. If the handle of the window differs from that of the last window, Move draws an inverted box around the window.

Listing 27.11 The Move Event

...
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

The most important part of this procedure is End (listing 27.12), which restores the screen back to normal and either grabs or sends text to or from the window under the cursor.

Listing 27.12 The End Event

...
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

The ExchangeData function (listing 27.13) performs the physical data exchange between your application and another application. The function begins by declaring some API constants and determining the type of control to which the user is pointing. After determining the control's type, ExchangeData sends a message requesting text from the control.

Listing 27.13 The ExchangeData 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)

Although the way that you communicate with each windows control type is similar, subtle differences exist that require that you handle each type of control separately. You handle combo and list boxes in the same way, except that they use different API constants. The key to capturing a list is to find out how many items are in the it (using ?B_GETCOUNT) and capture each line individually (using GETTEXT) by iterating through the list. The code in listing 27.14 demonstrates how you determine this number.

Listing 27.14 Capturing Text from a List

...
'*****************************************************************
' If it is a combo box, use combo functions to communicate.
'*************************************************************
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 procedure, 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

If the control isn't a combo or list box, then try WM_GETTEXT or WM_SETTEXT (see listing 27.15). These messages work on most standard Windows controls and some nonstandard controls.

Listing 27.15 Using the WM_GETTEXT or WM_SETTEXT Messages

...
'*****************************************************************
' 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

The next code segment is only called if ExchangeData cannot communicate with the control to which the user was pointing. Send the calling function some flaky error message so it can be distinguished from a valid return string.

...
'*************************************************************
' If you got here, then this function is unsuccessful.
'*************************************************************
' 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
GetClass simply returns the class name of a window:
'*****************************************************************
' 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

The InvertTracker procedure (listing 27.16) draws an inverted box around a window to indicate visually to the user the window with which they are about to communicate. This procedure simply gets a handle to the window's device context (an hDC) and draws the inverted box around it.

Listing 27.16 The InvertTracker Procedure

'*****************************************************************
' 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

A call to InvalidateRect with null parameters results in repainting the entire screen. CaptureWindows does this repainting just in case it left any ghost lines. Here is the call to InvalidateRect:

'*****************************************************************
' Force the entire screen to be repainted immediately.
'*****************************************************************
Private Sub RefreshScreen()
InvalidateRect 0, 0&, True
End Sub

FRMSTUB.FRM, the user interface for STUBBORN.VBP, provides the command buttons' functional code. It begins by setting up some necessary declarations and doing some form initialization routines. Next, the program lists a helper function, FileExists, followed by the Text1_Change event, which enables or disables the Send Text to a Window button. Listing 27.17 shows FRMSTUB.FRM.

Listing 27.17 FRMSTUB.FRM, the User Interface for STUBBORN.VBP

'*****************************************************************
' FRMSTUB.FRM: This program demonstrates how to communicate
' with apps that don't respond via DDE or OLE.
'*****************************************************************
Option Explicit
'*****************************************************************
' Form-level 16- & 32-bit API declarations.
'*****************************************************************
#If Win32 Then
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess& Lib "kernel32" (ByVal _
dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&)
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal _
hProcess As Long, lpExitCode As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias _
"LoadCursorA" (ByVal hInstance&, ByVal lpCursor&) As Long
Private Declare Function DrawIcon Lib "user32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal hIcon As Long) As Long
Private Const IDC_UPARROW = 32516&
#Else
Private Declare Function GetModuleUsage% Lib "Kernel" _
(ByVal hModule%)
#End If
'*****************************************************************
' Form-level variables.
'*****************************************************************
Private SendIt As Boolean, PointMode As Boolean
'*****************************************************************
' Form Initialization.
'*****************************************************************
Private Sub Form_Load()
'*****************************************************************
' Exchanging data is totally different in Win32, so readjust the
' visual appearance of the form for it. Win16 uses the default
' configuration set at design time.
'*****************************************************************
#If Win32 Then
Dim iX%, iY%, iDrawX%
'*************************************************************
' Change the ScaleMode to pixels and turn on AutoRedraw
'*************************************************************
ScaleMode = vbPixels
AutoRedraw = True
'*************************************************************
' Hide controls for use with Win16 and display Win32 controls.
'*************************************************************
cmd(0).Visible = False
cmd(1).Visible = False
Frame1.Visible = True
'*************************************************************
' Build positioning variables and set CurrentX & CurrentY
'*************************************************************
iX = Frame1.Left + Frame1.Width
CurrentX = iX
iDrawX = iX + ((ScaleWidth - iX) / 2) + 10
iY = Text1.Top + Text1.Height
iY = iY + ((ScaleHeight - (Frame1.Top + Frame1.Height)) _
/ 2) + 5
CurrentY = iY
'*************************************************************
' Draw MousePointer vbUpArrow
' into the form's persistent bitmap.
'*************************************************************
DrawIcon hdc, iDrawX, iY, LoadCursor(0, IDC_UPARROW)
'*************************************************************
' Give the user some instructions
' about why the arrow is painted
' on the form.
'*************************************************************
Print " Click & drag this arrow ->"
CurrentX = iX
Print " to exhange data."
#End If
'*************************************************************
' Hide controls for use with Win32 and display Win16 controls.
'*************************************************************
cmd(0).Visible = True
cmd(1).Visible = True
Frame1.Visible = False
'*************************************************************
' Centers the form to the screen
'*************************************************************
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
End Sub
'*****************************************************************
' This function checks to see if a file exists.
'*****************************************************************
Private Function FileExists(FileName$) As Boolean
On Error Resume Next
FileExists = IIf(Dir(FileName) <> "", True, False)
End Function
'*****************************************************************
' Only enable cmd(1) when it contains text.
'*****************************************************************
Private Sub Text1_Change()
cmd(1).Enabled = IIf(Text1 = "", False, True)
End Sub

cmd_Click processes command-button clicks. The action code for the first two buttons is in EXCHANGE.BAS's CaptureWindows function, this function contains the code for cmd(2):

'*****************************************************************
' Process command-button clicks.
'*****************************************************************
Private Sub cmd_Click(Index As Integer)
Dim hNotepad&, Source%, FileName$, msg$, Handle&, ExitCode&
Select Case Index
Case 0 ' Get
SendIt = False
PointMode = True
CaptureWindows "Start", Me, 0, 0, ""
Case 1 ' Send
SendIt = True
PointMode = True
CaptureWindows "Start", Me, 0, 0, ""

The SendKeys button (listing 27.18) starts Notepad, enters some text, and waits for the user to save the file and close Notepad. After Notepad stops running, the function continues by opening the data file and inserting it into Text1. Although not the best way to communicate with an application, the scheme certainly presents a valid, possible solution.

Listing 27.18 Handling the SendKeys Button

...
Case 2 ' Use SendKeys
'*****************************************************
' Build a temporary file name.
' Kill it if it already exists.
'*****************************************************
FileName = App.Path & "\~test~.txt"
If FileExists(FileName) Then Kill FileName
'*****************************************************
' Run Notepad maximized with the new file
' and store its task handle into a variable
' for later use.
'*****************************************************
hNotepad = Shell("notepad.exe " & FileName, _
vbNormalFocus)
'*****************************************************
' This statement hits Enter to create the new file.
'*****************************************************
SendKeys "~", True
'*****************************************************
' Build an instruction screen and insert it
' into Notepad.
'*****************************************************
msg = "Enter your text in here." & vbCrLf
msg = msg & "When you are done, quit "
msg = msg & "Notepad and save your changes."
SendKeys msg, True
'*****************************************************
' Finally, highlight the instructions so the user can
' easily delete them.
'*****************************************************
SendKeys "^+{Home}", True
'*****************************************************
' Wait while Notepad is still open.
'*****************************************************
#If Win32 Then
Handle = OpenProcess(PROCESS_QUERY_INFORMATION, _
False, hNotepad)
Do
GetExitCodeProcess Handle, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
#Else
Do While GetModuleUsage(hNotepad)
DoEvents
Loop
#End If
'*****************************************************
' Once Notepad is unloaded, open the file and insert
' it into Text1.
'*****************************************************
Source = FreeFile
Open FileName For Input As Source
Text1 = Input(LOF(Source), Source)
Close Source
'*****************************************************
' Kill the temporary file.
'*****************************************************
Kill FileName
End Select
End Sub

The next two procedures, MouseDown and MouseMove, execute only while the application is capturing the mouse. During this time, the application draws a box around the window to which the user is pointing. When the user chooses a window, the program calls ExchangeData. Listing 27.19 shows the code for these two procedures.

Listing 27.19 The MouseDown and MouseMove Events

'*****************************************************************
' Win32 version of SetCapture requires the left mouse button to be
' depressed in order to capture data from other processes and the
' MouseUp event automatically does a ReleaseCapture.
' This difference requires totally different code
' (and a different UI).
'*****************************************************************
#If Win32 Then
Private Sub Form_MouseDown(Button As Integer, Shift%, x!, y!)
'*********************************************************
' If opt(0) is checked, then send the text from Text1
' using the code already in cmd(0)'s click event.
' Otherwise, get text from another window using
' cmd(1)'s code.
'*********************************************************
If opt(0) Then
cmd_Click 0
Else
cmd_Click 1
End If
End Sub
'*************************************************************
' Stop capturing and exchange the text
' on the Form_MouseUp event.
'*************************************************************
Private Sub Form_MouseUp(Button As Integer, Shift%, x!, y!)
HandleMouse Button, Shift, x, y
End Sub
'*****************************************************************
' 16-bit version of MouseDown. MouseUp is ignored.
'*****************************************************************
#Else
'*************************************************************
' Stop capturing and exchange the text
' on the Form_MouseDown event
'*************************************************************
Private Sub Form_MouseDown(Button As Integer, Shift%, x!, y!)
HandleMouse Button, Shift, x, y
End Sub
#End If
'*****************************************************************
' Mouse code is the same for Win16 & Win32, but its called in
' different locations on the two platforms. Rather than repeating
' code, this code is entered once and called from the appropriate
' event.
'*****************************************************************
Private Sub HandleMouse(Button As Integer, Shift%, x!, y!)
Dim errStr$, retStr$
'*************************************************************
' Build a string that matches the return error value.
'*************************************************************
errStr = "Error:" & String(10, "~")
'*************************************************************
' Get text from a window.
'*************************************************************
If PointMode And SendIt = False Then
retStr = CaptureWindows("End", Me, x, y, "")
If retStr = errStr Then
MsgBox "Sorry, but that control didn't respond!", 48
Else
Text1 = retStr
End If
PointMode = False
'*************************************************************
' Send text to a window.
'*************************************************************
ElseIf PointMode And SendIt Then
retStr = CaptureWindows("End", Me, x, y, Text1)
If retStr = "0" Or retStr = errStr Then
MsgBox _
"Sorry, but that control will not accept text!", 48
End If
PointMode = False
End If
End Sub
'*****************************************************************
' During the PointMode, this window receives a mouse move
' for the entire desktop. This function causes a new highlight
' to be drawn.
'*****************************************************************
Private Sub Form_MouseMove(Button As Integer, Shift%, x!, y!)
If GetCapture() Then CaptureWindows "Move", Me, x, y, ""
End Sub
'*****************************************************************
' Only enable cmd(1) when it contains text.
'*****************************************************************
Private Sub Text1_Change()
cmd(1).Enabled = IIf(Text1 = "", False, True)
End Sub

Stubborn is a good sample program to use to test whether you can communicate with other applications. If Stubborn can't enable you to communicate with another application, you should contact the application's vendor to see whether you can try anything else. Finally, if all else fails, consider rewriting the application yourself. Although this isn't a great solution, it is necessary sometimes.

From Here...

Unfortunately, few resources are available that cover communications with other Microsoft applications. Of those that exist, however, the best include the following:

© 1996, QUE Corporation, an imprint of Macmillan Publishing USA, a Simon and Schuster Company.