Jeff Webb, Mike McKelvy, Ronald Martinsen, Taylor Maxwell, Michael Regelski September 1995 Special Edition Using Visual Basic 4 - Chapter 28 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 28

Integration with Multiple Office Applications


Eventually you will need to build an application that uses more than one Microsoft Office application. This project will probably involve a large programming team and will require weeks (or even months) to complete.

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

Creating a Large-Scale Integrated Application

This chapter's example, UseAll, is a integrated application that encompasses the most common obstacles to developing large-scale programs. This relatively small application doesn't do anything particularly useful except demonstrate some powerful techniques. Also, by using application-independent objects, the application demonstrates the importance of reusability.

Before viewing this application's code, this section presents the UseAll application's user interface. Figures 28.1 through 28.8 display the elements of this application's user interface. The figure captions describe the purpose of each element. This interface is designed to help a program manager accomplish the following:

Fig. 28.1

The interface's main window provides access to all the application's features.

Fig. 28.2

The first page of the Bug Report Wizard contains contact information about the person who submitted the bug report.

Fig. 28.3

The second page of the Bug Report Wizard contains system information about the person who submitted the bug report.

Fig. 28.4

The final page of the Bug Report Wizard is the actual bug reporting form used by all the applications that this company distributes.

Fig. 28.5

UseAll sends a bug summary to Excel for further analysis.

Fig. 28.6

Instead of viewing code as text, UseAll formats the text in Word for easy viewing.

Fig. 28.7

When a user clicks the embedded chart, UseAll automatically updates the chart by using OLE Automation and in-place activation.

Fig. 28.8

The user can edit Project and PowerPoint objects by right-clicking on the object and then choosing a verb.

Putting It All Together

This small application encompasses the most common obstacles of such projects. Although it doesn't do anything very useful, the application demonstrates how you can accomplish the following integration tasks:

The sample application in this chapter, UseAll, contains virtually no error handling, in the interest of keeping the example simple. However, you should never release an application without extensive error handling. Chapter 29, "Distributing Integrated Applications," demonstrates proper error-handling techniques.

Don't panic when you see code listing for this example. Although the listing is rather long, most of the code is relatively simple. Also, previous chapters have already discussed about 80 percent of the techniques that this example demonstrates. If you just take the application one file at a time, you shouldn't have any trouble understanding the material that the code presents.

SHARED.BAS�A Common Module

SHARED.BAS (listing 28.1) contains code that two or more files in this project use. The code provides a way for this project's files to set a window's AlwaysOnTop status and enables the application to show or hide a splash form.

The SetWindowPos API call used by the AlwaysOnTop routine in SHARED.BAS does not work while you are running this sample within the Visual Basic 4.0 IDE. However, when you compile your application and run it outside of the IDE, it will work as expected.

Listing 28.1 SHARED.BAS: Common Modules Are Useful for Application-Independence and Code Sharing

'*****************************************************************
' SHARED.BAS - This module contains code that is shared
' by two or more modules.
'*****************************************************************
Option Explicit
'*****************************************************************
' Declare SetWindowPos for AlwaysOnTop.
'*****************************************************************
#If Win32 Then
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd&, _
ByVal y As Long,ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Boolean
#Else
Private Declare Function SetWindowPos Lib "User" (ByVal hWnd%, _
ByVal hb%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, _
ByVal FLAGS%) As Integer
#End If
'*****************************************************************
' Forces a window to stay in front of all other windows.
'*****************************************************************
Public Sub AlwaysOnTop(FormName As Form, TopMost As Boolean)
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
'*************************************************************
' Set the window to TopMost, and ignore the return value.
'*************************************************************
If TopMost Then
SetWindowPos FormName.hWnd, HWND_TOPMOST, 0, 0, 0, 0, _
FLAGS
'*************************************************************
' Otherwise, return the window to its normal nontopmost state.
'*************************************************************
Else
SetWindowPos FormName.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, _
FLAGS
End If
End Sub
'*****************************************************************
' Displays and unloads the splash form.
'*****************************************************************
Public Sub SplashVisible(bState As Boolean, _
Optional ByVal sCaption)
If bState Then
sCaption = IIf(IsMissing(sCaption), _
"Loading...Please Wait!", sCaption)
With frmSplash
.lblMessage = sCaption
.Show
.Refresh
End With
Else
DoEvents
Unload frmSplash
End If
End Sub
'*****************************************************************
' This procedure draws a 3-D button (in either an up
' or down state), draws a picture, and prints a caption.
'*****************************************************************
Public Sub DrawButton(pBox As PictureBox, IsDown As Boolean, _
IsResource As Boolean, Optional ByVal sCaption, _
Optional ByVal sIcon)
Dim Offset%, where%, sTag$
'*************************************************************
' If the button is supposed to be down, offset it by 2 pixels.
'*************************************************************
On Error Resume Next
If IsDown Then Offset = 2
'*************************************************************
' The tag can contain a caption and a name of an sIcon.
' The format is "sCaption|sIcon". If a caption and icon were
' provided, then the tag is ignored.
'*************************************************************
sTag = Trim(pBox.Tag)
where = InStr(sTag, "|")
If sTag <> "" Then
sCaption = IIf(IsMissing(sCaption), _
Left(sTag, where - 1), sCaption)
sIcon = IIf(IsMissing(sIcon), Mid(sTag, where + 1), sIcon)
Else
sCaption = IIf(IsMissing(sCaption), "", sCaption)
sIcon = IIf(IsMissing(sIcon), "", sIcon)
End If
'*************************************************************
' Clear the picture box, and redraw the 3-D effect.
'*************************************************************
pBox.Cls
Draw3DPicBorder pBox, IsDown
'*************************************************************
' Paint the picture from a file, or icon resource, then
' vertically center position for the caption.
'*************************************************************
With pBox
If IsResource Then
.PaintPicture LoadResPicture(sIcon, vbResIcon), 10, _
((pBox.Height / 2) - 16) + Offset
Else
.PaintPicture LoadPicture(sIcon), 10, 4 + Offset
End If
.CurrentY = (pBox.Height / 2) - _
(pBox.TextHeight("X") / 2) + Offset
.CurrentX = 52
End With
'*************************************************************
' Draw the caption.
'*************************************************************
pBox.Print sCaption
End Sub

QUADRANT.BAS�Creating and Manipulating a Form's Region

QUADRANT.BAS manipulates one of four regions on a form. The module starts with GetQuadrants, which divides the form into four equal regions, starting from the upper-left corner and incrementing the regions from left to right and top to bottom. The drawing functions that follow simply enable you to perform drawing methods (some of which are predefined) on any of a form's four regions. Table 28.1 describes the remaining helper functions and their purpose. Listing 28.2 is the code for QUADRANT.BAS.

Table 28.1 QUADRANT.BAS Helper Functions

Helper Function Description
EqualToQuadClient Checks whether a given control is equal to the client area of a rectangle
GetQuad Sets a given RECT variable to the value of an existing quadrant
GetRectWidth Returns a rectangle's width
GetRectHeight Returns a rectangle's height
MoveRect Changes the left and top values of a rectangle without changing the right and bottom values
ResizeRect Inflates or deflates a rectangle from all sides or from the bottom
SizeToRectClient Resizes a control into the client area of a given rectangle

Listing 28.2 QUADRANT.BAS Is Helpful for the Cosmetics of USEALL.VBP

'*****************************************************************
' QUADRANT.BAS - This is a special rectangle module that performs
' several rectangle functions.
'*****************************************************************
Option Explicit
'*****************************************************************
' Expose a new rectangle data type.
'*****************************************************************
#If Win32 Then
Public Type RECT
rL As Long 'Left
rT As Long 'Top
rR As Long 'Right (This is NOT equal to Width)
rB As Long 'Bottom (This is NOT equal to Height)
End Type
Public Type PointAPI
x As Long
y As Long
End Type
#Else
Public Type RECT
rL As Integer 'Left
rT As Integer 'Top
rR As Integer 'Right (This is NOT equal to Width)
rB As Integer 'Bottom (This is NOT equal to Height)
End Type
Public Type PointAPI
x As Integer
y As Integer
End Type
#End If
'*****************************************************************
' API Declarations.
'*****************************************************************
#If Win32 Then
Public Declare Sub GetClientRect Lib "user32" _
(ByVal hWnd As Long, lpRect As RECT)
Public Declare Sub InflateRect Lib "user32" (lpRect As RECT, _
ByVal x As Long, ByVal y As Long)
Public Declare Function PtInRect Lib "user32" (lpRect As RECT, _
ByVal ptScreenX As Long, ByVal ptScreenY As Long) As Long
Public Declare Function ClientToScreen Lib "user32" _
(ByVal hWnd&, lpPoint As PointAPI) As Long
#Else
Public Declare Sub GetClientRect Lib "User" (ByVal hWnd%, _
lpRect As RECT)
Public Declare Sub InflateRect Lib "User" (lpRect As RECT, _
ByVal iX%, ByVal iY%)
Public Declare Sub ClientToScreen Lib "User" (ByVal hWnd%, _
lpPoint As PointAPI)
Public Declare Function PtInRect Lib "User" (lpRect As RECT, _
ByVal ptScreenY As Integer, ByVal ptScreenX As Integer) _
As Integer
' ptRect As PointAPI) As Integer
#End If
'*****************************************************************
' Private Module Variables
'*****************************************************************
Private Quad1 As RECT, Quad2 As RECT, Quad3 As RECT, Quad4 As RECT
'*****************************************************************
' Divides a form into 4 quadrants, starting with the upper-left
' corner (Q1), and continuing clockwise.
'*****************************************************************
Public Sub GetQuadrants(FormName As Form, Q1 As RECT, _
Q2 As RECT, Q3 As RECT, Q4 As RECT)
Dim FormWidth%, FormHeight%
'*************************************************************
' The form ScaleMode MUST be in pixels!
'*************************************************************
FormName.ScaleMode = vbPixels
'*************************************************************
' Determine the height & width of the forms client area.
'*************************************************************
FormWidth = FormName.ScaleWidth
FormHeight = FormName.ScaleHeight
'*************************************************************
' Set the 4 quad arguments and the module-level quads.
'*************************************************************
With Quad1
.rL = 0
.rT = 0
.rR = FormWidth / 2
.rB = FormHeight / 2
End With
Q1 = Quad1
With Quad2
.rL = FormWidth / 2
.rT = 0
.rR = FormWidth - 1
.rB = FormHeight / 2
End With
Q2 = Quad2
With Quad3
.rL = 0
.rT = FormHeight / 2
.rR = FormWidth / 2
.rB = FormHeight - 1
End With
Q3 = Quad3
With Quad4
.rL = FormWidth / 2
.rT = FormHeight / 2
.rR = FormWidth - 1
.rB = FormHeight - 1
End With
Q4 = Quad4
End Sub
'*****************************************************************
' Draw either a solid or hollow rectangle on a form.
'*****************************************************************
Public Sub DrawRect(FormName As Form, rRect As RECT, _
Solid As Boolean, Optional RectColor)
'*************************************************************
' If no color is provided, then use black.
'*************************************************************
RectColor = IIf(IsMissing(RectColor), RGB(0, 0, 0), RectColor)
'*************************************************************
' Draw the rectangle on the form.
'*************************************************************
If Solid Then
FormName.Line (rRect.rL, rRect.rT)-(rRect.rR, rRect.rB), _
RectColor, BF
Else
FormName.Line (rRect.rL, rRect.rT)-(rRect.rR, rRect.rB), _
RectColor, B
End If
End Sub
'*****************************************************************
' Draw a hollow 3-D rectangle. (Similar to the SSPanel3D control.)
'*****************************************************************
Public Sub Draw3DRect(FormName As Form, rRect As RECT, _
Inset As Boolean)
Dim LT&, BR&
'*************************************************************
' Set the L(eft)T(op) and B(ottom)R(ight) line colors.
'*************************************************************
LT = IIf(Inset, vb3DShadow, vb3DHighlight)
BR = IIf(Inset, vb3DHighlight, vb3DShadow)
'*************************************************************
' Draw the 4 lines.
'*************************************************************
FormName.Line (rRect.rL, rRect.rT)-(rRect.rL, rRect.rB), LT
FormName.Line (rRect.rL, rRect.rT)-(rRect.rR, rRect.rT), LT
FormName.Line (rRect.rR, rRect.rT)-(rRect.rR, rRect.rB), BR
FormName.Line (rRect.rL, rRect.rB)-(rRect.rR + 1, rRect.rB), _
BR
End Sub
'*****************************************************************
' Draw a hollow 3-D rectangle. (Similar to the SSPanel3D control.)
'*****************************************************************
Public Sub Draw3DPBRect(pBox As PictureBox, rRect As RECT, _
Inset As Boolean)
Dim LT&, BR&
'*************************************************************
' Set the L(eft)T(op) and B(ottom)R(ight) line colors.
'*************************************************************
LT = IIf(Inset, vb3DShadow, vb3DHighlight)
BR = IIf(Inset, vb3DHighlight, vb3DShadow)
'*************************************************************
' Draw the 4 lines.
'*************************************************************
pBox.Line (rRect.rL, rRect.rT)-(rRect.rL, rRect.rB), LT
pBox.Line (rRect.rL, rRect.rT)-(rRect.rR, rRect.rT), LT
pBox.Line (rRect.rR, rRect.rT)-(rRect.rR, rRect.rB), BR
pBox.Line (rRect.rL, rRect.rB)-(rRect.rR + 1, rRect.rB), BR
End Sub
'*****************************************************************
' Draw a hollow 3-D rectangle around the edge of the picture box.
'*****************************************************************
Public Sub Draw3DPicBorder(pBox As PictureBox, Inset As Boolean)
Dim rRect As RECT
'*************************************************************
' Get the client rect of the form.
'*************************************************************
GetClientRect pBox.hWnd, rRect
'*************************************************************
' Deflate the right & bottom of the rect by 1 pixel.
'*************************************************************
ResizeRect rRect, -1, -1, True
'*************************************************************
' Draw the 3-D rect, and repeat again.
'*************************************************************
Draw3DPBRect pBox, rRect, Inset
ResizeRect rRect, -1, -1, False
Draw3DPBRect pBox, rRect, Inset
End Sub
'*****************************************************************
' Draw a hollow 3-D rectangle around the edge of the form.
'*****************************************************************
Public Sub Draw3DFormRect(FormName As Form, Inset As Boolean)
Dim rRect As RECT
'*************************************************************
' Get the client rect of the form.
'*************************************************************
GetClientRect FormName.hWnd, rRect
'*************************************************************
' Deflate the right & bottom of the rect by 1 pixel.
'*************************************************************
ResizeRect rRect, -1, -1, True
'*************************************************************
' Draw the 3-D rect.
'*************************************************************
Draw3DRect FormName, rRect, Inset
End Sub
'*****************************************************************
' Inflates or deflates a rectangle from all sides or the bottom.
'*****************************************************************
Public Sub ResizeRect(rRect As RECT, iX%, iY%, _
KeepSameLT As Boolean)
'*************************************************************
' If KeepSameL(eft)T(op), then only operate on .rR & .rB.
'*************************************************************
If KeepSameLT Then
rRect.rR = rRect.rR + iX
rRect.rB = rRect.rB + iY
'*************************************************************
' Otherwise inflate or deflate all 4 sides.
'*************************************************************
Else
InflateRect rRect, iX, iY
End If
End Sub
'*****************************************************************
' Changes the left & top values of a rectangle.
'*****************************************************************
Public Sub MoveRect(rRect As RECT, ByVal iX%, ByVal iY%)
rRect.rL = rRect.rL + iX
rRect.rT = rRect.rT + iY
End Sub
'*****************************************************************
' Draws a 3-D grid on a form with 4 child quadrants.
'*****************************************************************
Public Sub Draw3DGrid(FormName As Form, Inset As Boolean, _
Optional ByVal Offset)
Dim InsideOffset%, OutsideOffset%
'*************************************************************
' Set the offset values.
'*************************************************************
On Error Resume Next
Offset = IIf(IsMissing(Offset), 10, Offset)
InsideOffset = Offset
OutsideOffset = Abs(IIf(IsMissing(Offset), 5, (Offset / 2)) _
- 1)
'*************************************************************
' This is a bit redundant, but it's necessary.
'*************************************************************
GetQuadrants FormName, Quad1, Quad2, Quad3, Quad4
'*************************************************************
' Draw the 4 3-D quadrants.
'*************************************************************
MoveRect Quad1, InsideOffset + 1, InsideOffset + 1
ResizeRect Quad1, -InsideOffset, -InsideOffset, True
Draw3DRect FormName, Quad1, Inset
MoveRect Quad2, OutsideOffset, InsideOffset + 1
ResizeRect Quad2, -InsideOffset - 1, -InsideOffset, True
Draw3DRect FormName, Quad2, Inset
MoveRect Quad3, InsideOffset + 1, OutsideOffset
ResizeRect Quad3, -InsideOffset, -InsideOffset, True
Draw3DRect FormName, Quad3, Inset
MoveRect Quad4, OutsideOffset, OutsideOffset
ResizeRect Quad4, -InsideOffset - 1, -InsideOffset, True
Draw3DRect FormName, Quad4, Inset
'*************************************************************
' Draw a 3-D border around the form.
'*************************************************************
Draw3DFormRect FormName, False
End Sub
'*****************************************************************
' Set a given RECT (Quad) to the value of a quadrant.
'*****************************************************************
Public Sub GetQuad(Quadrant%, Quad As RECT)
Select Case Quadrant
Case 1
Quad = Quad1
Case 2
Quad = Quad2
Case 3
Quad = Quad3
Case 4
Quad = Quad4
End Select
End Sub
'*****************************************************************
' Get the Width & Height of a rectangle.
'*****************************************************************
Public Function GetRectWidth(rRect As RECT) As Integer
GetRectWidth = rRect.rR - rRect.rL
End Function
Public Function GetRectHeight(rRect As RECT) As Integer
GetRectHeight = rRect.rB - rRect.rT
End Function
'*****************************************************************
' Size a control into the client area of a rectangle.
'*****************************************************************
Public Sub SizeToRectClient(Cntl As Control, rSourceRect As RECT)
Dim rRect As RECT
rRect = rSourceRect
ResizeRect rRect, -1, -1, False
Cntl.Move rRect.rL, rRect.rT, GetRectWidth(rRect), _
GetRectHeight(rRect)
End Sub
'*****************************************************************
' Check to see if a control is equal to the client area of a rect.
'*****************************************************************
Public Function EqualToQuadClient(Cntl As Control, _
rSourceRect As RECT) As Boolean
Dim rRect As RECT
'*************************************************************
' Since you can't pass rects by value, then create a new copy.
'*************************************************************
rRect = rSourceRect
'*************************************************************
' Resize the copy.
'*************************************************************
ResizeRect rRect, -1, -1, False
'*************************************************************
' If any are true, then return false.
'*************************************************************
If Cntl.Left <> rRect.rL Then GoSub ReturnFalse
If Cntl.top <> rRect.rT Then GoSub ReturnFalse
If Cntl.Width <> GetRectWidth(rRect) Then GoSub ReturnFalse
If Cntl.Height <> GetRectHeight(rRect) Then GoSub ReturnFalse
'*************************************************************
' If you got this far, then they are indeed equal.
'*************************************************************
EqualToQuadClient = True
Exit Function
'*****************************************************************
' Save yourself some typing by using a GoSub to here.
'*****************************************************************
ReturnFalse:
EqualToQuadClient = False
Exit Function
End Function
'*****************************************************************
' Converts a rectangle to screen coordinates.
'*****************************************************************
Public Sub ConvertRectToScreen(FormName As Form, _
rSourceRect As RECT)
Dim ptLT As PointAPI, ptRB As PointAPI
ptLT.x = rSourceRect.rL
ptLT.y = rSourceRect.rT
ptRB.x = rSourceRect.rR
ptRB.y = rSourceRect.rB
ClientToScreen FormName.hWnd, ptLT
ClientToScreen FormName.hWnd, ptRB
End Sub

BASWAVE.BAS�Playing .WAV Files

BASWAVE.BAS (listing 28.3) plays sound files from a resource file. The magic of this module lies in the API call to sndPlaySound in the multimedia library (MMSYSTEM.DLL) that comes with Windows 3.1.

Listing 28.3 BASWAVE.BAS Plays Wave Files from a File or Resource

'*****************************************************************
' BASWAVE.BAS - Plays a wave file from a resource.
'*****************************************************************
Option Explicit
#If Win32 Then
Private Declare Function PlaySound Lib "winmm.dll" Alias _
"PlaySoundA" (lpszName As Any, ByVal hModule&, _
ByVal dwFlags As Long) As Long
Private Declare Function sndPlaySound& Lib "winmm" Alias _
"sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long)
'*****************************************************************
' Flag values for uFlags parameter.
'*****************************************************************
Public Const SND_SYNC = &H0 ' Play synchronously (default)
Public Const SND_ASYNC = &H1 ' Play asynchronously
' **SEE NOTE IN PlayWavRes!!!!
Public Const SND_NODEFAULT = &H2 ' No default sound event is used
Public Const SND_MEMORY = &H4 ' lpszSoundName points to a
' memory file.
Public Const SND_ALIAS = &H10000' Name is a WIN.INI [sounds] entry
Public Const SND_FILENAME = &H20000 ' Name is a file name
Public Const SND_RESOURCE = &H40004
' Name is a resource name or atom
Public Const SND_ALIAS_ID = &H110000 ' Name is a WIN.INI [sounds]
' entry identifier.
Public Const SND_ALIAS_START = 0 ' Must be > 4096 to keep strings
' in same section of resource file.
Public Const SND_LOOP = &H8
' Loop the sound until next sndPlaySound
Public Const SND_NOSTOP = &H10
' Don't stop any currently playing sound
Public Const SND_VALID = &H1F ' Valid flags
Public Const SND_NOWAIT = &H2000' Don't wait if the driver is busy
Public Const SND_VALIDFLAGS = &H17201F ' Set of valid flag bits.
' Anything outside this range
' will raise an error.
Public Const SND_RESERVED = &HFF000000
' In particular these flags are reserved
Public Const SND_TYPE_MASK = &H170007
Public Const SND_PURGE = &H40 ' Purge nonstatic events for task
Public Const SND_APPLICATION = &H80
'Look for application-specific association
#Else
Private Declare Function sndPlaySound Lib "MMSYSTEM" ( _
lpszSoundName As Any, ByVal wFlags%) As Integer
'*****************************************************************
' Flag values for wFlags parameter.
'*****************************************************************
Public Const SND_SYNC = &H0 ' Play synchronously (default)
Public Const SND_ASYNC = &H1 ' Play asynchronously
' **SEE NOTE IN PlayWavRes!!!!
Public Const SND_NODEFAULT = &H2 ' Don't use default sound
Public Const SND_MEMORY = &H4
' lpszSoundName points to a memory file
Public Const SND_LOOP = &H8
' Loop the sound until next sndPlaySound
Public Const SND_NOSTOP = &H10
' Don't stop any currently playing sound
#End If
'*****************************************************************
' Plays a wave file from a resource.
'*****************************************************************
Public Sub PlayWaveRes(vntResourceID As Variant, _
Optional vntFlags)
Dim bytSound() As Byte
' Always store binary data in byte arrays!
bytSound = LoadResData(vntResourceID, "WAVE")
'*************************************************************
' If no flags were provided, then set the defaults.
'*************************************************************
If IsMissing(vntFlags) Then
vntFlags = SND_NODEFAULT Or SND_SYNC Or SND_MEMORY
End If
'*************************************************************
' Make sure the SND_MEMORY bit is set.
'*************************************************************
If (vntFlags And SND_MEMORY) = 0 Then
vntFlags = vntFlags Or SND_MEMORY
End If
'*************************************************************
' WARNING: If you want to play sound files asynchronously in
' Win32, you MUST change bytSound() from a local
' variable to a module-level or static variable.
' Doing this prevents your array from being
' destroyed before sndPlaySound is complete.
' If you fail to do this, you will pass an invalid
' memory pointer, which will cause a GPF in MCI.
'*************************************************************
If (vntFlags And SND_ASYNC) Then
' Turn off SND_ASYNC if present
vntFlags = vntFlags Xor SND_ASYNC
End If
'*************************************************************
' Pass the address of the first element in the byte array
' to play the wave file.
'*************************************************************
If sndPlaySound(bytSound(0), vntFlags) = False Then
MsgBox "PlayWaveRes failed!", vbCritical
End If
End Sub
Public Sub PlayWaveFile(strFileName As String, Optional vntFlags)
'*************************************************************
' If no flags were provided, then set the defaults.
'*************************************************************
If IsMissing(vntFlags) Then
vntFlags = SND_NODEFAULT Or SND_SYNC
End If
'*************************************************************
' Turn off SND_MEMORY if present.
'*************************************************************
If (vntFlags And SND_MEMORY) Then
vntFlags = vntFlags Xor SND_MEMORY
End If
'*************************************************************
' Play the wave (BE SURE TO USE ByVal!!!!).
'*************************************************************
If sndPlaySound(ByVal strFileName, vntFlags) = False Then
MsgBox "PlayWaveFile failed!", vbCritical
End If
End Sub

GENERIC.CLS�a Simple Database Class

GENERIC.CLS (listing 28.4) is a useful database class that you can use in any project. Its purpose is to simplify the data-access features of Visual Basic 4.0 by making them easier to use. The class begins by declaring some necessary variables and initialization and continues by performing some extensive data-access functions.

GENERIC.CLS requires your project to have a reference to the Microsoft DAO 2.5/3.0 Compatibility Object Library. If you attempt to run this example without this reference, you get an error.

Listing 28.4 GENERIC.CLS: A Reusable Generic Database Class

'*****************************************************************
' GENERIC.CLS - A database class with a set of common routines.
'*****************************************************************
Option Explicit
'*****************************************************************
' Class data members
'*****************************************************************
Private WSpace As Workspace ' Class Workspace
Private DBase As Database ' Class Database
Private RecSet As Recordset ' Main Class RecordSet
Private DBFileName As String ' File name of the database
Private TBDef As TableDef ' For creating new tables
Private FieldName As Field ' For creating new fields
'*****************************************************************
' This procedure creates the default workspace
'*****************************************************************
Private Sub Class_Initialize()
Set WSpace = DBEngine.Workspaces(0)
End Sub
'*****************************************************************
' The recordset, database, and workspace are closed when
' the object goes out of scope to prevent corrupting the database.
'*****************************************************************
Private Sub Class_Terminate()
On Error Resume Next
RecSet.Close
DBase.Close
WSpace.Close
End Sub
...

GENERIC.CLS provides six read-only properties�GetWorkspace, GetDatbase, Data, NewTable, NewField, and Filename�that enable calling functions to manipulate the database directly in ways that the class itself does not provide. Listing 28.5 shows the code for these properties.

Listing 28.5 Helpful Properties Provided by the GenericDB Class

...
'*****************************************************************
' Returns a reference to the workspace.
'*****************************************************************
Public Property Get GetWorkspace() As Workspace
Set GetWorkspace = WSpace
End Property
'*****************************************************************
' Returns a reference to the database.
'*****************************************************************
Public Property Get GetDatabase() As Database
Set GetDatabase = DBase
End Property
'*****************************************************************
' Returns a reference to the currently open recordset.
'*****************************************************************
Public Property Get Data() As Recordset
Set Data = RecSet
End Property
'*****************************************************************
' Returns a reference to the open TableDef.
'*****************************************************************
Public Property Get NewTable() As TableDef
Set NewTable = TBDef
End Property
'*****************************************************************
' Returns a reference to the currently open field definition.
'*****************************************************************
Public Property Get NewField() As Field
Set NewField = FieldName
End Property
'*****************************************************************
' Returns the file name of the database that is currently open.
'*****************************************************************
Public Property Get FileName() As String
FileName = DBFileName
End Property

The most common data-access method is OpenDatabase, which makes data access easier and more reliable. The method first ensures that the file exists; if it does, OpenDatabase tries to open the file. If the method cannot open the database, it prompts the user to repair the possibly corrupt database. Listing 28.6 shows the a custom OpenDatabase method called OpenDB.

Listing 28.6 The OpenDB Method

'*****************************************************************
' Opens a database for use with this class.
'*****************************************************************
Public Sub OpenDB(File$, Optional OpenExclusive, _
Optional OpenReadOnly)
Dim res%
'*************************************************************
' If any arguments are missing, add default values.
'*************************************************************
On Error Resume Next
If Not IsMissing(File) Then DBFileName = File
If IsMissing(OpenExclusive) Then OpenExclusive = False
If IsMissing(OpenReadOnly) Then OpenReadOnly = False
'*************************************************************
' Convert the arguments into valid Booleans.
'*************************************************************
OpenExclusive = CBool(OpenExclusive)
OpenReadOnly = CBool(OpenReadOnly)
'*************************************************************
' Open the database.
'*************************************************************
Set DBase = WSpace.OpenDatabase(DBFileName, OpenExclusive, _
OpenReadOnly)
'*************************************************************
' If the database is corrupted, then prompt to repair it.
'*************************************************************
If Err = 3049 Then
res = MsgBox(Error & vbLf & vbLf & _
"Would you like attempt to repair this database?", _
vbQuestion + vbYesNo)
'*********************************************************
' If no, then bug out.
'*********************************************************
If res = vbNo Then Exit Sub
'*********************************************************
' Otherwise repair it, clear the error flag,
' and try again.
'*********************************************************
Repair DBFileName: Err = 0
Set DBase = WSpace.OpenDatabase(DBFileName, _
OpenExclusive, OpenReadOnly)
'*********************************************************
' If there is another error, then give up.
'*********************************************************
If Err Then
MsgBox "An attempt to open the database failed!", _
vbCritical
End If
'*************************************************************
' If some other error, then just report it.
'*************************************************************
ElseIf Err <> 0 And Err <> 3049 Then
MsgBox Error, vbExclamation
End If
End Sub

CreateRecordset (listing 28.7) creates a recordset for use with the methods in this class. If you don't specify a recordset type, the procedure assumes a dynaset.

Listing 28.7 The CreateRecordset Method

'*****************************************************************
' Creates a recordset for use with this class.
'*****************************************************************
Public Sub CreateRecordSet(Source$, Optional ViewType, _
Optional Options)
'*************************************************************
' If any arguments are missing, add default values.
'*************************************************************
If IsMissing(ViewType) Then ViewType = dbOpenDynaset
If IsMissing(Options) Then
Set RecSet = DBase.OpenRecordset(Source, CInt(ViewType))
Else
Set RecSet = DBase.OpenRecordset(Source, CInt(ViewType), _
CInt(Options))
End If
End Sub

The methods in listing 28.8�Create, MakeTable, AddTable, MakeField, AddField, and MakeIndex�simplify the process of creating a database and appending fields and indexes to a database.

Listing 28.8 Database and Table Creation Methods

'*****************************************************************
' Creates a new database.
'*****************************************************************
Public Sub Create(File$)
If Not IsMissing(File) Then DBFileName = File
Set DBase = WSpace.CreateDatabase(DBFileName, dbLangGeneral)
End Sub
'*****************************************************************
' Creates a TableDef.
'*****************************************************************
Public Sub MakeTable(TableName As String)
Set TBDef = DBase.CreateTableDef(TableName)
End Sub
'*****************************************************************
' Writes the TableDef to the table, so a new table can be created.
'*****************************************************************
Public Sub AddTable()
DBase.TableDefs.Append TBDef
Set TBDef = Nothing
End Sub
'*****************************************************************
' Creates a new field definition. Other attributes
' should be set by obtaining the NewField reference,
' and make the changes directly.
'*****************************************************************
Public Sub MakeField(FName$, FType%, Optional FSize)
Set FieldName = TBDef.CreateField(FName, FType)
If Not IsMissing(FSize) Then FieldName.Size = CInt(FSize)
End Sub
'*****************************************************************
' Writes the field definition to the current TableDef.
'*****************************************************************
Public Sub AddField()
TBDef.Fields.Append FieldName
Set FieldName = Nothing
End Sub
'*****************************************************************
' Writes a index to a TableDef.
'*****************************************************************
Public Sub MakeIndex(FldName$, PrimaryKey As Boolean, _
UniqueKey As Boolean)
Dim NewIndex As New Index ' For creating new indexes
With NewIndex
.Name = "idx" & FldName
.Fields = FldName
.Primary = PrimaryKey
.Unique = IIf(PrimaryKey, True, UniqueKey)
End With
TBDef.Indexes.Append NewIndex
End Sub

The next three methods�GetData, GetArrayData, and GetControlData�provide an easy way to return all the records in a field either as a string or in an array or control. The key to the success of these functions is to start at the first record in the table and iterate through to the last. Listing 28.9 shows these three methods.

Listing 28.9 Methods That Return a Field's Records

'*****************************************************************
' Returns all (up to ~32k) of the records of a field
' in a delimited string. This is a useful feature
' for inserting data into a text box.
'*****************************************************************
Public Function GetData(FName$, ByVal Delimiter$) As String
Dim res$, retStr$
'*************************************************************
' Move to the first record.
'*************************************************************
On Error Resume Next
RecSet.MoveFirst
'*************************************************************
' Build a large (<=~32k) delimited string of the records.
'*************************************************************
Do While Not RecSet.EOF
res = Trim(RecSet(FName))
If Len(res) + Len(retStr) > 32001 Then Exit Do
retStr = retStr & res & Delimiter
RecSet.MoveNext
Loop
'*************************************************************
' Return to the first record, and return the results.
'*************************************************************
RecSet.MoveFirst
GetData = retStr
End Function
'*****************************************************************
' Same as GetData, but the data is stored in an array.
'*****************************************************************
Public Sub GetArrayData(FName$, retArray() As String)
Dim res$, retStr$, i%
On Error Resume Next
Erase retArray
RecSet.MoveFirst
Do While Not RecSet.EOF
res = Trim(RecSet(FName))
If Len(res) + Len(retStr) > 32001 Then Exit Do
If Not IsNull(res) Then
retStr = retStr & res
ReDim Preserve retArray(i + 1)
retArray(i) = res
i = i + 1
End If
RecSet.MoveNext
Loop
RecSet.MoveFirst
End Sub
'*****************************************************************
' Same as GetData, but the data is loaded into a control.
' The control MUST either be a list or combo box in order
' for this method to work.
'*****************************************************************
Public Sub GetControlData(FName$, CtrlName As Control)
Dim res$, retStr$
On Error Resume Next
RecSet.MoveFirst
Do While Not RecSet.EOF
res = Trim(RecSet(FName))
If Len(res) + Len(retStr) > 32001 Then Exit Do
If Not IsNull(res) Then
retStr = retStr & res
CtrlName.AddItem res
End If
RecSet.MoveNext
Loop
CtrlName.ListIndex = 0
RecSet.MoveFirst
End Sub

AddOrEditRecord adds a new record or edits an existing one. Its first argument determines whether to add or edit the data that the FieldPipeValue parameter array stores. The second parameter, FieldPipeValue, is a parameter array that contains values delimited by the pipe character (|), in the form Field Name|Value.

This function begins by ensuring that the parameter array isn't empty, and then sets the current recordset's .Add or .Edit property based on the action specified the AddRec parameter. Next, AddOrEditRecord iterates through the parameter array, determines the data type, and updates the recordset. Listing 28.10 shows the AddOrEditRecord method.

Listing 28.10 The AddOrEditRecord Method Manipulates Data at the Record Level

'*****************************************************************
' Adds a new record, or edits an existing one.
' This method should not be used when adding or
' editing > 20 records (for performance reasons).
'*****************************************************************
Public Sub AddOrEditRecord(ByVal AddRec As Boolean, _
ParamArray FieldPipeValue())
Dim NumItems%, i%, where%, FName$, FValue
'*************************************************************
' Find out how many parameters were passed.
' If none, then exit.
'*************************************************************
On Error Resume Next
NumItems = UBound(FieldPipeValue)
If IsEmpty(FieldPipeValue(0)) Then Exit Sub
'*************************************************************
' Determine whether to add or edit the record.
'*************************************************************
If AddRec Then
RecSet.AddNew
Else
RecSet.Edit
'*********************************************************
' If there was no current record, then notify the user.
'*********************************************************
If Err = 3021 Then
MsgBox "Since there is no current record,
it cannot be edited.", vbCritical
Exit Sub
End If
End If
'*************************************************************
' If loop through each parameter.
'*************************************************************
For i = 0 To NumItems
'*********************************************************
' Separate the field name from its value.
'*********************************************************
FName = FieldPipeValue(i)
where = InStr(FName, "|")
If where = 0 And i > 1 Then
Exit For
ElseIf where = 0 And i < 1 Then
Exit Sub
End If
FValue = Mid(FName, where + 1)
FName = CStr(Left(FName, where - 1))
'*********************************************************
' Determine the record type, and convert the value.
'*********************************************************
Select Case RecSet(FName).Type
Case dbBoolean
RecSet(FName) = CBool(FValue)
Case dbByte, dbInteger
RecSet(FName) = CInt(FValue)
Case dbLong
RecSet(FName) = CLng(FValue)
Case dbCurrency
RecSet(FName) = CCur(FValue)
Case dbSingle
RecSet(FName) = CSng(FValue)
Case dbDouble
RecSet(FName) = CDbl(FValue)
'*****************************************************
' Otherwise it must be a dbDate, dbText,
' dbLongBinary, & dbMemo.
'*****************************************************
Case Else
where = RecSet(FName).Size
'*************************************************
' If the record is too long, then clip it.
'*************************************************
If where And (Len(FValue) > where) Then
FValue = Left(FValue, where)
ElseIf Len(FValue) > 32000 Then
FValue = Left(FValue, 32000)
End If
RecSet(FName) = FValue
End Select
Next i
'*************************************************************
' Complete the transaction.
'*************************************************************
RecSet.Update
End Sub

The next four methods�MFirst, MLast, MNext, and MPrev�navigate through the recordset and return the current record. The last two methods�FindRecord and GetRecord�provide methods for searching for a specific record and retrieving the current record. Listing 28.11 contains all six of these methods.

Listing 28.11 GENERIC.CLS Recordset Navigation Methods

'*****************************************************************
' Move to the first record.
'*****************************************************************
Public Function MFirst(Optional FName) As String
On Error Resume Next
If RecSet.Type = 2 Then Exit Function
RecSet.MoveFirst
If Not IsMissing(FName) Then
MFirst = Trim(RecSet(CStr(FName)))
End If
End Function
'*****************************************************************
' Move to the last record.
'*****************************************************************
Public Function MLast(Optional FName) As String
On Error Resume Next
RecSet.MoveLast
If Not IsMissing(FName) Then
MLast = Trim(RecSet(CStr(FName)))
End If
End Function
'*****************************************************************
' Move to the next record.
'*****************************************************************
Public Function MNext(Optional FName) As String
On Error Resume Next
RecSet.MoveNext
If RecSet.EOF Then RecSet.MoveLast
If Not IsMissing(FName) Then
MNext = Trim(RecSet(CStr(FName)))
End If
End Function
'*****************************************************************
' Move to the previous record.
'*****************************************************************
Public Function MPrev(Optional FName) As String
On Error Resume Next
If RecSet.Type = 2 Then Exit Function
RecSet.MovePrevious
If RecSet.BOF Then RecSet.MoveFirst
If Not IsMissing(FName) Then
MPrev = Trim(RecSet(CStr(FName)))
End If
End Function
'*****************************************************************
' Locates a record, and returns its result.
'*****************************************************************
Public Function FindRecord(FName$, FindWhat, Optional ByVal _
ExactMatch) As Variant
'*************************************************************
' Determine whether to find a similar or exact match.
'*************************************************************
On Error Resume Next
ExactMatch = IIf(IsMissing(ExactMatch), True, ExactMatch)
'*************************************************************
' Start at the beginning, and find the record.
'*************************************************************
RecSet.MoveFirst
If ExactMatch Then
RecSet.FindFirst FName & " = '" & FindWhat & "'"
Else
RecSet.FindFirst "[" & FName & "] LIKE '" & FindWhat & "'"
End If
'*************************************************************
' If no match, then return "".
'*************************************************************
FindRecord = IIf(RecSet.NoMatch, "", _
FindRecord = RecSet(FName))
End Function
'*****************************************************************
' Returns a record from a specific field.
'*****************************************************************
Public Function GetRecord(FName$) As Variant
On Error Resume Next
GetRecord = RecSet(FName)
End Function

Databases sometimes become damaged, so the Repair method (listing 28.12) provides a cleaner way to repair and compact a corrupted database.

Listing 28.12 The Repair Method

'*****************************************************************
' Repairs and compacts a damaged database.
'*****************************************************************
Public Sub Repair(FileName$)
Dim BakFileName$, res%
'*************************************************************
' Make a copy of the database to work on.
'*************************************************************
On Error Resume Next
BakFileName = Left(FileName, InStr(FileName, ".")) & "BAK"
FileCopy FileName, BakFileName
DBEngine.RepairDatabase BakFileName
'*************************************************************
' If it was successfully repaired, then kill the original.
'*************************************************************
If Err = 0 Then
Kill FileName
'*********************************************************
' Repaired databases should be compacted, so do it now.
'*********************************************************
DBEngine.CompactDatabase BakFileName, FileName
'*********************************************************
' If it succeeded, ask users if they want to delete
' the backup copy.
'*********************************************************
If Err = 0 Then
If MsgBox("Would you like to delete the backup file?", _
vbYesNo + vbQuestion) = vbYes Then Kill BakFileName
End If
End If
End Sub

PRETTY.CLS�Creating Word-Formatted Copies

PRETTYPR.CLS (listing 28.13) is a class that shows off the power of OLE Automation with Microsoft Word, by performing several methods to create a formatted copy of a given Visual Basic code file. The class begins by declaring some useful constants and properties.

Listing 28.13 The PRETTYPR.CLS Class Formats VB Code in Word

'*****************************************************************
' PRETTYPR.CLS: Reads a Visual Basic file and displays a formatted
' copy in Microsoft Word 6.0 or 7.0.
'*****************************************************************
Option Explicit
Option Compare Text
'*****************************************************************
' Private Member Variables
'*****************************************************************
Private ColorDeclare%, ColorComment%, ColorFunction%
Private ColorSub%, ColorContinueChar%, ColorDefault%
Private Word As Object, SourceFile As Integer
Private DocFileName As String, ErrValue%, bRestore As Boolean
'*****************************************************************
' Private Member Constants
'*****************************************************************
Private Const FIND_CONTINUE_CHAR = " _"
Private Const FIND_COMMENT = "'"
Private Const FIND_DECLARE = "Declare"
Private Const FIND_FUNCTION = "Function"
Private Const FIND_PROPERTY = "Property"
Private Const FIND_SUB = "Sub"
'*****************************************************************
' Private Member Color Constants
'*****************************************************************
Private Const wordAutomatic = 0
Private Const wordBlack = 1
Private Const wordBlue = 2
Private Const wordCyan = 3
Private Const wordGreen = 4
Private Const wordMagenta = 5
Private Const wordRed = 6
Private Const wordYellow = 7
Private Const wordWhite = 8
Private Const wordDarkBlue = 9
Private Const wordDarkCyan = 10
Private Const wordDarkGreen = 11
Private Const wordDarkMagenta = 12
Private Const wordDarkRed = 13
Private Const wordDarkYellow = 14
Private Const wordDarkGray = 15
Private Const wordLightGray = 16
'*****************************************************************
' The following 6 properties are used to change the colors used to
' display certain elements.
'*****************************************************************
Public Property Let clrContinueChar(iColor As Integer)
ColorContinueChar = iColor
End Property
Public Property Let clrComment(iColor As Integer)
ColorComment = iColor
End Property
Public Property Let clrDeclare(iColor As Integer)
ColorDeclare = iColor
End Property
Public Property Let clrDefault(iColor As Integer)
ColorDefault = iColor
End Property
Public Property Let clrFunction(iColor As Integer)
ColorFunction = iColor
End Property
Public Property Let clrSub(iColor As Integer)
ColorSub = iColor
End Property
'*****************************************************************
' Expose the Word object in case the user wants to perform
' additional file processing.
'*****************************************************************
Public Property Set GetWord(obj As Object)
Set obj = Word
End Property
'*****************************************************************
' This property lets you set the visible state of Word.
'*****************************************************************
Public Property Let Visible(bShowWindow As Boolean)
If bShowWindow Then
Word.AppHide
Word.AppShow
Else
Word.AppHide
End If
End Property
Public Property Get Errors() As Integer
Errors = ErrValue
End Property

The application calls the Initialize event (shown in listing 28.14) for this class when you first access any member or method in the clsPrettyPrint class. This event displays a splash screen while attempting to create a Word object. In addition, the procedure initializes class variables with default values. When the class is destroyed, the Terminate event sets the Word object equal to Nothing to free up the memory that the Word object is using. Listing 28.14 shows both of these events.

Listing 28.14 The Initialize and Terminate Events

'*****************************************************************
' Initialize all member variables.
'*****************************************************************
Private Sub Class_Initialize()
On Error Resume Next
frmProgress.Update 0, "Establishing a connection with Word..."
frmProgress.Refresh
ColorDefault = wordAutomatic
ColorContinueChar = wordRed
ColorFunction = wordDarkBlue
ColorDeclare = wordDarkCyan
ColorComment = wordDarkGreen
SourceFile = FreeFile
OLEConnect Word, "Word.Basic"
End Sub
'*****************************************************************
' Release the memory use by Word.
'*****************************************************************
' WARNING: If Word wasn't already running, then all changes
' will be lost. If you want to save the changes,
' you must access the Word object and save them manually.
'*****************************************************************
Private Sub Class_Terminate()
On Error Resume Next
If bRestore Then Word.ToggleFull
Unload frmProgress
Set Word = Nothing
End Sub

The PrettyPrint (listing 28.15) is the key method in the clsPrettyPrint class. It provides an interface for the calling module to format the document and display the results. The method begins by displaying a splash screen while opening a new document based on the PRETTYPR.DOT template. PrettyPrint then prints a header and reads the code from the file. The method reads each line and inserts and formats it into Word. On reaching the end of the file, PrettyPrint displays the results for the user.

Listing 28.15 The PrettyPrint Method

'*****************************************************************
' Inserts a formmated copy of a VB file into Word.
'*****************************************************************
Public Sub PrettyPrint(FileName As String, Optional Header)
Dim Look$
'*************************************************************
' Change the pointer, open a new file, and print the header.
'*************************************************************
On Error GoTo PrettyPrint_Err
frmProgress.Update 0, "Initializing..."
Screen.MousePointer = vbHourglass
Word.FileNew Template:=App.Path & "\prettypr.dot"
PrintHeader IIf(IsMissing(Header), FileName, Header)
'*************************************************************
' Open the file as READ ONLY, and examine every line.
'*************************************************************
Open FileName For Input Access Read As SourceFile
Do While Not EOF(SourceFile)
Line Input #SourceFile, Look
frmProgress.Update (Seek(SourceFile) / _
LOF(SourceFile)) * 100, "Reading " & _
LCase(FileName) & "..."
ExamineLine Look
Loop
Close SourceFile
frmProgress.Update 100, "Complete!"
'*************************************************************
' Change the margins, and view it at 90% in Normal mode.
'*************************************************************
DisplayResults IIf(MsgBox( _
"Would you like to view your results in full-screen mode?", _
vbQuestion + vbYesNo) = vbYes, True, False)
With Word
.FilePageSetup TopMargin:="0.25", BottomMargin:="0.25", _
LeftMargin:="0.25", RightMargin:="0.25"
.ViewNormal
.ViewZoom ZoomPercent:="90%"
End With
'*************************************************************
' When you are done, restore the pointer and create
' a Word file name.
'*************************************************************
DocFileName = Left(FileName, InStr(FileName, ".")) & "DOC"
Screen.MousePointer = vbDefault
Unload frmProgress
Exit Sub
PrettyPrint_Err:
Unload frmProgress
MsgBox Error, vbCritical
Screen.MousePointer = vbDefault
ErrValue = Err
Exit Sub
End Sub

The next two procedures are responsible for formatting the document. PrintHeader inserts a formatted header line at the top of the first page. The procedure prints this line to describe which file the document contains. ExamineLine determines how to format the line and sends the line to the appropriate procedure for processing. Listing 28.16 shows both of these procedures.

Listing 28.16 The PrintHeader and ExamineLine Procedures

'*****************************************************************
' This is the first line printed before the file is inserted.
'*****************************************************************
Private Sub PrintHeader(Header As String)
'*************************************************************
' Change the current font, and insert the header.
'*************************************************************
ChangeFont sFont:="Arial", bBold:=1, sPoints:="14"
With Word
.Insert Header
.FormatParagraph After:="6 pt"
.InsertPara
.FormatParagraph After:="0 pt"
End With
End Sub
'*****************************************************************
' Determine how the line should be formatted.
'*****************************************************************
Private Sub ExamineLine(Source As String)
Dim where%
'*************************************************************
' Check for a Sub, Function, Property, and regular line,
' respectively.
'*************************************************************
where = InStr(Source, FIND_SUB)
If where Then
FormatProceedure where, Source
Else
where = InStr(Source, FIND_FUNCTION)
where = IIf(where, where, InStr(Source, FIND_PROPERTY))
If where Then
FormatProceedure where, Source
Else
FormatDefault Source
End If
End If
End Sub

The next four procedures�FormatProcedure, FormatDefault, FormatComment, and FormatDeclaration�actually format and insert the line into Word. Each of these functions looks for a specific keyword (such as Sub, Function, or neither) and formats the line appropriately. If any of the lines contain comment characters, the function handles them appropriately as well. Listing 28.17 shows the code for these four functions. This code isn't actually as complicated as it looks. The key is to take each line and formatting option separately.

Listing 28.17 PRETTYPR.CLS' Functions for Formatting Lines in Word through OLE Automation

'*****************************************************************
' This procedure handles the formatting of properties, subs, and
' functions.
'*****************************************************************
Private Sub FormatProcedure(where%, Source$)
Dim CommentPresent%, DeclarePresent%
'*************************************************************
' Search for comments and external declarations.
'*************************************************************
CommentPresent = InStr(Source, FIND_COMMENT)
DeclarePresent = InStr(Source, FIND_DECLARE)
'*************************************************************
' If this line is really a procedure and not a Exit Sub, Exit
' Function, or API declaration, then continue.
'*************************************************************
If where And InStr(Source, _
"Exit ") = 0 And DeclarePresent = 0 Then
'*********************************************************
' Change the font.
'*********************************************************
ChangeFont bBold:=1, iColor:=ColorFunction
'*********************************************************
' If a comment is present, split the line for formatting.
'*********************************************************
If CommentPresent Then
Word.Insert Left(Source, CommentPresent - 1)
FormatComment CommentPresent, Source
'*********************************************************
' If there is a line-continuation char, then...
'*********************************************************
ElseIf Right(Source, 2) = FIND_CONTINUE_CHAR Then
'*****************************************************
' Loop while the current line has line-continue char.
'*****************************************************
Do While Right(Source, 2) = FIND_CONTINUE_CHAR
Word.Insert Left(Source, Len(Source) - 2)
'*************************************************
' Format the continuation char, so it sticks out.
'*************************************************
ChangeFont bBold:=1, iColor:=ColorContinueChar
Word.Insert Right(Source, 2)
Word.InsertPara
ChangeFont bBold:=1, iColor:=ColorFunction
'*************************************************
' Read the next line.
'*************************************************
Line Input #SourceFile, Source
frmProgress.Update (Seek(SourceFile) \ _
LOF(SourceFile)) * 100
Loop
Word.Insert Source
Word.InsertPara
Else
Word.Insert Source
Word.InsertPara
End If
'*************************************************************
' If it is an external declartion, then process it.
'*************************************************************
ElseIf DeclarePresent Then
FormatDeclaration Source
'*************************************************************
' Otherwise, it must be a normal line.
'*************************************************************
Else
FormatDefault Source
End If
End Sub
'*****************************************************************
' Formats a line with the default formatting.
'*****************************************************************
Private Sub FormatDefault(ByVal Source$)
Dim where%
'*************************************************************
' If there is a line continuation char,
' then loop and format each continued line.
'*************************************************************
If Right(Source, 2) = FIND_CONTINUE_CHAR Then
Do While Right(Source, 2) = FIND_CONTINUE_CHAR
ChangeFont
Word.Insert Left(Source, Len(Source) - 2)
ChangeFont bBold:=1, iColor:=ColorContinueChar
Word.Insert Right(Source, 2)
Word.InsertPara
Line Input #SourceFile, Source
frmProgress.Update (Seek(SourceFile) \ _
LOF(SourceFile)) * 100
Loop
ChangeFont
Word.Insert Source
Word.InsertPara
'*************************************************************
' Otherwise use the default format and check for comments.
'*************************************************************
Else
ChangeFont
where = InStr(Source, FIND_COMMENT)
If where Then
Word.Insert Left(Source, where - 1)
FormatComment where, Source
Else
Word.Insert Source
Word.InsertPara
End If
End If
End Sub
'*****************************************************************
' Formats a comment in italics.
'*****************************************************************
Private Sub FormatComment(where%, Source)
'*************************************************************
' Change the font to italics, and print the rest of the line.
'*************************************************************
ChangeFont bItalic:=1, iColor:=ColorComment
Word.Insert Mid(Source, where)
Word.InsertPara
End Sub
'*****************************************************************
' Formats a declare statement like the default, but it's colored.
'*****************************************************************
Private Sub FormatDeclaration(Source$)
Dim CommentPresent%
'*************************************************************
' Search for a comment char, and change the font.
'*************************************************************
CommentPresent = InStr(Source, FIND_COMMENT)
ChangeFont iColor:=ColorDeclare
'*************************************************************
' If a comment is present, then print up to the comment.
'*************************************************************
If CommentPresent Then
Word.Insert Left(Source, CommentPresent - 1)
FormatComment CommentPresent, Source
'*************************************************************
' If there is a line-continuation char ,
' then loop and format each continued line.
'*************************************************************
ElseIf Right(Source, 2) = FIND_CONTINUE_CHAR Then
Do While Right(Source, 2) = FIND_CONTINUE_CHAR
Word.Insert Left(Source, Len(Source) - 2)
ChangeFont bBold:=1, iColor:=ColorContinueChar
Word.Insert Right(Source, 2)
Word.InsertPara
ChangeFont iColor:=ColorDeclare
Line Input #SourceFile, Source
frmProgress.Update (Seek(SourceFile) \ _
LOF(SourceFile)) * 100
Loop
Word.Insert Source
Word.InsertPara
'*************************************************************
' Otherwise, just print it with the new font settings.
'*************************************************************
Else
Word.Insert Source
Word.InsertPara
End If
End Sub

The next three procedures�DisplayResults, Save, and PrintResults�display, save, or print the results of the formatting. The last procedure, ChangeFonts, is a helper procedure that the three previous procedures use to change the formatting of the current font in Word. Listing 28.18 shows all four of these functions.

Listing 28.18 Displaying, Printing, and Saving Formatting Results

'*****************************************************************
' Displays Word in Full Screen Word.
'*****************************************************************
Public Sub DisplayResults(FullScreenMode As Boolean)
'*************************************************************
' Return to the start of the document.
'*************************************************************
Word.StartOfDocument
'*************************************************************
' If the user wants full screen mode, then make sure the Full
' Screen toolbar is visible.
'*************************************************************
If FullScreenMode Then
With Word
.ToggleFull
.ViewToolbars Toolbar:="Full Screen", Show:=1
.MoveToolbar "Full Screen", 5, 595, 43
End With
bRestore = True
End If
'*************************************************************
' Let the system catch up, then show Word.
'*************************************************************
DoEvents
Word.AppHide
Word.AppShow
End Sub
'*****************************************************************
' Saves the file. If no file name is provided, then a default is
' provided by using the original name with a .DOC extension.
'*****************************************************************
Public Sub Save(Optional FileName)
Word.FileSaveAs IIf(IsMissing(FileName),DocFileName,FileName)
End Sub
'*****************************************************************
' Prints the results of the formatting to the current printer.
'*****************************************************************
Public Sub PrintResults()
Word.FilePrintDefault
End Sub
'*****************************************************************
' Changes the current font in Word. If an argument is ommitted,
' a default value is used.
'*****************************************************************
Private Sub ChangeFont(Optional sPoints, Optional iColor, _
Optional sFont, Optional bBold, Optional bItalic)
Word.FormatFont Points:=IIf(IsMissing(sPoints), "10", _
sPoints), Color:=IIf(IsMissing(iColor), _
ColorDefault, iColor), _
Font:=IIf(IsMissing(sFont), "Courier New", _
sFont), Bold:=IIf(IsMissing(bBold), 0, bBold), _
Italic:=IIf(IsMissing(bItalic), 0, bItalic)
End Sub

The OLEConnect function establishes an OLE Automation connection with Word, whether it is running or not. You write this function to be generic so that you can easily insert the same code into your own project without making any modifications.

'*****************************************************************
' OLEConnect takes a pointer to an object variable and class name.
' If this function is successful, then the function returns true
' and the obj argument points to a valid OLE Automation object.
'*****************************************************************
Private Function OLEConnect(obj As Object, sClass As String) _
As Boolean
'*************************************************************
' Temporarily turn off error handling
'*************************************************************
On Error Resume Next
Set obj = GetObject(, sClass)
'*************************************************************
' If GetObject failed, then try Create
'*************************************************************
If Err = 429 Then
'*********************************************************
' Resume error handling
'*********************************************************
On Error GoTo OLEConnect_Err
Set obj = CreateObject(sClass)
'*************************************************************
' If any other error, then display & exit
'*************************************************************
ElseIf Err <> 0 Then
GoSub OLEConnect_Err
End If
'*************************************************************
' If this line is executed, then the function succeeded
'*************************************************************
OLEConnect = True
Exit Function
'*****************************************************************
' Display error message and abort
'*****************************************************************
OLEConnect_Err:
MsgBox Err.Description, vbCritical
Exit Function
End Function

REPRT2XL.CLS�Creating Bug Reports from a Database

REPRT2XL.CLS (listing 28.19) is a class that shows off the power of OLE Automation and data access with Microsoft Excel by performing several methods to create a report from a database query. The class begins by declaring some variables and exposing a read-only pointer to the object that this class uses. When initialized, the class displays a splash screen while trying to create an Excel object. When destroyed, the class sets the Excel object equal to nothing to close Excel and free up the memory that the object is using.

Listing 28.19 REPRT2XL.CLS Sends Report Data to Excel

'*****************************************************************
' REPRT2XL.CLS - Sends data from a bug report database
' to Excel.
'*****************************************************************
Option Explicit
Private Excel As Object, CloseExcel As Boolean
Private BugDBase As New GenericDB
'*****************************************************************
' Expose the Excel object for further processing.
'*****************************************************************
Public Property Set GetExcel(obj As Object)
Set obj = Excel
End Property
'*****************************************************************
' Set the Excel object, if possible.
'*****************************************************************
Private Sub Class_Initialize()
On Error Resume Next
SplashVisible True, "Establishing a connection with Excel..."
OLEConnect Excel, "Excel.Application"
SplashVisible False
End Sub
'*****************************************************************
' Close the workbook (or Excel) without saving any changes.
'*****************************************************************
Private Sub Class_Terminate()
On Error Resume Next
Excel.ActiveWorkbook.Saved = True
If CloseExcel Then
Excel.Quit
Else
Excel.ActiveWorkbook.Close saveChanges:=False
Excel.WindowState = -4140 'xlMinimized
End If
SplashVisible False
Set Excel = Nothing
End Sub

The ReportToExcel method (listing 28.20) retrieves data from BUGS.MDB and inserts it into USEALL.XLS. After inserting the data, the procedure formats it to make it easier to read and removes the splash screen.

Listing 28.20 ReportToExcel Demonstrates OLE Automation with Excel

'*****************************************************************
' Create a summary report in Excel from a database file.
'*****************************************************************
Public Sub ReportToExcel(Optional ByVal FileName)
Dim XLSFile$
'*************************************************************
' Open the default or create a new workbook,
' then open the database.
'*************************************************************
On Error Resume Next
SplashVisible True, "Sending data to Excel..."
XLSFile = App.Path & "\useall.xls"
If Dir(XLSFile) = "" Then
Excel.Workbooks.Add
Else
Excel.Workbooks.Open XLSFile
End If
BugDBase.OpenDB IIf(IsMissing(FileName), _
App.Path & "\bugs.mdb", FileName)
'*************************************************************
' Set the current cell to bold blue with a gray background.
'*************************************************************
With Excel.Range("A1")
.Font.Bold = True
.Font.ColorIndex = 11
.Interior.ColorIndex = 15
.Interior.Pattern = 1
End With
'*************************************************************
' Autofill to the adjacent cells
'*************************************************************
Excel.Selection.AutoFill Destination:=Excel.Range("A1:E1"), _
Type:=0
'*************************************************************
' Write the data to Excel.
'*************************************************************
LoadColumn "Bug Details", "Product", "A"
LoadColumn "Bug Details", "Build", "B"
LoadColumn "Bug Details", "Title", "C"
LoadColumn "Bug Details", "Reproducible", "D"
LoadColumn "Bug Details", "BetaID", "E"
'*************************************************************
' Select all of the data, and format it.
' Make XL visible when done.
'*************************************************************
With Excel
.Range("A2").Select
.Selection.End(-4121).Select
.Selection.End(-4161).Select
.Range(Excel.Selection.Address, "A1").Select
.ActiveWindow.Zoom = 86
.Selection.Columns.AutoFit
.Selection.Sort Key1:=Excel.Range("A2"), Order1:=1, _
Header:=0, OrderCustom:=1, MatchCase:=False, _
Orientation:=1
.Visible = True
.Range("A1").Select
End With
SplashVisible False
End Sub

The key to the ReportToExcel method is the LoadColumn procedure (listing 28.21). LoadColumn requires that the caller provide a table name, a field name, and the column in which to insert the data from the field. The procedure queries the database and prints the results in Excel.

Listing 28.21 The LoadColumn Procedure

'*****************************************************************
' Load a column in Excel with the values from the bug database.
'*****************************************************************
Private Sub LoadColumn(TableName$, FieldName$, XLColumn$)
Dim i%, NumItems%, retArray() As String
'*************************************************************
' Create a dynaset and load an array with its values.
'*************************************************************
On Error Resume Next
BugDBase.CreateRecordSet TableName
BugDBase.GetArrayData FieldName, retArray()
'*************************************************************
' Determine how many items were returned.
'*************************************************************
NumItems = UBound(retArray)
'*************************************************************
' Print a column heading, then continue.
'*************************************************************
Excel.Range(XLColumn & "1").Select
Excel.ActiveCell.FormulaR1C1 = FieldName
Excel.Range(XLColumn & "2").Select
'*************************************************************
' Iterate through the array and write its value to Excel.
'*************************************************************
For i = 0 To NumItems
Excel.ActiveCell.FormulaR1C1 = retArray(i)
Excel.Range(XLColumn & Format(i + 3)).Select
Next i
End Sub

FRMSPL.CLS�Displaying a Splash Screen

Any large project such as UseAll inevitably performs certain tasks that take several minutes to complete. Because long intervals with no apparent activity can scare users into prematurely rebooting their computer, a splash screen provides a reassuring visual effect. For this project, FRMSPL.FRM (listing 28.22) provides the code for presenting the splash screen.

Listing 28.22 FRMSPL.FRM Presents a Splash Form

'*****************************************************************
' FRMSPL.FRM - This is just a splash form that is used to display
' messages to the user during long processes.
'*****************************************************************
Option Explicit
'*****************************************************************
' Initialize the form.
'*****************************************************************
Private Sub Form_Load()
'*************************************************************
' Set the mouse pointer, and put the window on top.
'*************************************************************
Screen.MousePointer = vbHourglass
AlwaysOnTop Me, True
'*************************************************************
' Reposition the label to the center of the form.
'*************************************************************
lblMessage.Move (ScaleWidth - lblMessage.Width) / 2, _
(ScaleHeight - lblMessage.Height) / 2
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
End Sub
'*****************************************************************
' Restore the mouse pointer.
'*****************************************************************
Private Sub Form_Unload(Cancel As Integer)
Screen.MousePointer = vbDefault
End Sub

FRMRET.FRM�Enabling the User to Return to UseAll

The clsPrettyPrint and clsReportToXL classes leave the user in different applications when they finish processing. FRMRET.FRM (listing 28.23) is a form that looks like a button in the screen's upper-right corner. The form provides the user an easy (and safe) way to return to your application. FRMRET.FRM also closes the current program (either Excel or Word) by setting its objects equal to nothing.

Listing 28.23 FRMRET.FRM Presents a Button That Enables Users to Return to Your Application

'*****************************************************************
' FRMRET.FRM - This form is a picture button that provides a
' generic way to return to your app from Excel & Word.
'*****************************************************************
Option Explicit
Option Compare Text
'*****************************************************************
' Position the form and button to the same size in the upper-right
' corner so they block the Minimize & Maximize buttons.
'*****************************************************************
Private Sub Form_Load()
Dim XTwips%, YTwips%
XTwips = Screen.TwipsPerPixelX
YTwips = Screen.TwipsPerPixelY
'*************************************************************
' Size the control, THEN move it to the upper-right corner.
'*************************************************************
Move Left, Top, 200 * XTwips, 43.4 * YTwips
Move Screen.Width - Width, 0
picReturn.Move 0, 0, 200, 43.4
'*************************************************************
' Prevent the window from being covered up,
' and draw the button.
'*************************************************************
AlwaysOnTop Me, True
Handle_MouseUpDown False
End Sub
'*****************************************************************
' When the form is unloaded, close the app by examining the form's
' .Tag property. This property was set by the calling funtion.
'*****************************************************************
Private Sub Form_Unload(Cancel As Integer)
If Tag = "Excel" Then
Set frmMain.clsR2XL = Nothing
Else
Set frmMain.clsPPrint = Nothing
End If
End Sub
'*****************************************************************
' Handle drawing the button in its various states.
' Notice how we use to DrawButton routine from frmMain.
'*****************************************************************
Private Sub Handle_MouseUpDown(bState As Boolean)
frmMain.DrawButton picReturn, IsDown:=bState, _
sCaption:="Return to " & App.Title & "...", _
sIcon:="RETURN", IsResource:=True
End Sub
'*****************************************************************
' Simulate a button click via graphics methods.
'*****************************************************************
Private Sub picReturn_MouseDown(Button%, Shift%, x As Single, _
y As Single)
Handle_MouseUpDown True
End Sub
Private Sub picReturn_MouseUp(Button%, Shift%, x As Single, _
y As Single)
Handle_MouseUpDown False
End Sub
'*****************************************************************
' Show the main form, and unload this window.
'*****************************************************************
Private Sub picReturn_Click()
frmMain.Show
Unload Me
End Sub

FRMBUGS.FRM�Writing Data to an Access Database

FRMBUGS.FRM (listing 28.24) is a bug-reporting wizard that you use to store information into an Access database. The form begins by declaring some form-level constants. Next, the SetupForm procedure initializes the form by positioning all the controls, loading the combo boxes, and playing an opening tune. Listing 28.24 also includes the LoadCombos procedure, which uses the GetControlData function from the GenericDB class to load all the combo boxes on the form.

Listing 28.24 FRMBUGS.FRM Shows How to Create a "Bugbase" Wizard

'*****************************************************************
' FRMBUGS.FRM - This is a bug reporting form that writes
' to an Access database via direct calls
' to the Jet database layer.
'*****************************************************************
Option Explicit
Private DBase As New GenericDB
Private FrameIndex%, BetaID$
'*****************************************************************
' Create more descriptive names for the cmd array indexes.
'*****************************************************************
Private Const CMD_HINT = 0
Private Const CMD_CANCEL = 1
Private Const CMD_PREV = 2
Private Const CMD_NEXT = 3
Private Const CMD_FINISH = 4
Private Const MAX_FRAMES_INDEX = 2
'*****************************************************************
' Position everything, open the database, load the combos,
' and play an opening tune.
'*****************************************************************
Private Sub Form_Load()
'*************************************************************
' Show the splash form, and set up the form.
'*************************************************************
SplashVisible True
SetupForm
LoadFrames
'*************************************************************
' Open the database, and load the combos from its contents.
'*************************************************************
DBase.OpenDB App.Path & "\bugs.mdb"
LoadCombos
'*************************************************************
' Play an introductory tune, and unload the splash form.
'*************************************************************
PlayWaveRes "Game"
SplashVisible False
End Sub
'*****************************************************************
' Load all of the combo boxes with data from the database.
'*****************************************************************
Private Sub LoadCombos()
DBase.CreateRecordSet "List Defaults"
DBase.GetControlData "OS", cboHardware(0)
DBase.GetControlData "Computer", cboHardware(1)
DBase.GetControlData "Video", cboHardware(2)
DBase.GetControlData "Boot", cboHardware(3)
DBase.GetControlData "SCSI", cboHardware(4)
DBase.GetControlData "Products", cboBugs(0)
DBase.GetControlData "Repro", cboBugs(1)
DBase.Data.Close
DBase.CreateRecordSet fra(0)
DBase.GetControlData "BetaID", cboContact
End Sub
'*****************************************************************
' Position the buttons, form, and frames.
'*****************************************************************
Private Sub SetupForm()
Const CMD_TOP = 5350
Const CMD_WIDTH = 1095
Const CMD_HEIGHT = 375
cmd(0).Move 1880, CMD_TOP, CMD_WIDTH, CMD_HEIGHT
cmd(1).Move 3095, CMD_TOP, CMD_WIDTH, CMD_HEIGHT
cmd(2).Move 4310, CMD_TOP, CMD_WIDTH, CMD_HEIGHT
cmd(3).Move 5480, CMD_TOP, CMD_WIDTH, CMD_HEIGHT
cmd(4).Move 6695, CMD_TOP, CMD_WIDTH, CMD_HEIGHT
Width = 8125
Height = 6300
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
LoadFrames
Draw3DLine
End Sub
'*****************************************************************
' Draw a 3-D line above the command buttons.
'*****************************************************************
Private Sub Draw3DLine()
Dim iXStart%, iXEnd%, iYStart%, iPixel%
'*************************************************************
' Calculate where the line should be drawn.
'*************************************************************
iPixel = Screen.TwipsPerPixelY
iXEnd = cmd(4).Left + cmd(4).Width
iXStart = fra(0).Left + iPixel
iYStart = cmd(0).Top - (iPixel * 10)
'*************************************************************
' Draw the gray line, then the white line underneath.
'*************************************************************
Line (iXStart, iYStart)-(iXEnd, iYStart), vb3DShadow
iYStart = iYStart + iPixel
Line (iXStart, iYStart)-(iXEnd, iYStart), vb3DHilight
End Sub
'*****************************************************************
' Initializes the frames.
'*****************************************************************
Private Sub LoadFrames()
'*************************************************************
' Position the frames.
'*************************************************************
fra(0).Move 135, 135, 7665, 4875
fra(1).Move 135, 135, 7665, 4875
fra(2).Move 135, 135, 7665, 4875
'*************************************************************
' Change the captions.
'*************************************************************
fra(0) = "Contact Information"
fra(1) = "Hardware Information"
fra(2) = "Bug Details"
End Sub

The NavigatePages procedure (listing 28.25) handles the navigation between different pages in the wizard by hiding and displaying the appropriate frames.

Listing 28.25 The NavigatePages Procedure

'*****************************************************************
' Handles changing frames.
'*****************************************************************
Private Sub NavigatePages(ByVal bMoveNext As Boolean)
'*************************************************************
' If you can't update the data, then exit.
'*************************************************************
If bMoveNext And Not UpdateData(FrameIndex) Then Exit Sub
'*************************************************************
' Hide the current frame, increment FrameIndex,
' then show the new frame.
'*************************************************************
fra(FrameIndex).Visible = False
FrameIndex = IIf(bMoveNext, FrameIndex + 1, FrameIndex - 1)
fra(FrameIndex).Visible = True
'*************************************************************
' Open the table for the current page, and load the data.
'*************************************************************
DBase.Data.Close
DBase.CreateRecordSet fra(FrameIndex)
LoadPage
'*************************************************************
' Change the enabled status of the command buttons.
'*************************************************************
If FrameIndex = 0 Then
cmd(CMD_PREV).Enabled = False
ElseIf FrameIndex = MAX_FRAMES_INDEX Then
cmd(CMD_NEXT).Enabled = False
Else
cmd(CMD_PREV).Enabled = True
cmd(CMD_NEXT).Enabled = True
End If
End Sub

As UseAll changes each page, it calls UpdateData (listing 28.26) to write the data to the database. This function calls either the VerifyRequiredField function, to verify that required fields are filled, or the AddOrEditRecord function, to write data to the database.

Listing 28.26 The UpdateData Function

'*****************************************************************
' Write the changes or additions to the database.
'*****************************************************************
Private Function UpdateData(Index%, Optional AddRec) As Boolean
Static Iterations As Integer
'*************************************************************
'AddRec determines whether to add or update a record.
'*************************************************************
AddRec = IIf(IsMissing(AddRec), True, AddRec)
'*************************************************************
' Iterations are used to prevent uncontrolled recursive loops.
'*************************************************************
Iterations = Iterations + 1
'*************************************************************
' Clear the error handler (for recursive calls only).
'*************************************************************
If Iterations > 0 Then Err = 0
'*************************************************************
' Update the appropriate page.
'*************************************************************
Select Case Index
'*********************************************************
' Contact Information
'*********************************************************
Case 0
'*****************************************************
' Verify required fields.
'*****************************************************
If Not VerifyRequiredField(txtMultiContact(0)) _
Then Exit Function
If Not VerifyRequiredField(txtContact(0)) _
Then Exit Function
DBase.AddOrEditRecord AddRec, _
"NameAddress|" & txtMultiContact(0), _
"Phone|" & txtContact(0), _
"Fax|" & txtContact(1), _
"InternetAddress|" & txtContact(2), _
"BetaID|" & cboContact
'*********************************************************
' Hardware Information
'*********************************************************
Case 1
If Not VerifyRequiredField(cboHardware(0)) _
Then Exit Function
If Not VerifyRequiredField(cboHardware(1)) _
Then Exit Function
If Not VerifyRequiredField(cboHardware(2)) _
Then Exit Function
If Not VerifyRequiredField(cboHardware(3)) _
Then Exit Function
DBase.AddOrEditRecord AddRec, _
"OperatingSystem|" & cboHardware(0), _
"ComputerType|" & cboHardware(1), _
"VideoAdapter|" & cboHardware(2), _
"BootDiskType|" & cboHardware(3), _
"SCSI|" & cboHardware(4), _
"OtherDiskTypes|" & txtHardware(0), _
"Floppies|" & txtHardware(1), _
"FileSystems|" & txtHardware(2), _
"BetaID|" & BetaID
'*********************************************************
' Bug Details
'*********************************************************
Case 2
If Not VerifyRequiredField(txtBugs(0)) _
Then Exit Function
If Not VerifyRequiredField(txtBugs(1)) _
Then Exit Function
If Not VerifyRequiredField(txtMultiBugs(0)) _
Then Exit Function
If Not VerifyRequiredField(txtMultiBugs(1)) _
Then Exit Function
DBase.AddOrEditRecord AddRec, _
"Product|" & cboBugs(0), _
"Build|" & txtBugs(0), _
"Reproducible|" & cboBugs(1), _
"Title|" & txtBugs(1), _
"Problem|" & txtMultiBugs(0), _
"Steps|" & txtMultiBugs(1), _
"BetaID|" & BetaID
End Select
'*************************************************************
' If Index is 2 and duplicate key error, then notify the user
' that the title is invalid.
'*************************************************************
If Index = MAX_FRAMES_INDEX And Err = 3022 Then
PlayWaveRes "Ring"
MsgBox "A report with the same name has already
been reported.", vbExclamation
Iterations = 0
UpdateData = False
'*************************************************************
' If less than 2 iterations, then recursively call.
'*************************************************************
ElseIf Iterations < 2 And Err Then
UpdateData = UpdateData(Index, False)
Iterations = 0
'*************************************************************
' Otherwise return true and reset the iterations variable.
'*************************************************************
Else
UpdateData = True
Iterations = 0
End If
End Function

As the cboContact drop-down combo box loses its focus, the cboContact procedure (listing 28.27) checks whether the combo box is blank. If it is, the procedure displays a message and returns the focus to the combo box. If not, the user information (if any) that is already in the database fills the page.

Listing 28.27 The cboContact Procedure

'*****************************************************************
' Make sure a Beta ID is listed.
'*****************************************************************
Private Sub cboContact_LostFocus()
'*************************************************************
' Set the global variable.
'*************************************************************
BetaID = Trim(cboContact)
'*************************************************************
' If one wasn't entered, then alert the user and halt.
'*************************************************************
If BetaID = "" Then
PlayWaveRes "Ding"
MsgBox "This field can not be blank!", vbCritical
cboContact.SetFocus
'*************************************************************
' Otherwise load the other controls with data from that id.
'*************************************************************
Else
LoadPage
End If
End Sub

The cmd_Click procedure handles click events from the command buttons on the wizard. The only control with any significant code is the Finish button. This button writes the bug report to the database and then asks the user if he or she wants to enter another bug. If not, the procedure dismisses the form. Otherwise, the procedure clears the page and returns the focus to the first drop-down combo box. The txtMultiBugs_Change event handles the enabled status of the Finish button to prevent users from finishing prematurely. Listing 28.28 shows these event-handling routines.

Listing 28.28 FRMBUGS Event-Handling Routines

'*****************************************************************
' Process command-button clicks.
'*****************************************************************
Private Sub cmd_Click(Index As Integer)
Select Case Index
'*********************************************************
' Display a hint (from the frame's .Tag) in a message box.
'*********************************************************
Case CMD_HINT
PlayWaveRes "Chimes"
MsgBox fra(FrameIndex).Tag, vbInformation
'*********************************************************
' Cancel is used to quit without filing a report.
'*********************************************************
Case CMD_CANCEL
If MsgBox("Are you sure you want to Quit?" _
, vbQuestion + vbYesNo) = vbYes Then
PlayWaveRes "Hasta"
Unload Me
End If
'*********************************************************
' The next two are used to navigate between frames.
'*********************************************************
Case CMD_PREV
NavigatePages False
Case CMD_NEXT
NavigatePages True
'*********************************************************
' File the bug report.
'*********************************************************
Case CMD_FINISH
'*****************************************************
' If UpdateData failed, the title must have already
' appeared in the database. Set the focus to the title
' text box, and exit. If users want to quit without
' fixing the problem, they'll have to use Cancel.
'*****************************************************
If Not UpdateData(FrameIndex) Then
txtBugs(1).SetFocus
Exit Sub
End If
'*****************************************************
' If the report was successfully filed, then ask users
' if they want to file another. If so, clear the page.
'*****************************************************
If MsgBox("Would you like to report another bug?" _
, vbQuestion + vbYesNo) = vbYes Then
txtBugs(1) = ""
txtMultiBugs(0) = ""
txtMultiBugs(1) = ""
txtBugs(1).SetFocus
'*****************************************************
' Otherwise tell the user goodbye, and unload.
'*****************************************************
Else
PlayWaveRes "ItsBeen"
MsgBox "Thank you for completing this report.", _
vbInformation
Unload Me
End If
End Select
End Sub
'*****************************************************************
' If the "Steps" text box is empty, disable the Finish button.
'*****************************************************************
Private Sub txtMultiBugs_Change(Index As Integer)
If Index = 1 Then
cmd(CMD_FINISH).Enabled = IIf(txtMultiBugs(1) <> "", _
True, False)
End If
End Sub

The LoadPage procedure loads a page with data from the database. The next procedure, ClearAll, clears all the form's controls. Finally, the VerifyRequiredField procedure verifies that the field isn't null. If it is, the procedure displays an error message and adds a space to the field to prevent multiple errors. Listing 28.29 shows all three of these procedures.

Listing 28.29 The LoadPage, ClearAll, and VerifyRequiredField Procedures

'*****************************************************************
' Loads the data from the database into the controls.
'*****************************************************************
Private Sub LoadPage()
'*************************************************************
' Find the record based on its BetaID value.
'*************************************************************
If DBase.FindRecord("BetaID", BetaID) = "" Then
ClearAll
Exit Sub
End If
'*************************************************************
' Use the public FrameIndex value to determine
' which frame to load.
'*************************************************************
Select Case FrameIndex
Case 0
'*****************************************************
'NOTE: & "" is appended to each line to prevent
' triggering an error if the return value
' from the record is NULL.
'*****************************************************
txtMultiContact(0) = DBase.GetRecord("NameAddress") _
& ""
txtContact(0) = DBase.GetRecord("Phone") & ""
txtContact(1) = DBase.GetRecord("Fax") & ""
txtContact(2) = DBase.GetRecord("InternetAddress") _
& ""
Case 1
cboHardware(0) = DBase.GetRecord("OperatingSystem") _
& ""
cboHardware(1) = DBase.GetRecord("ComputerType") & ""
cboHardware(2) = DBase.GetRecord("VideoAdapter") & ""
cboHardware(3) = DBase.GetRecord("BootDiskType") & ""
cboHardware(4) = DBase.GetRecord("SCSI") & ""
txtHardware(0) = DBase.GetRecord("OtherDiskTypes") _
& ""
txtHardware(1) = DBase.GetRecord("Floppies") & ""
txtHardware(2) = DBase.GetRecord("FileSystems") & ""
End Select
End Sub
'*****************************************************************
' Clear and reset selected controls.
'*****************************************************************
Private Sub ClearAll()
txtMultiContact(0) = ""
txtContact(0) = ""
txtContact(1) = ""
txtContact(2) = ""
cboHardware(0).ListIndex = 0
cboHardware(1).ListIndex = 0
cboHardware(2).ListIndex = 0
cboHardware(3).ListIndex = 0
cboHardware(4).ListIndex = 0
txtHardware(0) = ""
txtHardware(1) = ""
txtHardware(2) = ""
End Sub
'*****************************************************************
' If the field is required, then make sure it isn't blank.
'*****************************************************************
Private Function VerifyRequiredField(Cntl As Control) As Boolean
If Cntl.Text = "" Then
MsgBox "This is a required field!", vbExclamation
'*********************************************************
' Put blank space in control to prevent another error.
'*********************************************************
Cntl.Text = " "
Cntl.SetFocus
VerifyRequiredField = False
Exit Function
End If
'*************************************************************
' If its data is valid, then return True.
'*************************************************************
VerifyRequiredField = True
End Function

FRMMAIN.FRM�Combining Modules to Create an Interface

FRMMAIN.FRM (listing 28.30) ties all the previous modules together in one central user interface. The beginning of this form contains some necessary declarations, followed by the form initialization tasks. The Form_Load procedure draws the 3-D effect of the form and its four graphical buttons. In addition, the procedure positions the controls on the form to fit each individual quadrant. These tasks can be rather time consuming, so FRMMAIN.FRM displays a splash screen during startup processing.

Listing 28.30 FRMMAIN.FRM Is USEALL.VBP's Central User Interface

'*****************************************************************
' FRMMAIN.FRM - This is command central where everything begins.
'*****************************************************************
Option Explicit
Public clsR2XL As New clsReportToXL
Public clsPPrint As New clsPrettyPrint
#If Win32 Then
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As _
Long, ByVal nIndex As Long) As Long
#Else
Private Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC%, _
ByVal nIndex%) As Integer
#End If
'*****************************************************************
' This is a form-level conditional compilation constant. It's used
' to prevent performing certain time-consuming tasks
' during debugging.
'*****************************************************************
#Const DEBUG_MODE = False
'*****************************************************************
' Position and size all objects on the form.
'*****************************************************************
Private Sub Form_Load()
Dim Quad2 As RECT, Quad4 As RECT, NewQuad As RECT, i%
'*************************************************************
' Since these are time consuming to display, hide them during
' debugging.
'*************************************************************
#If DEBUG_MODE Then
oleExcel.Visible = False
olePower.Visible = False
oleProject.Visible = False
#End If
'*************************************************************
' Change Backcolor and display the splash screen.
'*************************************************************
On Error Resume Next
picButton(0).BackColor = vb3DFace
BackColor = vb3DFace
SplashVisible True
'*************************************************************
' Size the form to the screen.
'*************************************************************
Move 0, 0, Screen.Width, Screen.Height
'*************************************************************
' Draw a 3-D grid on the form.
'*************************************************************
Draw3DGrid Me, True
'*************************************************************
' Position a label above the oleExcel control.
'*************************************************************
GetQuad 2, Quad2
GetQuad 4, Quad4
With NewQuad
.rL = Quad2.rL
.rT = Quad2.rB
.rR = Quad2.rR
.rB = Quad4.rT
End With
SizeToRectClient lblStatus, NewQuad
'*************************************************************
' Draw a DkBlue background in Quad2 & position lbl
' and picButtons.
'*************************************************************
ResizeRect Quad2, -1, -1, False
DrawRect Me, Quad2, Solid:=True, RectColor:=RGB(0, 0, 64)
SizeToRectClient lbl, Quad2
lbl.top = Quad2.rT + 2
lbl.Height = GetRectHeight(Quad2) * 0.1
picButton(0).Move lbl.Left + 50, lbl.top + lbl.Height, _
lbl.Width - 100, GetRectHeight(Quad2) * 0.2
'*************************************************************
' Load 3 more buttons 5 pixels apart.
'*************************************************************
For i = 1 To 3
Load picButton(i): picButton(i).Visible = True
picButton(i).top = picButton(i - 1).top + _
picButton(i - 1).Height + 5
Next i
'*************************************************************
' Create the button effect, and label them.
'*************************************************************
picButton(0).Tag = "Create a Bug Report..." & "|ADD_BUGS"
Handle_MouseUpDown 0, False
Handle_MouseUpDown 1, False
Handle_MouseUpDown 2, False
Handle_MouseUpDown 3, False
'*************************************************************
' Make sure everything is positioned,
' then remove the splash form.
'*************************************************************
VerifyControlPositions
Visible = True
SplashVisible False
End Sub

The VerifyControlPositions routine (listing 28.31) verifies that the controls are placed properly. If the screen resolution is anything other than 640 by 480, the routine must resize the controls. Every time that you size an OLE container control, you must open the OLE server object and redraw the control's picture. Because this process is time consuming, the routine resizes the controls only if necessary.

Listing 28.31 The VerifyControlPositions Routine

'*****************************************************************
' Resizing OLE Controls can be VERY time consuming, so only
' do it if they have moved, or if resolution is <> 640x480.
'*****************************************************************
Sub VerifyControlPositions()
Const HORZRES = 8 ' Horizontal width in pixels
Const VERTRES = 10 ' Vertical width in pixels
Dim hRes%, vRes%, Quad1 As RECT, Quad3 As RECT, Quad4 As RECT
'*************************************************************
' Get the size of the quadrants.
'*************************************************************
GetQuad 1, Quad1
GetQuad 3, Quad3
GetQuad 4, Quad4
'*************************************************************
' Get the screen resolution,
'*************************************************************
hRes = GetDeviceCaps(hDC, HORZRES)
vRes = GetDeviceCaps(hDC, VERTRES)
'*************************************************************
' If not 640x480, then resize the OLE controls.
'*************************************************************
If hRes <> 640 Or vRes <> 480 Then
SizeToRectClient oleProject, Quad1
SizeToRectClient olePower, Quad3
SizeToRectClient oleExcel, Quad4
'*************************************************************
' If ole??? has moved or been resized, then fix it.
'*************************************************************
ElseIf Not EqualToQuadClient(oleProject, Quad1) Then
SizeToRectClient oleProject, Quad1
ElseIf Not EqualToQuadClient(olePower, Quad3) Then
SizeToRectClient olePower, Quad3
ElseIf Not EqualToQuadClient(oleExcel, Quad4) Then
SizeToRectClient oleExcel, Quad4
End If
'*************************************************************
' Process the delays caused by resizing OLE controls.
'*************************************************************
DoEvents
End Sub

When unloading the form, the Form_Unload procedure ensures that the application doesn't continue displaying the frmReturn form. The next procedure, Form_MouseMove, ensures that the lblStatus label is no longer visible. The lblStatus label displays when the user moves the mouse over the oleExcel control to display a status message. The message informs users that they update the control by clicking on it. Listing 28.32 shows both of these procedures.

Listing 28.32 The Form_Unload and MouseMove Procedures

'*****************************************************************
' Make sure there are no orphan forms.
'*****************************************************************
Private Sub Form_Unload(Cancel As Integer)
Unload frmReturn
End Sub
'*****************************************************************
' If the mouse is over the form, then hide lblStatus.
'*****************************************************************
Private Sub Form_MouseMove(Button%, Shift%, x As Single, _
y As Single)
lblStatus.Visible = False
End Sub
'*****************************************************************
' Update the chart whenever the user clicks on it.
'*****************************************************************
Private Sub oleExcel_Click()
UpdateChart
End Sub
'*****************************************************************
' If the mouse is over the control, then show the label.
'*****************************************************************
Private Sub oleExcel_MouseMove(Button%, Shift%, x As Single, _
y As Single)
lblStatus.Visible = True
End Sub

All the following procedures in listing 28.33 paint the graphical buttons that appear on the form. The buttons are actually picture boxes with a 3-D border and a caption and graphic painted on them. The resource file stores the pictures, and PaintPicture paints them on the control.

Listing 28.33 The 3-D Graphical Buttons That Use Picture Boxes

'*****************************************************************
' Performs the appropriate action for the picButton
' that was clicked.
'*****************************************************************
Private Sub picButton_Click(Index As Integer)
'*************************************************************
' Since a Click event only occurs when an object gets
' a Mouse_Down AND a Mouse_Up event, all command processing
' should be here.
'*************************************************************
On Error Resume Next
Select Case Index
Case 0
frmBugs.Show vbModal
Case 1
'*****************************************************
' Display frmReturn by calling its Display method,
' instead of using the Show method. This allows
'frmReturn to know which form is requesting
' that frmReturn is displayed. This is important
' because frmReturn needs to know which form it
' should activate when it is unloaded.
'*****************************************************
frmReturn.Display Me
clsR2XL.ReportToExcel App.Path & "\bugs.mdb"
Case 2
'*****************************************************
' Display a common file open dialog.
'*****************************************************
cdlg.FLAGS = cdlOFNFileMustExist + _
cdlOFNHideReadOnly +cdlOFNPathMustExist
cdlg.ShowOpen
If Err <> cdlCancel Then
frmReturn.Display Me
clsPPrint.PrettyPrint cdlg.FileName
End If
Case 3
Unload Me
End Select
End Sub
'*****************************************************************
' These two events simulate the button-clicking effect.
'*****************************************************************
Private Sub picButton_MouseDown(Index%, Button%, Shift%, x!, y!)
Handle_MouseUpDown Index, True
End Sub
Private Sub picButton_MouseUp(Index%, Button%, Shift%, x!, y!)
Handle_MouseUpDown Index, False
End Sub
'*****************************************************************
' A single procedure is used so that the code appears in only one
' place. This prevents errors from duplicate code.
'*****************************************************************
Private Sub Handle_MouseUpDown(Index%, bState As Boolean)
'*************************************************************
' Here's where all of buttons are drawn. Any changes here will
' affect all other procedures that operate on picButtons.
'*************************************************************
Select Case Index
Case 0
DrawButton picButton(Index), IsDown:=bState, _
IsResource:=True
Case 1
DrawButton picButton(1), IsDown:=bState, _
sCaption:="Bug Summary in Excel...", _
sIcon:="VIEW_BUGS", _
IsResource:=True
Case 2
DrawButton picButton(2), IsDown:=bState, _
sCaption:="View Code in Word...", _
sIcon:="VIEW_CODE", _
IsResource:=True
Case 3
DrawButton picButton(3), IsDown:=bState, _
sCaption:="Exit Application...", _
sIcon:="EXIT", _
IsResource:=True
End Select
End Sub

Finally, the UpdateChart procedure (listing 28.34) gets bug data from the database and uses OLE Automation methods on the object inside the OLE container control to update the Excel chart.

Listing 28.34 The UpdateChart Procedure

Private Sub UpdateChart()
Dim BugDBase As New GenericDB, retArray() As String
BugDBase.OpenDB App.Path & "\bugs.mdb"
BugDBase.CreateRecordSet "qryBugsByProduct"
BugDBase.GetArrayData "BugCount", retArray()
oleExcel.DoVerb 0
With oleExcel.Object.Parent.Parent.ActiveWorkbook
.Sheets("Bugs").Range("B2").FormulaR1C1 = retArray(0)
.Sheets("Bugs").Range("B3").FormulaR1C1 = retArray(1)
.Sheets("Bugs").Range("B4").FormulaR1C1 = retArray(2)
End With
oleExcel.Close
Set BugDBase = Nothing
End Sub

To help you understand the UseAll application components better, the companion CD includes six small projects that use each major component separately. If you have difficulties understanding any of the information presented in this chapter, try opening one of these smaller projects. You might understand the information better if you focus on a smaller code sample.

From Here...

Although this chapter presents many solutions to integrated application problems, it omits thousands of other solutions. You might find the solutions to some of your integration problems in the following sources:


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