This set of procedures can be used in Microsoft Access to collect messages during a process to display to the user after the process is complete. It provides a good example of how to use collections in VBA.
For instance, you could track the progress of some calculations and then message the user like this:
InitMsg
' Track the calculation numbers.
dblRatio = DLookup("Ratio","Settings")
AddMsg "Ratio: " & dblRatio
dblOrders = DCount("OrderNumber","Orders")
AddMsg "Orders: " & dblOrders
dblOrdersRatio = dblRatio * dblOrders
AddMsg "Orders Ratio: " & dblOrdersRatio
' Message the user the results.
MsgBox Msg, , "Calculation"
QuitMsg
Code:
Option Compare Database
Option Explicit
' basMsg.bas Version 1.0.0
' Copyright © 2009 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact support@extramiledata.com.
' Use (at your own risk) and modify freely as long as proper credit is given.
' This set of functions is used to manage a collection of messages.
' 1. Call InitMsg to initialize the collection.
' 2. Call AddMsg to add to the collection.
' 3. Call Msg to see a comma-delimited list of messages in the collection.
' 3. Call EmptyMsg to empty the collection if you need to start over.
' 4. Call QuitMsg to remove the collection.
' This is the global collection.
Public gcolMsg As Collection
Public Sub TestMsg()
' This is an example of how the set of procedures work.
' Initialize the collection.
InitMsg
' Add messages.
AddMsg "comment 1"
AddMsg "comment 2"
AddMsg "Comment 3"
' Retrieve the messages (in the Immediate window for this example).
Debug.Print "Before:" & vbCrLf & Msg
' Empty the collection to start again.
EmptyMsg
' Now there should be no messages.
Debug.Print "After:" & vbCrLf & Msg
' Remove the collection.
QuitMsg
End Sub
Public Sub InitMsg()
' This procedure initializes the collection.
Set gcolMsg = New Collection
End Sub
Public Function QuitMsg()
' This procedure removes the collection.
Set gcolMsg = Nothing
End Function
Public Sub AddMsg(Msg As String)
' This procedure adds a new message to the collection.
' If the message collection is initialized,
' then add Msg to the collection.
If Not (gcolMsg Is Nothing) Then gcolMsg.Add Msg
End Sub
Public Function Msg() As Variant
' This function returns a list of messages from the collection, separated
' by carriage-return/line feeed. If there are no messages, it returns Null.
On Error GoTo Err_Msg
Dim varMsg
Dim strResult As String
' If the collection was not initialized, then just return
' a Null.
If gcolMsg Is Nothing Then
Msg = Null
Exit Function
End If
' Initialize the result variable.
strResult = ""
' Loop through all the messages in the collection, adding each
' to strResult, separated by a carriage return.
For Each varMsg In gcolMsg
If Len(strResult) = 0 Then
strResult = varMsg
Else
strResult = strResult & vbCrLf & varMsg
End If
Next
' If there were no messages, then pass back a Null.
' Otherwise, return the result.
If Len(strResult) = 0 Then
Msg = Null
Else
Msg = strResult
End If
Exit_Msg:
On Error Resume Next
Exit Function
Err_Msg:
MsgBox Err.Number & " " & Err.Description, vbCritical, "Msg()"
Msg = Null
Resume Exit_Msg
End Function
Public Function EmptyMsg() As Boolean
' This function empties all the messages from the collection.
On Error GoTo Err_EmptyMsg
Dim varMsg
' If the collection was not initialized, then just return
' a true.
If gcolMsg Is Nothing Then
EmptyMsg = True
Exit Function
End If
' Loop through all the messages in the collection, starting at
' the largest index and working back to 1, removing each one.
For varMsg = gcolMsg.Count To 1 Step -1
gcolMsg.Remove (varMsg)
Next
EmptyMsg = True
Exit_EmptyMsg:
On Error Resume Next
Exit Function
Err_EmptyMsg:
MsgBox Err.Number & " " & Err.Description, vbCritical, "EmptyMsg()"
EmptyMsg = False
Resume Exit_EmptyMsg
End Function
Download Code: basMsg.zip