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

Chapter 26

Integration with Microsoft Excel

No discussion of custom applications or Visual Basic for Applications (VBA) is complete without discussing Microsoft Excel. This product is arguably the most powerful single application ever written for Windows, so you'll certainly want to take advantage of it. In this chapter, you see how to exploit the power of Excel so that you can develop world-class custom applications.

In this chapter, you learn more about the following:

OLE Automation with Microsoft Excel

In late 1993, Excel for Windows 5.0 became the first Microsoft product to be released with VBA. It introduced new features to the Visual Basic languages, and the concept of shareable OLE type libraries. This release opened up a whole new way to integrate applications with Visual Basic, and this section covers how you can benefit from this feature.

Using Excel's Macro Recorder to Write OLE Automation Code

Because Excel and Visual Basic (VB) both use VBA (albeit different versions), you can paste most of your Excel code directly into VB without encountering errors. What's more, you can take advantage of Excel's macro recorder to get a rough script of what you need to do through OLE Automation, without writing a single line of code. For example, the code in listing 26.1 was recorded in Excel and pasted directly into VB to perform an OLE Automation task.

Listing 26.1 Code Can Be Recorded in Excel and Used with VB

Option Explicit
Dim Excel As Object
Sub RecordedForVB4()
'********************************************************
' This code was unmodified from Excel's recorder,
' except the With Excel...End With statement. This
' statement is required because VB needs to know which
' object it should reference.
'********************************************************
With Excel
.Workbooks.Add
.Range("A2").Select
.ActiveCell.FormulaR1C1 = "North"
.Range("A3").Select
.ActiveCell.FormulaR1C1 = "South"
.Range("A4").Select
.ActiveCell.FormulaR1C1 = "East"
.Range("A5").Select
.ActiveCell.FormulaR1C1 = "West"
.Range("B1").Select
.ActiveCell.FormulaR1C1 = "Spring"
.Range("C1").Select
.ActiveCell.FormulaR1C1 = "Summer"
.Range("D1").Select
.ActiveCell.FormulaR1C1 = "Fall"
.Range("E1").Select
.ActiveCell.FormulaR1C1 = "Winter"
.Range("B2").Select
.ActiveCell.FormulaR1C1 = "100"
.Range("C2").Select
.ActiveCell.FormulaR1C1 = "125"
.Range("D2").Select
.ActiveCell.FormulaR1C1 = "108"
.Range("E2").Select
.ActiveCell.FormulaR1C1 = "97"
.Range("E3").Select
.ActiveCell.FormulaR1C1 = "118"
.Range("D3").Select
.ActiveCell.FormulaR1C1 = "110"
.Range("C3").Select
.ActiveCell.FormulaR1C1 = "109"
.Range("B3").Select
.ActiveCell.FormulaR1C1 = "110"
.Range("B2:E3").Select
.Selection.AutoFill Destination:=.Range("B2:E5") _
.Range("B2:E5").Select
.Range("A1:E5").Select
.Calculate
.Charts.Add
End With
End Sub
Private Sub Command1_Click()
'********************************************************
' Create the object, make Excel visible, run the macro,
' then free the object.
'********************************************************
Set Excel = CreateObject("Excel.Application")
Excel.Visible = True
RecordedForVB4
Excel.ActiveWorkbook.Saved = True 'Ignore changes
MsgBox "Macro Complete!"
Excel.Quit
Set Excel = Nothing
Unload Me
End Sub

This feature is incredibly powerful, because it's like having an OLE Automation recorder built in to VB. No matter how complex your task might be, you can just turn on Excel's recorder and let Excel write your code for you.

Macro recorder code requires some editing because it records your every keystroke. Therefore, you should examine the recorded code to remove unnecessary elements. You also must surround your recorded code within a With block and prefix each line with a period.

Tips for OLE Automation with Excel

When you use OLE Automation with Excel, you should remember the following:

Because Excel includes VBA and support for custom forms, you can easily create powerful custom applications using Excel alone. In many cases, you might want to choose Excel as your primary application environment and expose your VB application (or its classes) as an OLE object. This enables Excel to use some of the powerful features of VB without creating an application entirely in VB. In this sense, you can use VB's exposed objects the same way that a C programmer uses a dynamic linking library (DLL)

Excel 5.0 and Word 6.0 are almost opposites in the way that they behave toward OLE Automation. Until you get used to the differences, you might want to consult this book (or some other source) before writing any code. Failing to do so could lead to unexpected results, and possibly even a General Protection Fault.

As a general rule, make sure that you are using the latest updates of any applications that you are using with OLE Automation. At the time that this chapter was completed, the latest version of Excel was 5.0c, and Word's was 6.0c.

Leveraging the Power of Excel in Your Applications

After the previous chapter's discussion of Word, you should be very familiar with the reasons that an OLE server's custom control can be helpful. However, with OLE's in-place activation, a custom control is a lifesaver. Microsoft has done a tremendous amount of work to make in-place activation usable by Visual Basic programmers, so you'll certainly want take advantage of it. In Visual Basic 4.0 (VB4), you can support two types of in-place activation for Excel:

Each of these methods have advantages and disadvantages. The next few sections demonstrate the power of each tool so that you can decide which is right for you.

Excel as an OLE Insertable Object Control

With the power of Excel's workbooks and graphs, there are few better applications to use as a insertable object control. If you have ever used the Graph or Grid .VBX controls in previous versions of VB, you know that it requires a great deal of work simply to enter data and create charts. With an Excel insertable object control, this functionality is so easy that you might find yourself including it in the simplest of applications.

Instead of using both Excel's chart and worksheet OLE insertable object controls in a project, you can use either one individually because your data is stored in a workbook. Therefore, you can have a workbook containing a chart sheet and a worksheet, to display the same information in two different ways with the same control.

The following example program uses the Excel Worksheet OLE insertable object control to view and edit data in a grid and in a worksheet by exploiting the power of workbooks. Figure 26.1 shows the program displaying formatted data in a worksheet, and figure 26.2 shows the same data in a chart.

Fig. 26.1

Excel worksheet controls can display data in worksheets.

Fig. 26.2

Excel worksheet controls can also display data in charts.

The capability to use the same control to display data in both a grid and chart is unheard of for Visual Basic users, so this is certainly a powerful feature. Figure 26.3 shows the simplicity of switching from either view.

Fig. 26.3

Using Excel's powerful workbooks, you can switch between different views.

Because creating this application is almost identical to the steps listed in the previous chapter, they are not listed here. However, you can use the steps shown in the Word chapter to create this application. In addition, you can find this program on the companion CD as EXCELWBK.VBP.

In addition to the functionality that the preceding figures depict, the Excel insertable object control supports the following events, methods, and properties:

As you can see, the Excel Worksheet insertable object control (and any other OLE controls) support a wealth of events and properties. In most cases, this method possesses all the functionality that you will ever need.

If you plan to use only Excel in your application, the Excel worksheet control is a great choice. However, if your users need to insert objects at run time, you should consider using the OLE container control.

Your application fails to run if the destination system does not have Microsoft Excel, or if Excel.Worksheet is not properly registered in the system registry.

If you are unsure whether your users have a copy of Excel properly installed on their system, you should consider using the Grid control (GRID.OCX) with either the Graph control (GRAPH.OCX) or a Microsoft Graph (GRAPH5.EXE) OLE object control. This way, you can ensure that the user has the correct products installed.

Using the OLE Container Control with Excel

Before I began writing this section, I never realized how much the OLE container control could do. I found myself doing things that I never dreamed were possible. What's more, I saw VB and Excel handle these incredibly difficult tasks with the greatest of ease. After seeing this section's code example at work, you also will appreciate the power that these two products possess.

The sample program in this section is an MDI application that presents information from Excel in chart and table form. The user can switch between the two views, shown in figures 26.4 and 26.5, by using tabs.

Fig. 26.4

By using tabs with the OLE container control, you can view data in a chart.

Fig. 26.5

Using tabs with the OLE container control also enable you to view data in a spreadsheet table.

It is a good programming practice to build a set of "helper functions" for use with large-scale applications. Listing 26.2 contains code that must be accessible to two or more modules in the project at run time. Placing this code in a separate module prevents you from having to maintain the identical code in several modules.

Listing 26.2 Shared Procedures and Declarations Should Be Stored in Modules.

'*****************************************************************
' PUBLIC.BAS - Global constants, functions, and variables.
'*****************************************************************
Option Explicit
'*****************************************************************
' API Declarations for this module.
'*****************************************************************
#If Win32 Then
Private Declare Function GetPrivateProfileString Lib _
"kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, lpKeyName As Any, ByVal _
lpDefault As String, ByVal lpRetStr As String, ByVal nSize _
As Long, ByVal lpFileName$) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
Private Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd&, _
ByVal nCmdShow As Long) As Long
#Else
Private Declare Function GetPrivateProfileString Lib "Kernel" _
(ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, _
ByVal lpReturnStr$, ByVal nSize%, ByVal lpFileName$) _
As Integer
Private Declare Function FindWindow Lib "User" _
(ByVal lpClassName$, ByVal lpWindowName As Long) As Integer
Private Declare Function PostMessage Lib "User" (ByVal hWnd%, _
ByVal wMsg As Integer, ByVal wParam%, lParam&) As Long
Private Declare Function ShowWindow Lib "User" _
(ByVal hWnd As Integer, ByVal nCmdShow As Integer) As Integer
#End If
'*****************************************************************
' These globals keep track of the new instances of frmExcel.
'*****************************************************************
Public Const MAX_WINDOWS = 4
Public Excels(MAX_WINDOWS) As New frmExcel
Public ExcelWindows As Integer
Public ActiveIndex%
'*****************************************************************
' Generic update status bar routine.
'*****************************************************************
Public Sub UpdateStatus(StatusBar As Label, Optional StatusText)
If IsMissing(StatusText) Then
StatusBar = "Ready"
Else
StatusBar = StatusText
End If
End Sub
'*****************************************************************
' Start an OLE Server, if it is not already running.
'*****************************************************************
Public Function StartServer(ClassName$, Program$) As Long
Const SW_SHOWNA = 8
#If Win32 Then
Dim hWnd As Long
#Else
Dim hWnd As Integer
#End If
'*************************************************************
' Prevent any error messages from interrupting the program.
'*************************************************************
On Error Resume Next
'*************************************************************
' Check to see if its already running.
' If so, then activate it.
'*************************************************************
hWnd = FindWindow(ClassName, 0&)
If hWnd Then
ShowWindow hWnd, SW_SHOWNA
'*********************************************************
' Return False to indicate that it was already running.
'*********************************************************
StartServer = False
Else
'*********************************************************
' Otherwise, start it and return its hWnd.
'*********************************************************
Shell Program, vbMinimizedNoFocus
DoEvents
StartServer = FindWindow(ClassName, 0&)
End If
End Function
'*****************************************************************
' Calls the API to read an .INI file, and return the results.
'*****************************************************************
' NOTE: ByVal is used, so you can pass control values such
' as Text1.Text without surrounding it in parentheses.
'*****************************************************************
Public Function GetINI(ByVal Section$, ByVal Key$, ByVal _
Default$, ByVal FileName$) As String
Dim res%, retVal$
retVal = Space$(32400)
res = GetPrivateProfileString(Section, Key, Default, _
retVal, Len(retVal), FileName)
GetINI = Left$(retVal, res)
End Function
'*****************************************************************
' Posts a WM_CLOSE message to an application.
'*****************************************************************
Public Sub CloseApp(hWnd As Long)
Const WM_CLOSE = &H10
#If Win32 Then
PostMessage hWnd, WM_CLOSE, 0, 0&
#Else
PostMessage CInt(hWnd), WM_CLOSE, 0, 0&
#End If
End Sub

Listing 26.3 contains the minimum amount of code needed to display the splash screen. This form (see fig. 26.6) gives the user some "visual candy" during long processing times. A splash screen reassures users that their system has not locked up during heavy processing.

Fig. 26.6

The splash screen provides the user with "visual candy" during long processing times.

Listing 26.3 Splash Screens Calm the User's Fears

'*****************************************************************
' FRMSPLASH - This is just a splash form that is used to display
' messages to the user during long processes.
'*****************************************************************
Option Explicit
'*****************************************************************
' Declare SetWindowPos so this window can be "AlwaysOnTop".
'*****************************************************************
#If Win32 Then
Private Declare Sub SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long)
#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
'*****************************************************************
' Initialize the form.
'*****************************************************************
Private Sub Form_Load()
Const HWND_TOPMOST = -1
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
'*************************************************************
' Set the mouse pointer.
'*************************************************************
Screen.MousePointer = vbHourglass
'*************************************************************
' Set the window to TopMost, and ignore the return value.
'*************************************************************
SetWindowPos hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
'*************************************************************
' 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

Listing 26.4 contains code to size the form and its command button. This form displays information, gathered through OLE Automation, about the linked OLE object in this application (see fig. 26.7).

Fig. 26.7

The Object Information dialog box displays data that was gathered by using OLE Automation with the OLE container control's Object property.

Listing 26.4 Information Dialog Boxes Should Contain Little or No Code

'*****************************************************************
' FRMINFO.FRM - This is essentially a "stupid" dialog used by
' frmExcel. Its only purpose is to display
' information.
'*****************************************************************
Option Explicit
'*****************************************************************
' Initialize the form so that it can hold 10, 40 char lines.
'*****************************************************************
Private Sub Form_Load()
'*************************************************************
' Get the height and width of a character
' to set the form size.
'*************************************************************
Width = TextWidth(String(42, "X"))
Height = TextHeight("X") * 14
'*************************************************************
' Move the command button to the bottom center of the form.
'*************************************************************
cmd.Move (ScaleWidth - cmd.Width) / 2, _
ScaleHeight - cmd.Height - 10
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
End Sub
'*****************************************************************
' Always unload this form, since it loads so fast.
'*****************************************************************
Private Sub cmd_Click()
Unload Me
End Sub

Listing 26.5 is the MDI parent. This form contains code that starts Excel (if necessary) and maintains the toolbar and the status bar (see fig. 26.8). You develop the toolbar and status bar, shown in figure 26.8, entirely in Visual Basic by using picture boxes and image controls. You use no custom controls, so your application loads faster and your distribution disk is smaller. This is important when you are writing large applications, because every control in your project increases the startup time.

Fig. 26.8

The MDI form contains only a minimal menu, a toolbar, and status bar.

Listing 26.5 MDI Forms Should Only Manage Itself and Load the First Child Form
'*****************************************************************
' MDIOLE.FRM - MDI Parent Form.
'*****************************************************************
Option Explicit
Private StartedExcel As Long
'*****************************************************************
' Saves the button image in imgHold, and inserts the down picture.
'*****************************************************************
Private Sub imgTools_MouseDown(Index As Integer, _
Button As Integer, Shift As Integer, X As Single, _
Y As Single)
imgHold.Picture = imgTools(Index).Picture
imgTools(Index).Picture = imgTools(Index + 1).Picture
End Sub
'*****************************************************************
' Updates the status bar.
'*****************************************************************
Private Sub imgTools_MouseMove(Index As Integer, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
UpdateStatus lblStatus, imgTools(Index).Tag
End Sub
'*****************************************************************
' Restores the graphic, and processes toolbar clicks.
'*****************************************************************
Private Sub imgTools_MouseUp(Index As Integer, _
Button As Integer, Shift As Integer, X As Single, _
Y As Single)
'*************************************************************
' Restore the toolbar picture.
'*************************************************************
imgTools(Index).Picture = imgHold.Picture
'*************************************************************
' Execute the appropriate toolbar action.
'*************************************************************
Select Case Index
Case 0 ' Hand
Unload Me
Case 2 ' Question Mark
'*********************************************************
' Bring up the splash form again, because the first OLE
' Automation call will require Excel to be started. After
' it is started, any subsequent calls will be performed
' as fast as they would be in a native Excel macro.
'*********************************************************
frmSplash.lblMessage = _
"Gathering OLE Automation information from Excel...Please Wait!"
frmSplash.Show
frmSplash.Refresh
'*********************************************************
' Load the info dialog, and start printing to it.
'*********************************************************
Load frmInfo
'*********************************************************
' NOTE: Using the OLE Container's Object property, you can
' execute OLE Automation statements on the object in
' the control.
'*********************************************************
' Using 2 .Parent properties, allows you to access Excel's
' Application object.
'*********************************************************
PrintMessage "Application Name:", _
ActiveForm.Excel(0).Object.Parent.Parent.Name & " " & _
ActiveForm.Excel(0).Object.Parent.Parent.Version
PrintMessage "Operating System:", _
ActiveForm.Excel(0).Object.Parent.Parent.OperatingSystem
PrintMessage "Organization Name:", _
ActiveForm.Excel(0).Object.Parent.Parent.OrganizationName
'*********************************************************
' By default, the Object property points to a Worksheet.
'*********************************************************
PrintMessage "Range(""A2""):", _
ActiveForm.Excel(0).Object.Range("A2")
'*********************************************************
' Using 1 call to Parent, allows you to access Excel's
' Workbook object.
'*********************************************************
PrintMessage "Read Only:", _
ActiveForm.Excel(0).Object.Parent.ReadOnly
PrintMessage "Saved:", _
ActiveForm.Excel(0).Object.Parent.Saved
PrintMessage "Sheet Name:", _
ActiveForm.Excel(0).Object.Name
PrintMessage "Workbook Author:", _
ActiveForm.Excel(0).Object.Parent.Author
PrintMessage "Workbook Name:", _
ActiveForm.Excel(0).Object.Parent.Name
'*********************************************************
' Make sure all activity is complete, before unloading the
' the splash.
'*********************************************************
DoEvents
Unload frmSplash
'*********************************************************
' Display the information to the user.
'*********************************************************
frmInfo.Show 1
End Select
End Sub
'*****************************************************************
' Print the formatted string to frmInfo.
'*****************************************************************
Private Sub PrintMessage(Item As String, Result As Variant)
Dim LeftStr As String * 20, RightStr As String * 30
LeftStr = Item
RightStr = Result
frmInfo.Print LeftStr & RightStr
End Sub
'*****************************************************************
' Prepares the application for use.
'*****************************************************************
Private Sub MDIForm_Load()
Dim XLPath$
'*************************************************************
' Always use the system defined backcolor.
'*************************************************************
BackColor = vb3DFace
StatusBar.BackColor = vb3DFace
Toolbar.BackColor = vb3DFace
'*************************************************************
' If necessary, start Excel to prevent annoying message boxes.
'*************************************************************
XLPath = GetINI("Microsoft Excel", "cbtlocation", _
"c:\excel\excelcbt", "excel5.ini")
XLPath = Left(XLPath, Len(XLPath) - 8) & "excel.exe"
StartedExcel = StartServer("XLMAIN", XLPath)
WindowState = 2 'Maximized
frmExcel.Show
Arrange vbTileHorizontal
End Sub
'*****************************************************************
' Updates the status bar with the default text.
'*****************************************************************
Private Sub MDIForm_MouseMove(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
UpdateStatus lblStatus
End Sub
'*****************************************************************
' If you had to start Excel, close it. Otherwise, leave it alone.
'*****************************************************************
Private Sub MDIForm_Unload(Cancel As Integer)
If StartedExcel <> False Then
CloseApp StartedExcel
End If
End Sub
'*****************************************************************
' Terminates the application.
'*****************************************************************
Private Sub mnuFileItems_Click(Index As Integer)
Unload Me
End Sub
'*****************************************************************
' Updates the status bar with the default text.
'*****************************************************************
Private Sub StatusBar_MouseMove(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
UpdateStatus lblStatus
End Sub
'*****************************************************************
' Adds a 3-D appearance to the status bar.
'*****************************************************************
Private Sub StatusBar_Paint()
HighlightBar StatusBar
Highlight lblStatus
End Sub
'*****************************************************************
' Updates the status bar with the default text.
'*****************************************************************
Private Sub Toolbar_MouseMove(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
UpdateStatus lblStatus
End Sub
'*****************************************************************
' Adds a 3-D appearance to the toolbar.
'*****************************************************************
Private Sub Toolbar_Paint()
HighlightBar Toolbar
End Sub
'*****************************************************************
' Adds a 3-D effect to a picture box.
'*****************************************************************
Private Sub HighlightBar(Bar As PictureBox)
Bar.Line (0, 5)-(Bar.ScaleWidth, 5), vb3DHighlight
Bar.Line (0, Bar.ScaleHeight - 15)-(Bar.ScaleWidth, _
Bar.ScaleHeight - 15), vb3DShadow
End Sub
'*****************************************************************
' Adds a 3-D border around a control.
'*****************************************************************
Private Sub Highlight(Object As Control)
Const HORIZONTAL_OFFSET = 50
Const VERTICAL_OFFSET = 70
'*************************************************************
' Top
'*************************************************************
StatusBar.Line (Object.Left - HORIZONTAL_OFFSET, _
Object.Top - HORIZONTAL_OFFSET)- _
(Object.Width, _
Object.Top - HORIZONTAL_OFFSET), _
vb3DShadow
'*************************************************************
' Left
'*************************************************************
StatusBar.Line (Object.Left - HORIZONTAL_OFFSET, _
Object.Top - HORIZONTAL_OFFSET)- _
(Object.Left - HORIZONTAL_OFFSET, _
Object.Height + VERTICAL_OFFSET), _
vb3DShadow
'*************************************************************
' Bottom
'*************************************************************
StatusBar.Line (Object.Left - HORIZONTAL_OFFSET, _
Object.Height + VERTICAL_OFFSET)- _
(Object.Width, _
Object.Height + VERTICAL_OFFSET), _
vb3DHighlight
'*************************************************************
' Right
'*************************************************************
StatusBar.Line (Object.Width, _
Object.Top - HORIZONTAL_OFFSET)- _
(Object.Width, _
Object.Height + VERTICAL_OFFSET + 15), _
vb3DHighlight
End Sub

Listing 26.6 is the child form. This form is the heart of the application because it contains all the code necessary to display the data and tabs. It also keeps the status bar up to date when the user moves the mouse around the screen.

Listing 26.6 In an MDI Application, a Majority of Your Code Should Reside in the Child Form

'*****************************************************************
' FRMEXCEL.FRM - MDI Child form with a OLE container control.
'*****************************************************************
Option Explicit
'*****************************************************************
' The RECT and GetClientRect decs are required for PositionFrame.
'*****************************************************************
#If Win32 Then
Private Type RECT
rLEFT As Long
rTOP As Long
rWIDTH As Long
rHEIGHT As Long
End Type
Private Declare Sub GetClientRect Lib "user32" _
(ByVal hWnd As Long, lpRect As RECT)
#Else
Private Type RECT
rLEFT As Integer
rTOP As Integer
rWIDTH As Integer
rHEIGHT As Integer
End Type
Private Declare Sub GetClientRect Lib "User" _
(ByVal hWnd As Integer, lpRect As RECT)
#End If
'*****************************************************************
' Gets the client area of a frame, and sizes an object to it.
'*****************************************************************
Private Sub PositionFrame(SourceFrame As Frame, _
ChildObject As Control)
Dim Client As RECT, X As RECT
GetClientRect SourceFrame.hWnd, Client
X.rLEFT = (Client.rLEFT * Screen.TwipsPerPixelX) + 50
X.rTOP = (Client.rTOP * Screen.TwipsPerPixelY) + 150
X.rWIDTH = (Client.rWIDTH * Screen.TwipsPerPixelX) - 90
X.rHEIGHT = (Client.rHEIGHT * Screen.TwipsPerPixelY) - 190
ScaleMode = vbTwips
ChildObject.Move X.rLEFT, X.rTOP, X.rWIDTH, X.rHEIGHT
ScaleMode = vbPixels
End Sub
'*****************************************************************
' Initializes this form instance. This code is also called
' every time a new form is created.
'*****************************************************************
Private Sub Form_Load()
'*************************************************************
' Establishing links takes a few minutes, so give the user
' something to look at.
'*************************************************************
frmSplash.lblMessage = _
"Establishing links with Excel...Please Wait."
frmSplash.Show
frmSplash.Refresh
'*************************************************************
' Always create your recreate links in case the program is
' moved. In a real program, you should NEVER hard-code
' your links.
'*************************************************************
Excel(0).CreateLink App.Path & "\" & "SAMPLE.XLS!R1C1:R5C5"
Excel(1).CreateLink App.Path & "\" & "SAMPLE.XLS!Pie"
'*************************************************************
' Call DoEvents to process the links, and to prevent
' the splash screen from disappearing prematurely.
'*************************************************************
DoEvents
Unload frmSplash
End Sub
'*****************************************************************
' Updates the status bar with the default text.
'*****************************************************************
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
UpdateStatus mdiOLE.lblStatus
End Sub
'*****************************************************************
' This procedure controls the tab redrawing to handle switching.
'*****************************************************************
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Dim res%
res = Abs(DrawTabs(Me, X, Y) - 1)
If res < 2 Then Tabs(res).ZOrder
End Sub
'*****************************************************************
' Reposition the frames and resize the tabs.
'*****************************************************************
Private Sub Form_Resize()
Dim ActivateTab!
'*************************************************************
' When the form is resized, the tabs must be rescaled to fit.
'*************************************************************
SetupTabs Me, 2
'*************************************************************
' Position the OLE Containers to fit inside the frames.
'*************************************************************
PositionFrame Tabs(0), Excel(0)
PositionFrame Tabs(1), Excel(1)
'*************************************************************
' SetupTabs will make the first tab active. Determine which
' tab should be active, and MouseUp it.
'*************************************************************
ActivateTab = IIf(ActiveIndex = 0, 10, _
((ScaleWidth - 2) / 2) + 100)
Form_MouseUp 0, 0, ActivateTab, 20
End Sub
'*****************************************************************
' Automatically saves any changes to the data.
'*****************************************************************
Private Sub Form_Unload(Cancel As Integer)
Excel(0).Object.Parent.RunAutoMacros (xlAutoClose)
End Sub
'*****************************************************************
' Handles clicks from the File submenu.
'*****************************************************************
Private Sub mnuFileItems_Click(Index As Integer)
On Error Resume Next
Select Case Index
Case 1 'New
If ExcelWindows <= MAX_WINDOWS Then
ExcelWindows = ExcelWindows + 1
'*************************************************
' Create a new form, and set its caption.
'*************************************************
Excels(ExcelWindows - 1).Caption = "Excel -" _
& Str$(ExcelWindows + 1)
'*************************************************
' Remove the caption from both frames.
'*************************************************
Excels(ExcelWindows - 1).Tabs(0) = ""
Excels(ExcelWindows - 1).Tabs(1) = ""
End If
Case 3 'Exit
Unload mdiOLE
End Select
End Sub
'*****************************************************************
' Handles clicks from the Object submenu.
'*****************************************************************
Private Sub mnuObjectItems_Click(Index As Integer)
Select Case Index
Case 1 'Update Links
Excel(0).Update
Excel(1).Update
Case 2 'Close Object
Excel(ActiveIndex).Close
End Select
End Sub
'*****************************************************************
' Updates the status bar.
'*****************************************************************
Private Sub Excel_MouseMove(Index As Integer, Button As Integer, _
Shift As Integer, X As Single, Y As Single)
UpdateStatus mdiOLE!lblStatus, Excel(Index).Tag
End Sub
'*****************************************************************
' Handles clicks from the Window submenu.
'*****************************************************************
Private Sub mnuWindowItems_Click(Index As Integer)
mdiOLE.Arrange Index - 1
End Sub
'*****************************************************************
' Set the ActiveIndex. This isn't foolproof, but it works for this
' demonstration. In the "real world," this wouldn't be enough.
'*****************************************************************
Private Sub Tabs_MouseMove(Index As Integer, Button As Integer, _
Shift As Integer, X As Single, Y As Single)
ActiveIndex = Index
End Sub

In addition to all the code and forms in Visual Basic, this application also includes some code inside of Excel that enables the user to return to your application. Listing 26.7 includes the key Excel macros.

Listing 26.7 Supporting Code in Excel Can Help in Two-Way Communication between Your Applications

'*****************************************************************
' Returns control to your VB Program, and minimizes Excel.
'*****************************************************************
Sub ReturnToExample()
On Error Resume Next
AppActivate Title:="OLE Container Control Example"
If Err Then MsgBox "The example program isn't open.", _
vbInformation
Application.WindowState = xlMinimized
End Sub
'*****************************************************************
' Turns off errors and saves the workbook.
' This code is VITAL to prevent the user from being bothered
' by unnecessary message boxes.
'*****************************************************************
Sub Auto_Close()
Application.DisplayAlerts = False
ThisWorkbook.Save
End Sub

The ReturnToExample() procedure enables you to add a macro button to the worksheet (as shown in fig. 26.9). Such a button shows users clearly what they are supposed to do to return to your application. In addition, you can modify your menus (shown in fig. 26.10) to prevent users from closing the file or Excel. Notice how the Exit menu item has been removed.

Fig. 26.9

When using linked objects, you usually should give the user a visible way to return to your application.

Fig. 26.10

Modifying Excel's menus can be helpful to ensure that users can't do anything that they shouldn't.

Using Your VB Application as a DLL for Excel

Most programmers would love to create DLLs in Visual Basic so that they can share common code among applications. Although you can't write a traditional DLL in Visual Basic, you can write a class that you can expose to other applications (for example, Excel) to achieve the same effect. In fact, this section shows you how OLE Automation servers that you create with VB are more useful and easier to use than any traditional DLL could ever be.

The Useful Class Object

Before reading this section, you should have already read about classes and OLE Automation servers, including how to write an OLE Automation server. However, this project is rather lengthy, so it does require some additional explanation.

The project's first file is the About dialog box form. External applications use this form to display a professional-looking About dialog box easily. This form (shown at design time in fig. 26.11) includes only the minimum code necessary to initialize the form. Listing 26.8 demonstrates how to create a generic About box.

Fig. 26.11

The generic About box at design time differs significantly from its run-time counterpart.

Listing 26.8 A Generic About Box Is Useful to Give Your Applications a Consistent Look and Feel

'**************************************************************
' ABOUTBOX.FRM - This form contains a generic About dialog
' box which is accessed by the About class.
' You should never use this form directly.
'**************************************************************
Option Explicit
'**************************************************************
' API calls for use by this form only.
'**************************************************************
#If Win32 Then
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" _
(lpBuffer As MEMORYSTATUS)
#Else
Private Declare Function GetFreeSpace Lib "Kernel" (ByVal _
wFlags%) As Long
Private Declare Function GetFreeSystemResources Lib "User" _
(ByVal wSysResource%) As Integer
Private Declare Function GetWinFlags Lib "Kernel" () As Long
#End If
'**************************************************************
' Form level variables for preserving the pointer, and creating
' an About object.
'**************************************************************
Private OrigPointer As Integer
'**************************************************************
' Form Initialization
'**************************************************************
Private Sub Form_Load()
#If Win32 Then
Dim MemoryStat As MEMORYSTATUS
#Else
Const WF_ENHANCED = &H20
Const GFSR_SYSTEMRESOURCES = &H0
#End If
'**********************************************************
' Remember the current pointer, and change it to an hrglass
'**********************************************************
OrigPointer = Screen.MousePointer
Screen.MousePointer = vbHourglass
'**********************************************************
' If this form isn't being displayed as a splash screen
'**********************************************************
If Not bSplashScreen Then
'**********************************************************
' Set the visible property of the button based on the
' existences of msinfo.exe (from Microsoft).
'**********************************************************
#If Win32 Then
cmdSysInfo.Visible = FileExists(GetWinDir(True) _
& "msapps\msinfo\msinfo32.exe")
#Else
cmdSysInfo.Visible = FileExists(GetWinDir(True) _
& "msapps\msinfo\msinfo.exe")
#End If
'**********************************************************
' NOTE: You CANNOT distribute MSINFO.EXE, so this is the
' next best thing.
'**********************************************************
End If
'**********************************************************
' Set the label to reflect the environment mode
'**********************************************************
#If Win32 Then
lbl(9) = "Windows (32-bit)"
#Else
lbl(9) = IIf(GetWinFlags() And WF_ENHANCED, _
"386 Enhanced Mode", "Standard Mode")
#End If
'**********************************************************
' Call the API, and format the responses
'**********************************************************
#If Win32 Then
GlobalMemoryStatus MemoryStat
lbl(10) = "Physical Memory"
lbl(11) = Format(MemoryStat.dwTotalPhys \ 1024, _
"###,###,##0") & " KB"
lbl(12) = "Memory Load"
lbl(13) = Format(MemoryStat.dwMemoryLoad) & "%"
#Else
lbl(11) = Format$(GetFreeSpace(0) \ 1024, _
"###,###,##0") & " KB"
lbl(13) = Format$(GetFreeSystemResources _
(GFSR_SYSTEMRESOURCES)) & "%"
#End If
'**********************************************************
' Center the form
'**********************************************************
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
'**********************************************************
' Set the pointer to default, so the user doesn't see
' an hourglass on the About box.
'**********************************************************
Screen.MousePointer = vbDefault
End Sub
'**************************************************************
' Restore the pointer to its previous state, and free memory
'**************************************************************
Private Sub Form_Unload(Cancel As Integer)
Screen.MousePointer = OrigPointer
Set AboutBox = Nothing
End Sub
'**************************************************************
' Dismiss the dialog box, and run Form_Unload
'**************************************************************
Private Sub cmdOk_Click()
Unload Me
End Sub
'**************************************************************
' If this button is visible, then this will work. Since we
' ignore the return value, you don't need parentheses or
' variable = .
'**************************************************************
Private Sub cmdSysInfo_Click()
#If Win32 Then
Shell GetWinDir(True) & "msapps\msinfo\msinfo32.exe", _
vbNormalFocus
#Else
Shell GetWinDir(True) & "msapps\msinfo\msinfo.exe"
#End If
End Sub

Listing 26.9 is the private, noncreatable About class. This class contains all the code required to display the About dialog box. To prevent exposing multiple classes for a single project, you expose only the Application class and hide the About class.

Listing 26.9 Noncreatable Classes Are Useful for Creating an Object Hierarchy

'**************************************************************
' ABOUT.CLS - This is the About class which is used to display
' the About dialog. Its Creatable and Public
' properties have been set so that it is only
' visible to this project.
'**************************************************************
Option Explicit
'**************************************************************
' Declare private variables for your properties as Variant so
' you can take advantage of IsEmpty(). Remember that Variants
' are very inefficent because they are the largest data type,
' so you should try to limit your use of them.
' I included variants just to demonstrate a variety of
' techniques, but I normally avoid variants at all costs.
'**************************************************************
Private App, AppCompany, VerNum, User, Company
Private RegNum, AboutMsg
'**************************************************************
' NOTE: For all of the following properties, if a Get is
' performed before a Let, then a default value will be
' returned. However, this value is NOT stored in its
' related private variable.
'**************************************************************
'**************************************************************
' This is a Read/Write property which should be set with the
' name of the program that is using this object.
'**************************************************************
Public Property Let AppName(str As String)
App = str
End Property
Public Property Get AppName() As String
AppName = IIf(IsEmpty(App), "AppName Default", App)
End Property
'**************************************************************
' This is a Read/Write property which should be set with the
' name of the company who wrote the application that is
' calling this object.
'**************************************************************
Public Property Let AppCompanyName(str As String)
AppCompany = str
End Property
Public Property Get AppCompanyName() As String
AppCompanyName = IIf(IsEmpty(AppCompany), _
"AppCompanyName Default", AppCompany)
End Property
'**************************************************************
' This is a Read/Write property which should be set with the
' version number of the application which is using this object.
'**************************************************************
Public Property Let VersionNumber(str As String)
VerNum = str
End Property
Public Property Get VersionNumber() As String
VersionNumber = IIf(IsEmpty(VerNum), "1.00", VerNum)
End Property
'**************************************************************
' This is a Read/Write property which should be set with the
' name of the end user who is using your application.
'**************************************************************
Public Property Let UserName(str As String)
User = str
End Property
Public Property Get UserName() As String
UserName = IIf(IsEmpty(User), "UserName Default", User)
End Property
'**************************************************************
' This is a Read/Write property which should be set with the
' user's (see above) company name.
'**************************************************************
Public Property Let CompanyName(str As String)
Company = str
End Property
Public Property Get CompanyName() As String
CompanyName = IIf(IsEmpty(Company), "CompanyName Default", _
Company)
End Property
'**************************************************************
' This is a Read/Write property which should be set with a
' registration or serial number of the product that called
' this object.
'**************************************************************
Public Property Let Registration(str As String)
RegNum = str
End Property
Public Property Get Registration() As String
Registration = IIf(IsEmpty(RegNum), "Registration Default", _
RegNum)
End Property
'**************************************************************
' This is a Read/Write property which can contain up to 2
' lines of text to display in the About box. The text will
' automatically wrap, so carriage returns aren't required.
'**************************************************************
Public Property Let Message(str As String)
AboutMsg = str
End Property
Public Property Get Message() As String
Message = IIf(IsEmpty(AboutMsg), "Message Default", AboutMsg)
End Property
'**************************************************************
' This method detrmines how the dialog box should be displayed,
' then it loads it with the appropriate values and displays it.
'**************************************************************
Public Sub ShowAbout(AsSplash As Boolean)
'**********************************************************
' Set the variable so the About box knows how to
' display itself.
'**********************************************************
bSplashScreen = AsSplash
'**********************************************************
' Set the common elements used by the splash screen and
' About box.
'**********************************************************
With AboutBox
.lbl(0) = AppName
.lbl(1) = "Version " & VersionNumber
.lbl(2) = "Copyright © " & Year(Now) & " " _
& AppCompanyName
.lbl(3) = UserName
.lbl(4) = CompanyName
.lbl(5) = Registration
.lbl(6) = Message
End With
If AsSplash Then
'******************************************************
' Show About Box as splash screen by removing its
' caption, hiding the OK button, and displaying it as
' modeless.
'******************************************************
With AboutBox
.cmdOk.Visible = False
.Caption = ""
.Show
'**************************************************
' NOTE: This refresh is required, because splash
' screens are usually show during peak
' processing times. If you don't refresh,
' then you'll just display a white form.
'**************************************************
.Refresh
End With
'******************************************************
' Set the About box on top to prevent it from
' disappearing during event processing.
'******************************************************
AlwaysOnTop AboutBox.hwnd, False
Else
With AboutBox
.cmdOk.Visible = True
.Caption = "About " & AppCompanyName
.Show 1
End With
End If
End Sub
'**************************************************************
' Unloads the about box
'**************************************************************
Public Sub HideSplash()
Unload AboutBox
End Sub

Listing 26.10 is the common module that contains elements that all objects in the class share. However, because this is a module, you cannot expose it.

Listing 26.10 Modules Are Helpful When Two or More Files in a Project Need Access to the Same Procedure or Declaration

'**************************************************************
' COMMON.BAS - This module contains declarations and
' procedures that are needed by more than one
' form or class in this project. It also includes
' the required starting point for the project by
' declaring a public Sub Main().
'**************************************************************
Option Explicit
'**************************************************************
' API calls that are only used by this module don't need to
' be public.
'**************************************************************
#If Win32 Then
Private Declare Function SetWindowPos Lib "user32" (ByVal _
hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x _
As Long, ByVal y As Long, ByVal cx As Long, ByVal cy _
As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" _
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
Public Declare Function GetVersion Lib "kernel32" () As Long
Public Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
#Else
Private Declare Function SetWindowPos Lib "User" (ByVal hwnd%, _
ByVal hb%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, _
ByVal FLAGS%) As Integer
Private Declare Function GetWindowsDirectory Lib "Kernel" _
(ByVal retStr$, ByVal bufferLen%) As Integer
'**************************************************************
' API calls used by other modules, forms, or classes, should
' be exposed via Public.
'**************************************************************
Public Declare Function GetVersion Lib "Kernel" () As Long
Public Declare Function SendMessage Lib "User" (ByVal hwnd As _
Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
lParam As Any) As Long
Public Declare Function PostMessage Lib "User" (ByVal hwnd As _
Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
lParam As Any) As Long
#End If
'**************************************************************
' This Boolean keeps track of the way the About box should
' be displayed.
'**************************************************************
Public bSplashScreen As Boolean
'**************************************************************
' This procedure will set or restore a window to the topmost
' position above all open windows.
'**************************************************************
#If Win32 Then
Public Sub AlwaysOnTop(ByVal hwnd&, ResetWindow As Boolean)
#Else
Public Sub AlwaysOnTop(ByVal hwnd%, ResetWindow As Boolean)
#End If
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Dim success%
On Error GoTo AlwaysOnTop_Err
If ResetWindow Then
success = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, _
0, 0, FLAGS)
Else
success = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, _
0, FLAGS)
End If
Exit Sub
AlwaysOnTop_Err:
ErrHandler Err, "AlwaysOnTop" & str$(ResetWindow)
Exit Sub
End Sub
'**************************************************************
' This is a generic error handler which will display a message,
' close any open files, and restore the pointer and Err.
'**************************************************************
Public Sub ErrHandler(ErrType%, FromWhere$)
'**********************************************************
' We wouldn't be here if there wasn't an error, so be sure
' to turn error handling off.
'**********************************************************
On Error Resume Next
'**********************************************************
' ErrType = 32755 is Cancel button was selected
' ErrType = 3197 Then Data has changed when 2 users
' accessing one record
'**********************************************************
If ErrType = 32755 Or ErrType = 3197 Then Exit Sub
'**********************************************************
' This statement prevents an error message if this function
' was accidentally called.
'**********************************************************
If ErrType <> 0 Then
'******************************************************
' Set Err so we can get Error
'******************************************************
Err = ErrType
'******************************************************
' Restore the mouse, and display a descriptive message
'******************************************************
Screen.MousePointer = vbDefault
MsgBox "An error of type" & str(Err) & " occured in " _
& FromWhere & ".", vbExclamation, Error
'******************************************************
' Restore Err, and close any open files to prevent
' corrupting files.
'******************************************************
Err = 0
Close
End If
End Sub
'**************************************************************
' Uses the Dir command to see if a file exists. Resume Next is
' required in case FileName contains an invalid path
'**************************************************************
Public Function FileExists(FileName$) As Boolean
On Error Resume Next
FileExists = IIf(Dir(FileName) <> "", True, False)
End Function
'**************************************************************
' Returns the path to the Windows directory with or without
' a trailing backslash.
'**************************************************************
Public Function GetWinDir(WithSlash As Boolean) As String
Dim lpBuffer$, res%, GetWin$
'**********************************************************
' Turn on error handling
'**********************************************************
On Error GoTo GetWinDir_Err
'**********************************************************
' Initialize a buffer that is large enough to hold the
' result, otherwise you'll get a GPF.
'**********************************************************
lpBuffer = Space$(2048)
'**********************************************************
' Call the function, and strip the null terminator using
' the return value.
'**********************************************************
res = GetWindowsDirectory(lpBuffer, Len(lpBuffer))
GetWin = LCase$(Left$(lpBuffer, res))
'**********************************************************
' Add or Remove the slash depending on what was returned,
' and the value of WithSlash.
'**********************************************************
If Right$(GetWin, 1) <> "\" And WithSlash Then
GetWinDir = GetWin & "\"
ElseIf Right$(GetWin, 1) = "\" And Not WithSlash Then
GetWinDir = Left$(GetWin, Len(GetWin) - 1)
Else
GetWinDir = GetWin
End If
'**********************************************************
' Don't forget to exit, otherwise you'll fall into the
' error handler.
'**********************************************************
Exit Function
'**************************************************************
' If error, call the error handler, and tell it where the
' error occurred. This is useful for distributed apps.
'**************************************************************
GetWinDir_Err:
ErrHandler Err, "GetWinDir"
Exit Function
End Function
'**************************************************************
' All projects must have an entry point (either a startup form
' or Sub Main()). This one just initializes our variables.
'**************************************************************
Sub Main()
'**********************************************************
' If this program is started manually, then show the
' About box.
'**********************************************************
If App.StartMode = vbSModeStandalone Then
Dim thisApp As New Application
thisApp.ShowAboutBox False, App:="Martinsen's Software", _
AppCompany:="Martinsen's Software", _
VerNum:="1.00.01",
User:="John Doe", Company:="XYZ Incorporated", _
AboutMsg:="This OLE object was started manually.", _
RegNum:="Registration Number: 12345"
End If
End Sub

Listing 26.11 is the Application class. This public, creatable class is this project's exposed interface. It contains a routine to display the About box and includes some other helpful functions that your calling application might need.

Listing 26.11 An Exposed Class Provides an Interface for Your OLE Server

'**************************************************************
' APP.CLS - This is the application class which is exposed
' to other OLE Automation clients. It provides some
' handy routines that aren't included in VB, and it
' is a good demonstration on how to write an OLE server
' that can be used with other Office apps.
'**************************************************************
Option Explicit
'**************************************************************
' Hidden API functions for private use only
'**************************************************************
#If Win32 Then
Private Declare Function GetPrivateProfileInt Lib "kernel32" _
Alias "GetPrivateProfileIntA" (ByVal lpApplicationName$, _
ByVal lpKeyName As String, ByVal nDefault As Long, ByVal _
lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName$, _
lpKeyName As Any, ByVal lpDefault As String, ByVal _
lpReturnedString As String, ByVal nSize As Long, ByVal _
lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib _
"kernel32" Alias "WritePrivateProfileStringA" (ByVal _
lpApplicationName As String, lpKeyName As Any, lpString _
As Any, ByVal lplFileName As String) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" (ByVal lpszLongPath As String, ByVal _
lpszShortPath As String, ByVal cchBuffer As Long) As Long
#Else
Private Declare Function GetPrivateProfileInt Lib "Kernel" _
(ByVal lpApplicationName As String, ByVal lpKeyName _
As String, ByVal nDefault As Integer, ByVal lpFileName _
As String) As Integer
Private Declare Function GetPrivateProfileString Lib "Kernel" _
(ByVal lpAppName As Any, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString _
As String, ByVal nSize As Integer, ByVal lpFileName _
As String) As Integer
Private Declare Function WritePrivateProfileString% Lib "Kernel" _
(ByVal lpAppName As Any, ByVal lpKeyName As Any, ByVal _
lpString As Any, ByVal lpFileName As String)
#End If
'**************************************************************
' Hidden variable for this class
'**************************************************************
Private thisAbout As New About
'**************************************************************
' Description: This procedure displays an About box
'
' Arguments:
' AsSplash (Boolean)- Display as splash screen?
' App (String) - The name of your application
' AppCompany(String) - The name of your company
' VerNum (String) - The version number of your app
' User (String) - The name of the registered user
' Company (String) - The user's company name
' RegNum (String) - The user's registration number
' AboutMsg (String) - Your About box message that goes
' between the 2 black lines
' IconProg (String) - The file name (without an extension)
' of the running app that contains
' the icon you would like to use.
' The default is Progman
' (for Program Manager)
'
' IconIdx (Long) - The 1 based index of the icon
' stored in IconProg. The default
' is 1
'**************************************************************
Public Sub ShowAboutBox(AsSplash As Boolean, _
Optional App, _
Optional AppCompany, _
Optional VerNum, _
Optional User, _
Optional Company, _
Optional RegNum, _
Optional AboutMsg)
'**********************************************************
' You should only set the properties if the argument was
' provided. Otherwise, just let the default values appear.
'**********************************************************
If Not IsMissing(App) Then thisAbout.AppName = App
If Not IsMissing(AppCompany) Then _
thisAbout.AppCompanyName = AppCompany
If Not IsMissing(VerNum) Then thisAbout.VersionNumber = VerNum
If Not IsMissing(User) Then thisAbout.UserName = User
If Not IsMissing(Company) Then thisAbout.CompanyName = Company
If Not IsMissing(RegNum) Then thisAbout.Registration = RegNum
If Not IsMissing(AboutMsg) Then thisAbout.Message = AboutMsg
'**********************************************************
' Show it using the About object
'**********************************************************
thisAbout.ShowAbout AsSplash
End Sub
'**************************************************************
' Returns a reference to an About object so that its properties
' may be accessed individually.
'**************************************************************
Public Property Get CreateAbout() As Object
Set CreateAbout = thisAbout
End Property
'**************************************************************
' Unload via the About object
'**************************************************************
Public Sub UnloadSplash()
thisAbout.HideSplash
End Sub
'**************************************************************
' This method is just a wrapper for the global function which
' the About object needs too. This demonstrates how you can
' expose nonclass objects.
'**************************************************************
' NOTE: You may be wondering why I didn't just put the code
' in here, and require other modules to just call this
' one. The reason is that this is a class. If another
' module wants to use a class method, then they must
' create an object which consumes a great deal of
' memory. This method exposes our object, but it also
' leaves it available to all forms by putting it into
' a module. This duplication is actually an optimization.
'**************************************************************
#If Win32 Then
Public Sub AlwaysOnTop(ByVal hwnd&, ResetWindow As Boolean)
#Else
Public Sub AlwaysOnTop(ByVal hwnd%, ResetWindow As Boolean)
#End If
Common.AlwaysOnTop hwnd, ResetWindow
End Sub
'**************************************************************
' This method is a wrapper for Common.FileExists.
'**************************************************************
Public Function FileExists(FileName$) As Boolean
FileExists = Common.FileExists(FileName)
End Function
'**************************************************************
' This method is a wrapper for Common.GetWinDir.
'**************************************************************
Public Function GetWinDir(WithSlash As Boolean) As String
GetWinDir = Common.GetWinDir(WithSlash)
End Function
#If Win32 Then
'**************************************************************
' This function converts a long file name into a DOS-compatible
' short file name.
'**************************************************************
Private Function GetShortName(LongFileName As String) As String
Dim strFileName As String
strFileName = Space(2048)
GetShortName = Left(strFileName, GetShortPathName _
(LongFileName, strFileName, Len(strFileName)))
End Function
#End If
'**************************************************************
' This method extracts the file name (with extension) from a
' fully qualified path. If path = "c:\autoexec.bat", then
' this method returns "autoexec.bat".
'**************************************************************
' NOTE: This method is not used by any modules or forms in this
' project, so its code belongs here.
'**************************************************************
'***************************************************************
' WARNING: This function modifies Path, so ByVal is required.
'***************************************************************
Public Function ExtractFileName(ByVal Path As String) As String
Dim res%
'***********************************************************
' One of the few uses for GoTo is as an error handler,and
' this is a great example of how to use them.
'***********************************************************
On Error GoTo ExtractFileName_Err
'***********************************************************
' Since a file name (with extension) in DOS can only be
' a maximum of 13 chars (8 + 1 + 3), get rid of the rest.
'***********************************************************
#If Win32 Then ' Convert LFN's to SFN's
Path = GetShortName(Path)
#End If
If Len(Path) > 13 Then Path = Right(Path, 13)
res = InStr(Path, "\")
'***********************************************************
' Get rid of the rest of the garbage by looking for slashes.
'***********************************************************
Do While res <> 0
Path = Mid$(Path, res + 1, Len(Path))
res = InStr(Path, "\")
Loop
'***********************************************************
' Return the result, and exit the function to prevent
' executing the error handler.
'***********************************************************
ExtractFileName = Path
Exit Function
'***************************************************************
' Our error handler calls an external module's generic error
' handler, and exits to prevent further damage.
'***************************************************************
ExtractFileName_Err:
ErrHandler Err, "ExtractFileName"
Exit Function
End Function
'**************************************************************
' Calls the API to read an .INI file, and return the results.
' A large buffer is used so that this function can be used
' in any app without causing a GPF.
'***************************************************************
' NOTE: ByVal is used, so you can pass control values such
' as Text1.Text without surrounding it in parentheses.
'**************************************************************
Public Function GetINI(ByVal Section$, ByVal Key$, ByVal _
Default$, ByVal FileName$) As String
Dim res&, retVal$
retVal = Space$(32400)
res = GetPrivateProfileString(Section, Key, Default, _
retVal, Len(retVal), FileName)
GetINI = Left$(retVal, res)
End Function
'**************************************************************
' Same as above, but it returns an integer.
'**************************************************************
Public Function GetINIInt(ByVal Section$, ByVal Key$, ByVal _
Default%, ByVal FileName$) As Integer
GetINIInt = GetPrivateProfileInt(Section, Key, Default, _
FileName)
End Function
'**************************************************************
' This function is useful with SendMessage and GetVersion
' so you can get the low order word.
'**************************************************************
Public Function GetLoWord(ByVal DWORD&) As Long
GetLoWord = DWORD And &HFFFF&
End Function
'**************************************************************
' Same as above, but returns the high order word.
'**************************************************************
Public Function GetHiWord(ByVal DWORD As Long) As Long
GetHiWord = DWORD \ &H10000
End Function
#If Win16 Then
'**************************************************************
' This function is EXTREMELY useful under Win16 for making
' a DWORD which is sometimes required by SendMessage's lParam
' argument.
'**************************************************************
Public Function MakelParam(LoWord%, HiWord%) As Long
MakelParam = CLng(HiWord) * &H1000& Or LoWord
End Function
#End If
'**************************************************************
' This method returns the Windows version as a variant so you
' can use it as text or as a number.
'**************************************************************
Public Function WindowsVersion() As Variant
Dim WinVer As Long
WinVer = GetLoWord(GetVersion())
WindowsVersion = Format((WinVer Mod 256) + ((WinVer \ 256) _
/ 100), "Fixed")
End Function
'**************************************************************
' This methods accepts alphanumeric settings to write to an
' .INI file. In addition, you can delete a section or key by,
' passing the special "_DELETE_" string.
'**************************************************************
Public Sub WriteINI(ByVal Section$, ByVal Key$, ByVal Setting _
As Variant, ByVal FileName$)
'**********************************************************
' If key is set to _DELETE_, then delete the section
'**********************************************************
If Key = "_DELETE_" Then
WritePrivateProfileString Section, 0&, 0&, FileName
'**********************************************************
' If setting is set to _DELETE_, then delete the key
'**********************************************************
ElseIf Setting = "_DELETE_" Then
WritePrivateProfileString Section, Key, 0&, FileName
'**********************************************************
' Otherwise, convert the setting to a string and write it
' to the .INI file.
'**********************************************************
Else
WritePrivateProfileString Section, Key, CStr(Setting), _
FileName
End If
End Sub
#If Win32 Then
'**************************************************************
' This method demonstrates how you can expose API calls. Since
' you can't use As Any with functions, SendMessage requires
' type-safe versions.
'**************************************************************
Public Function SendMessageAsLong(hwnd As Long, wMsg As _
Integer, wParam As Long, lParam As Long) As Long
SendMessageAsLong = Common.SendMessage(hwnd, wMsg, wParam, _
lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function SendMessageAsStr(hwnd As Long, wMsg As _
Integer, wParam As Long, lParam As String) As Long
SendMessageAsStr = Common.SendMessage(hwnd, wMsg, wParam, _
lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function PostMessage(ByVal hwnd As Long, ByVal wMsg _
As Integer, ByVal wParam As Long, lParam As Long) As Long
PostMessage = Common.PostMessage(ByVal hwnd, wMsg, wParam, _
lParam)
End Function
#Else
'**************************************************************
' This method demonstrates how you can expose API calls. Since
' you can't use As Any with functions, SendMessage requires
' type-safe versions.
'**************************************************************
Public Function SendMessageAsLong(hwnd As Integer, wMsg As _
Integer, wParam As Integer, lParam As Long) As Long
SendMessageAsLong = Common.SendMessage(hwnd, wMsg, wParam, _
lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function SendMessageAsStr(hwnd As Integer, wMsg As _
Integer, wParam As Integer, lParam As String) As Long
SendMessageAsStr = Common.SendMessage(hwnd, wMsg, wParam, _
lParam)
End Function
'**************************************************************
' See above.
'**************************************************************
Public Function PostMessage(ByVal hwnd As Integer, ByVal wMsg _
As Integer, ByVal wParam As Integer, lParam As Long) As Long
PostMessage = Common.PostMessage(ByVal hwnd, wMsg, wParam, _
lParam)
End Function
#End If

The net result of this project is an exposed class that other VBA applications (such as Excel) can use to display a dialog box (see fig. 26.12) and access some helpful routines. It also demonstrates how you can create resusable objects that are more useful than DLLs without having to learn C.

Fig. 26.12

You can call this generic About box from any OLE Automation client, including Access, Excel, and Project.

To use this handy OLE Server from Excel, you need only to create an object variable of this type and access its member functions. Listing 26.12 demonstrates how to use the ShowAboutBox method, but the same method applies for all its member functions.

Listing 26.12 OLE Servers Created in VB Can Be Used with External Applications Such as Excel

Sub ShowAbout()
Dim Helpful As Object
Set Helpful = CreateObject("Useful.Application")
Helpful.ShowAboutBox AsSplash:=False, _
App:="My Excel Workbook",
AppCompany:="Martinsen's Software", VerNum:="1.00", _
User:="Ronald R. Martinsen", Company:="", RegNum:="1234-567", _
AboutMsg:="My AboutMessage Goes Here!"
End Sub

Because Visual Basic can create OLE Automation servers, you might find that other applications (for example, Access, Excel, or Project) are better source programs for your application code. You will also find that you can save yourself a lot of work without giving up the power of Visual Basic 4.0.

Using DDE with Microsoft Excel

As the previous chapter mentioned, any VB programmer should never have any valid reason to use DDE with a application that supports OLE Automation. Because Excel has an outstanding type library exposed, you should take advantage of it through OLE Automation. For this reason, this book intentionally does not cover this topic.

From Here...

Unfortunately, this chapter could cover only a few of the amazing things that you can do when integrating VB with Excel. However, the following are some great, highly recommended resources:

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