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:
- Use a generic database class that simplifies how to use data access
objects (DAO)
- Use a rectangle class that eliminates the need for three-dimensional
(3-D) controls and improves performance
- Create an application-independent way of returning to your main form
from another application
- Perform OLE Automation on an embedded chart so that it reflects the
changes in a database
- Play .WAV files from a resource file
- Draw pictures from a resource by using PaintPicture
- Create your own 3-D buttons using graphics methods and a picture box
- Create shareable and reusable objects
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:
- Plan the amount of time and resources that it will take to complete
the project
- Analyze bugs that have been reported on the company's products
- Provide a consistent method for entering these bug reports into a
bug database
- Edit and view a PowerPoint presentation that communicates your project's
progress to upper management
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:
- Using OLE Automation with Word for Windows 6.0
- Using OLE Automation to analyze data from an Excel database
- Updating an embedded object with external data
- Using embedded PowerPoint and Project objects
- Creating a wizard for entering database data
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:
- Microsoft Windows SDK. All the documentation of the Software
Development Kit (SDK) contains useful information for manipulating stubborn
Windows applications. Although this documentation is sometimes difficult
to understand, you might be surprised at the information that it provides.
- Visual Basic Programmer's Guide to the Windows API (Ziff-Davis,
1994), by Daniel Appleman. This book will be your bible if you decide to
explore extensive API programming with Visual Basic. If you program with
the API, make sure that you have this book handy.
© 1996, QUE Corporation, an imprint of Macmillan Publishing USA, a
Simon and Schuster Company.