Although you can't write a traditional DLL in Visual Basic, you can write a class that you can expose to other applications (such as Excel). In fact, this section shows you how OLE Automation servers that you create with VB are more useful and easy to use than any traditional DLL ever could be.
The Useful Class Object
Before reading this section, you already should have read about classes and OLE Automation servers, including how to write an OLE Automation server in Chapter 18 of this book. However, the USEFUL.VBP project is rather lengthy, so it requires additional explanation.
USEFUL.VBP's first file is the About dialog box form. External applications use this form to easily display a professional-looking About dialog box. This form (shown at design time in Figure 26.8) includes only the minimum code necessary to initialize the form. demonstrates how to create a generic About box.
The generic About box at design time differs significantly from its runtime counterpart.
Listing 26.8 - ABOUTBOX.FRM - A Generic About Box Is Useful for Giving Your Applications a Consistent Look and Feel
'*********************************************************************
' ABOUTBOX.FRM - This form contains a generic about dialog box which
' is accessed by the About class.
'*********************************************************************
Option Explicit
'*********************************************************************
' Form level variables for preserving the pointer, and creating an
' About object
'*********************************************************************
Private mintOrigPointer As Integer
Private mstrMSInfo As String
'*********************************************************************
' Form Initialization
'*********************************************************************
Private Sub Form_Load()
Dim clsMemorySnap As New clsMemorySnapshot
'*****************************************************************
' Remember the current pointer, and change it to an hourglass
'*****************************************************************
mintOrigPointer = Screen.MousePointer
Screen.MousePointer = vbHourglass
'*****************************************************************
' If this form isn't being displayed as a splash screen
'*****************************************************************
If Not gblnSplashScreen Then
'*****************************************************************
' Set the visible property of the button based on the existence of
' msinfo32.exe (from Microsoft)
'*****************************************************************
mstrMSInfo = GetRegString(HKEY_LOCAL_MACHINE, _
"Software\Microsoft\Shared Tools\MSInfo", "Path")
cmdSysInfo.Visible = FileExists(mstrMSInfo)
'*****************************************************************
' NOTE: You CAN NOT distribute MSINFO.EXE, so this is the next
' best thing
'*****************************************************************
End If
'*****************************************************************
' Set the label to reflect the windows version information
'*****************************************************************
lbl(9) = GetWindowsVersion()
'*****************************************************************
' Get memory information from clsMemory
'*****************************************************************
With clsMemorySnap
lbl(11) = Format(.TotalMemory \ 1024, "###,###,##0") & " KB"
lbl(13) = Format(.FreeMemory \ 1024, "###,###,##0") & " KB"
End With
'*****************************************************************
' Center the form
'*****************************************************************
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
'*****************************************************************
' Set the pointer to default, so the user doesn't see and
' 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 = mintOrigPointer
Set frmAboutBox = 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 parenthesis or variable =
'*********************************************************************
Private Sub cmdSysInfo_Click()
Shell mstrMSInfo, vbNormalFocus
End Sub
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 - ABOUT.CLS - 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 Instancing properties have been set so that it ' is only visible to this project. '********************************************************************* Option Explicit DefVar A-Z '********************************************************************* ' Declare private variables for your properties as Variant so you can ' take advantage of IsEmpty(). Remember that Variants are very ' inefficient 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 mvntApp, mvntAppCompany, mvntVerNum, mvntUser, mvntCompany Private mvntRegNum, mvntAboutMsg '********************************************************************* ' You can also create a read/write property by using a public ' variable, but this goes against the basic object-oriented ' programming rule of encapsulation (or data hiding) '********************************************************************* Public Copyright As String '********************************************************************* ' NOTE:For all of the following properties, if a Get is performed ' before a Let, then a default value will be returned '********************************************************************* ' 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) mvntApp = str End Property Public Property Get AppName() As String AppName = IIf(IsEmpty(mvntApp), "AppName Default", mvntApp) 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) Attribute AppCompanyName.VB_Description = "The software vendors name who will appear in the about box. (Read/Write)" mvntAppCompany = str End Property Public Property Get AppCompanyName() As String AppCompanyName = IIf(IsEmpty(mvntAppCompany), _ "AppCompanyName Default", mvntAppCompany) 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) Attribute VersionNumber.VB_Description = "The version number of the calling application as you want it to appear in the about box. (Read/Write)" mvntVerNum = str End Property Public Property Get VersionNumber() As String VersionNumber = IIf(IsEmpty(mvntVerNum), "1.00", mvntVerNum) 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) mvntUser = str End Property Public Property Get UserName() As String UserName = IIf(IsEmpty(mvntUser), "UserName Default", mvntUser) 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) Attribute CompanyName.VB_Description = "The end user's company name that will appear in the about box. (Read/Write)" mvntCompany = str End Property Public Property Get CompanyName() As String CompanyName = IIf(IsEmpty(mvntCompany), "CompanyName Default", _ mvntCompany) 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) Attribute Registration.VB_Description = "The registration or serial number you want to appear in the about box. (Read/Write)" mvntRegNum = str End Property Public Property Get Registration() As String Registration = IIf(IsEmpty(mvntRegNum), "Registration Default", _ mvntRegNum) End Property '********************************************************************* ' This is a Read/Write property which can contain up to two 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) Attribute Message.VB_Description = "Any additional info you want to appear in the about box between the black lines. (Read/Write)" mvntAboutMsg = str End Property Public Property Get Message() As String Message = IIf(IsEmpty(mvntAboutMsg), "Message Default", mvntAboutMsg) End Property '********************************************************************* ' This method determines how the dialog box should be displayed, then ' it loads it with the appropriate values and displays it '********************************************************************* Public Sub ShowAbout(blnAsSplash As Boolean) '***************************************************************** ' Set the global variable so the about box knows how to display ' itself '***************************************************************** gblnSplashScreen = blnAsSplash '***************************************************************** ' Set the common elements used by the splash screen and ' about box. '***************************************************************** With frmAboutBox .lbl(0) = AppName .lbl(1) = "Version " & VersionNumber .lbl(2) = Copyright .lbl(3) = UserName .lbl(4) = CompanyName .lbl(5) = Registration .lbl(6) = Message End With If blnAsSplash Then '************************************************************* ' Show About Box as Splash Screen by removing its caption, ' hiding the ok button, and displaying it as modeless '************************************************************* With frmAboutBox .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 an empty form '********************************************************* .Refresh End With '************************************************************* ' Set the about box on top to prevent it from disappearing ' during event processing '************************************************************* AlwaysOnTop frmAboutBox.hWnd, False Else With frmAboutBox .cmdOk.Visible = True .Caption = "About " & AppCompanyName .Show vbModal End With End If End Sub '********************************************************************* ' Unloads the about box '********************************************************************* Public Sub CloseAbout() Unload frmAboutBox End Sub
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 - COMMON.BAS - 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 need 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
'*********************************************************************
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd&, _
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
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
'*********************************************************************
' Types, constants and declarations required to get the Win version
'*********************************************************************
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 'Maintenance string for PSS usage
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias _
"GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
'*********************************************************************
' Global splash screen variable
'*********************************************************************
Public gblnSplashScreen As Boolean
'*********************************************************************
' This procedure will set or restore a window to the topmost position
' above all open windows
'*********************************************************************
Public Sub AlwaysOnTop(hWnd As Long, blnResetWindow As Boolean)
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
On Error GoTo AlwaysOnTop_Err
If blnResetWindow Then
SetWindowPos hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS
Else
SetWindowPos hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
End If
Exit Sub
AlwaysOnTop_Err:
ErrHandler Err, "AlwaysOnTop " & CStr(blnResetWindow)
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(lngErrType As Long, strFromWhere As String)
'*****************************************************************
' We wouldn't be here if there wasn't an error, so be sure to turn
' error handling off
'*****************************************************************
On Error Resume Next
'*****************************************************************
' lngErrType = 32755 is Cancel button was selected
' lngErrType = 3197 Then data has changed when 2 users accessing
' one record
'*****************************************************************
If lngErrType = 32755 Or lngErrType = 3197 Then Exit Sub
'*****************************************************************
' This statement prevents a error message if this function was
' accidentally called
'*****************************************************************
If lngErrType Then
'*************************************************************
' Restore the mouse, and display a descriptive message
'*************************************************************
Screen.MousePointer = vbDefault
MsgBox "An error of type" & str(lngErrType) & " occurred in " _
& strFromWhere & ".", vbExclamation, Error
'*************************************************************
' Restore Err, and close any open files to prevent corrupting
' files
'*************************************************************
Err.Clear
'Close ' You might want to consider using this line
End If
End Sub
'*********************************************************************
' Uses the Dir command to see if a file exists. Resume Next is
' required in case strFileName contains an invalid path or drive.
'*********************************************************************
Public Function FileExists(strFileName As String) As Boolean
On Error Resume Next
FileExists = IIf(Len(strFileName), Len(Dir(strFileName)), False)
End Function
'*********************************************************************
' Returns a string suitable for displaying in a dialog box
'*********************************************************************
Public Function GetWindowsVersion() As String
Dim strOS As String
Dim osvVersion As OSVERSIONINFO
Dim strMaintBuildInfo As String
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
'*****************************************************************
' Many Win32 API's have a first parameter that indicates the size
' of the structure (in bytes) so these structures will be portable
' to future OS versions or different systems (such as 64 bit
' systems or OS's). It is your responsibility to set this field
' prior to making the API call, and the Len function helps you
' to do that.
'*****************************************************************
osvVersion.dwOSVersionInfoSize = Len(osvVersion)
'*****************************************************************
' Get the version (exit if the GetVersionEx failed)
'*****************************************************************
If GetVersionEx(osvVersion) = 0 Then Exit Function
'*****************************************************************
' Get a string that represents the installed Operating System
'*****************************************************************
Select Case osvVersion.dwPlatformId
Case VER_PLATFORM_WIN32_WINDOWS
strOS = "Windows "
Case VER_PLATFORM_WIN32_NT
strOS = "Windows NT "
Case Else ' Impossible because VB doesn't run under Win32s
strOS = "Win32s "
End Select
'*****************************************************************
' Get the major, minor, and build numbers and concatenate them
' to the OS name
'*****************************************************************
With osvVersion
strOS = strOS & CStr(.dwMajorVersion) & "." & _
CStr(.dwMinorVersion) & "." & _
CStr(.dwBuildNumber And &HFFFF&)
strMaintBuildInfo = Left(.szCSDVersion, _
InStr(.szCSDVersion, Chr(0)))
End With
'*****************************************************************
' If this isn't a maintenance build (i.e., 4.xx.xxxx A)...
'*****************************************************************
If strMaintBuildInfo = Chr(0) Then
GetWindowsVersion = strOS
'*****************************************************************
' Otherwise include the maintenance build info
'*****************************************************************
Else
GetWindowsVersion = strOS & " " & _
Left(strMaintBuildInfo, Len(strMaintBuildInfo) - 1)
End If
End Function
'*********************************************************************
' Returns the path to the Windows directory with or without a trailing
' backslash
'*********************************************************************
Public Function GetWinDir(Optional blnWithSlash As Boolean) As String
Dim strWinDir As String
'*****************************************************************
' Get the windows directory using the windir environment variable
' that is available in all versions of Windows
'*****************************************************************
strWinDir = Environ$("windir")
'*****************************************************************
' Add or Remove the slash depending on what was returned,
' and the value of blnWithSlash.
'*****************************************************************
If Right$(strWinDir, 1) <> "\" And blnWithSlash Then
GetWinDir = strWinDir & "\"
ElseIf Right$(strWinDir, 1) = "\" And Not blnWithSlash Then
GetWinDir = Left$(strWinDir, Len(strWinDir) - 1)
Else
GetWinDir = strWinDir
End If
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 blnAsSplash:=False, _
strApp:=App.ProductName, _
strAppCompany:=App.CompanyName, _
strVerNum:=App.Major & "." & App.Minor, _
strCopyright:=App.LegalCopyright, _
strUser:="John Doe", _
strCompany:="XYZ Incorporated", _
strAboutMsg:="This OLE object was started manually.", _
strRegNum:="Registration Number: 12345"
End If
End Sub
is the Application class. This public, creatable class is USEFUL.VBP's exposed interface. It contains a routine to display the About box and includes other helpful functions that your calling application might need.
Listing 26.11 - APP.CLS - 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 a OLE server that can be used with other Office apps.
'*********************************************************************
Option Explicit
'*********************************************************************
' Hidden API Functions for private use only
'*********************************************************************
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
'*********************************************************************
' Hidden variable for this class
'*********************************************************************
Private mclsAbout As New About
'*********************************************************************
' Description: This procedure displays an about box
'
' Arguments:
' blnAsSplash (Boolean)- Display as splash screen?
' strApp (String) - The name of your application
' strAppCompany(String) - The name of your company
' strVerNum (String) - The version number of your app
' strCopyright (String) - The copyright info for your product
' strUser (String) - The name of the registered user
' strCompany (String) - The User's company name
' strRegNum (String) - The User's registration number
' strAboutMsg (String) - Your about box message that goes
' between the 2 black lines
'*********************************************************************
Public Sub ShowAboutBox(blnAsSplash As Boolean, _
Optional strApp As String, _
Optional strAppCompany As String, _
Optional strVerNum As String, _
Optional strCopyright As String, _
Optional strUser As String, _
Optional strCompany As String, _
Optional strRegNum As String, _
Optional strAboutMsg As String)
'*****************************************************************
' You should only set the properties If Len(the argument was provided.
' Otherwise, just let the default values appear.
'*****************************************************************
With mclsAbout
If Len(strApp) Then .AppName = strApp
If Len(strAppCompany) Then .AppCompanyName = strAppCompany
If Len(strVerNum) Then .VersionNumber = strVerNum
If Len(strCopyright) Then
.Copyright = strCopyright
Else
.Copyright = "Copyright " & Chr(169) & _
str(Year(Now)) & " " & .AppCompanyName
End If
If Len(strUser) Then .UserName = strUser
If Len(strCompany) Then .CompanyName = strCompany
If Len(strRegNum) Then .Registration = strRegNum
If Len(strAboutMsg) Then .Message = strAboutMsg
'*************************************************************
' Show it using the About object
'*************************************************************
.ShowAbout blnAsSplash
End With
End Sub
'*********************************************************************
' Returns a reference to an About object so that its properties may be
' accessed individually - HIDDEN - FOR INTERNAL USE ONLY
'*********************************************************************
Public Property Get About() As Object
Set About = mclsAbout
End Property
'*********************************************************************
' Unload via the About object
'*********************************************************************
Public Sub UnloadAbout()
mclsAbout.CloseAbout
End Sub
'*********************************************************************
' The following methods are just a wrappers for the public BAS module
' functions that the about object needs. This programming style
' demonstrates how you can expose non-creatable class objects to your
' external object users
'*********************************************************************
Public Sub AlwaysOnTop(hWnd As Long, blnResetWindow As Boolean)
basCommon.AlwaysOnTop hWnd, blnResetWindow
End Sub
'*********************************************************************
' This method is a wrapper for basCommon.FileExists
'*********************************************************************
Public Function FileExists(strFileName As String) As Boolean
FileExists = basCommon.FileExists(strFileName)
End Function
'*********************************************************************
' This method is a wrapper for basCommon.GetWinDir
'*********************************************************************
Public Function GetWinDir(blnWithSlash As Boolean) As String
GetWinDir = basCommon.GetWinDir(blnWithSlash)
End Function
'*********************************************************************
' This function converts a long file name into a DOS compatible short
' file name
'*********************************************************************
Private Function GetShortName(strLongFileName As String) As String
Dim strFileName As String
strLongFileName = Space(270)
GetShortName = Left(strFileName, GetShortPathName _
(strLongFileName, strFileName, Len(strFileName)))
End Function
'*********************************************************************
' This method extracts the filename (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 strPath As String) As String
Dim res As Integer
'*****************************************************************
' 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
'*****************************************************************
' Convert LFN's to SFN's
'*****************************************************************
strPath = GetShortName(strPath)
'*****************************************************************
' Since a filename (with extension) in DOS can only be a maximum
' of 13 chars (8 + 1 + 3), get rid of the rest
'*****************************************************************
If Len(strPath) > 13 Then strPath = Right(strPath, 13)
res = InStr(strPath, "\")
'*****************************************************************
' Get rid of the rest of the garbage by looking for slashes
'*****************************************************************
Do While res <> 0
strPath = Mid$(strPath, res + 1, Len(strPath))
res = InStr(strPath, "\")
Loop
'*****************************************************************
' Return the result, and exit the function to prevent executing
' the error handler
'*****************************************************************
ExtractFileName = strPath
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
'*********************************************************************
' Returns a string suitable for displaying in a dialog box
'*********************************************************************
Public Function GetWindowsVersion() As String
GetWindowsVersion = basCommon.GetWindowsVersion()
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 parenthesis
'*********************************************************************
Public Function GetINI(ByVal strSection$, ByVal strKey$, ByVal _
strDefault$, ByVal strFileName$) As String
Dim res As Long, strBuffer As String
strBuffer = Space$(2048)
res = GetPrivateProfileString(strSection, strKey, strDefault, _
strBuffer, Len(strBuffer), strFileName)
GetINI = Left$(strBuffer, res)
End Function
'*********************************************************************
' Same as above, but it returns an integer
'*********************************************************************
Public Function GetINIInt(ByVal strSection$, ByVal strKey$, ByVal _
intDefault%, ByVal strFileName$) As Integer
GetINIInt = GetPrivateProfileInt(strSection, strKey, _
intDefault, strFileName)
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 strSection As String, ByVal strKey As String, _
ByVal vntSetting As Variant, ByVal strFileName As String)
'*****************************************************************
' If key is set to _DELETE_, then delete the section
'*****************************************************************
If strKey = "_DELETE_" Then
WritePrivateProfileString strSection, 0&, 0&, strFileName
'*****************************************************************
' If setting is set to _DELETE_, then delete the key
'*****************************************************************
ElseIf vntSetting = "_DELETE_" Then
WritePrivateProfileString strSection, strKey, 0&, strFileName
'*****************************************************************
' Otherwise, convert the setting to a string and write it
' to the INI file.
'*****************************************************************
Else
WritePrivateProfileString strSection, strKey, _
CStr(vntSetting), strFileName
End If
End Sub
'*********************************************************************
' This function is useful with SendMessage and GetVersion so you can
' get the low order word
'*********************************************************************
Public Function GetLoWord(ByVal lngDWord As Long) As Integer
If lngDWord And &H8000& Then
GetLoWord = &H8000 Or (lngDWord And &H7FFF&)
Else
GetLoWord = lngDWord And &HFFFF&
End If
End Function
'*********************************************************************
' Same as above, but returns the high order word
'*********************************************************************
Public Function GetHiWord(ByVal lngDWord As Long) As Integer
GetHiWord = lngDWord \ &H10000
End Function
'*********************************************************************
' 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 Long, wParam _
As Long, lParam As Long) As Long
SendMessageAsLong = SendMessage(hWnd, wMsg, wParam, lParam)
End Function
'*********************************************************************
' See above.
'*********************************************************************
Public Function SendMessageAsStr(hWnd As Long, wMsg As Long, wParam _
As Long, lParam As String) As Long
SendMessageAsStr = SendMessage(hWnd, wMsg, wParam, ByVal lParam)
End Function
'*********************************************************************
' See above.
'*********************************************************************
Public Function PostMessage(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Long) As Long
PostMessage = PostMessage(hWnd, wMsg, wParam, lParam)
End Function
The net result of this project is an exposed class that other VBA applications, such as Access, can use to display a dialog box (see Figure 26.9) and access helpful routines. It also demonstrates how you can create reusable objects that are more useful than DLLs without having to learn C.
You can call this generic About box from Excel or any other OLE Automation server.
To use this handy OLE server from Excel, you need only create an object variable of our new Useful object, add the object in the References dialog box, and then access Useful's member functions. The code in demonstrates how to use the ShowAboutBox method, but the same method applies for all its member functions.
Listing 26.12 - SHOWABOUT.TXT - This Code Can Be Useful in Excel or Any Other VBA Host
Sub ShowAbout()
Dim Helpful As New Useful.Application
Helpful.ShowAboutBox blnAsSplash:=False, strApp:="VBA From Other App Test", _
strAppCompany:="Big Software Company", strVerNum:="2.00.1234", _
strUser:="Ronald R. Martinsen", strCompany:="Martinsen's Software", _
strRegNum:="12345-67-890", strAboutMsg:="Legal Junk Goes Here"
End Sub
Private Sub CommandButton1_Click()
ShowAbout
End Sub
Because Visual Basic can create OLE Automation servers, you might find that other applications (such as Excel or Word) are better source programs for your application code. By developing your code in a product that uses VBE and VBA, you can leverage its features and use shared OLE Automation objects written in VB. This allows you to choose the right product for the right task, so you can avoid writing unnecessary code.
