I learned a lot from developers who shared code samples on the web and in UseNet news groups. While I firmly believe that a developer learns more from their mistakes than their successes I also believe a developer needs to explore existing code samples. Taking a cautious approach to on-line code samples without assuming they are well-designed, debugged or appropriate for your needs can help developers learn new techniques, introduce alternative design methodologies and challenge your abilities. My intent is to post code samples I haven't found elsewhere hoping that you explore and challenge it and share your findings with me. I learned so much from others on the 'net that it is rewarding and necessary for me to do the same for others.

White Tigers

The white tiger (also known as the Bengal tiger) is about 3 meters long, and weighs approximately 180-285 kg (400-569 lbs). It’s coat lies flatter than that of the Siberian tiger, the tawny color is richer and the stripes are darker.

White tigers are white colored bengals, they are not albinos and they are not a seperate subspecies of tigers.

They have blue eyes, a pink nose, and creamy white fur covered with chocolate colored stripes. White tigers are born to tigers that carry the unusual gene needed for white coloring. Wild white tigers are very rare.

They are usually located on the Mainland of Southeastern Asia and in central and southern India. The white Bengal tiger lives in grassy or swampy areas and forests, where they can be well camouflaged. Those living on islands have almost disappeared; most now live in zoo’s or special wildlife parks.

White Tiger

Code Samples

NOTE:
Code presented in the code panes below may line wrap. If you can stretch your browser's width then they may unwrap. Just beware of the line wrap issue.




Code To HTML Convertor

Convert HTML/XML or VBA code to viewable HTML by copying your HTML/XML or VBA code into this page and pressing the appropriate button. Your code will be converted on-line to nicely formatted HTML using the <code> tag and some <span> elements. Extremely useful (used here - check out the code boxs below.). VBA code will display with the syntax coloring used by Access!

Updated 2009-02-14.


Rich Text Textboxes

Just a quick note for those of you wrestling with Rich Text flavor of the textbox control. I knew it was based on HTML rather than the Microsoft Rich Text Format (RTF) used by Word. Despite its name it doesn't support RTF codes and it only supports a limited set of HTML tags, some that have been deprecated for awhile. I wasn't able to find this info in the on-line help or in MSDN. Instead I happened across a MS blog that provided the most guidance I've found anywhere on line.

Here, in short format, are the supported HTML tags:


<font face="Arial Black" size=3 color="#A5A5A5" style="BACKGROUND-COLOR:#FFFF00">
<strong>
<em>
<u>
<br>
<div align=right dir=RTL>
<blockquote>
<ol> and <li> for number
<ul> and <li> for bulleted lists
            

Updated 2009-02-28.


Metamorphosis

The goal behind Metamorphosis is to provide sample code that can be used to migrate older Access data (i.e. Back-End data) into the running Access app's back-end and to handle the conversion process to the different format (new fields, dropped fields, type conversions, etc.). Metamorphosis won't create tables or relationships. Metamorphosis is a class module that you call from code in a module, form, menu or coded to run automagically.

This isn't a cut-and-paste solution for a new user. To use Metamorphosis will require some time reviewing to understand if it can meet your needs. Here is sample code on how to use Metamorphosis:

Public Sub Migrate()

    Dim cMigrateData As New clsMetamorphosis
    With cMigrateData
        .PromptForXmlFile = True
        .Migrate
    End With
    Set cMigrateData = Nothing
    
End Sub
'
' Writes a nicely formatted listing of the source and destination mappings.
'
Public Sub ListMappings() Dim cMigrateData As New clsMetamorphosis With cMigrateData .PromptForXmlFile = True .ListMappings End With Set cMigrateData = Nothing End Sub

The first generation defined table/field mappings in the code. This could be done because everyone used the same dataabase schema. If you are migrating users from one version to a new updated version then mapping via code statements may be the desired method. No additional files - just download a new Front-End with the Metamorphosis code. Here is how the mapping looks in the code:

    mapTable.sOrigTable = "TypicalMaterials"
    mapTable.sNewTable = "Materials"
    
    ' map fields -------------------------
nFieldsMapped = 0 With mapField .sOrigField = "LITERAL=Typical" .nOrigFieldDataType = dbText .sNewField = "Category" .nNewFieldDataType = dbText .bKeyField = False End With ReDim Preserve arrFields(nFieldsMapped) arrFields(nFieldsMapped) = mapField nFieldsMapped = nFieldsMapped + 1 With mapField .sOrigField = "MaterialCode" .nOrigFieldDataType = dbText .sNewField = "ItemID" .nNewFieldDataType = dbText .bKeyField = True End With ReDim Preserve arrFields(nFieldsMapped) arrFields(nFieldsMapped) = mapField nFieldsMapped = nFieldsMapped + 1 With mapField .sOrigField = "MaterialType" .nOrigFieldDataType = dbText .sNewField = "Description" .nNewFieldDataType = dbText .bKeyField = True End With ReDim Preserve arrFields(nFieldsMapped) arrFields(nFieldsMapped) = mapField nFieldsMapped = nFieldsMapped + 1 With mapField .sOrigField = "CostPerSqFt" .nOrigFieldDataType = dbCurrency .sNewField = "UnitPrice" .nNewFieldDataType = dbCurrency .bKeyField = False End With ReDim Preserve arrFields(nFieldsMapped) arrFields(nFieldsMapped) = mapField nFieldsMapped = nFieldsMapped + 1 ' save mappings -------------------------
mapTable.arrMap = arrFields ReDim Preserve arrTables(nTablesMapped) arrTables(nTablesMapped) = mapTable nTablesMapped = nTablesMapped + 1

Gets more difficult if there are multiple database schemas in use in the Back-End for different clients. Metamorphosis now supports the use of XML mapping files where the table and field mapping can be defined by XML. Just deliver a custom made XML file to the client which defines their unique data conversion needs. The code can prompt the user for the XML file location or you can hard-code it into the sample and away you go. Here is how it would look in XML:

<?xml version="1.0" encoding="utf-8"?>
<dataMapping>
  <tableset>
    <tables>
      <OrigTable>TypicalMaterials</OrigTable>
      <NewTable>Materials</NewTable>
    </tables>
    <fieldMap>
      <field>
        <OrigField>LITERAL=Typical</OrigField>
        <OrigFieldDataType>10</OrigFieldDataType>
        <NewField>Category</NewField>
        <NewFieldDataType>10</NewFieldDataType>
        <KeyField>False</KeyField>
      </field>
      <field>
        <OrigField>MaterialCode</OrigField>
        <OrigFieldDataType>10</OrigFieldDataType>
        <NewField>ItemID</NewField>
        <NewFieldDataType>10</NewFieldDataType>
        <KeyField>True</KeyField>
      </field>
      <field>
        <OrigField>MaterialType</OrigField>
        <OrigFieldDataType>10</OrigFieldDataType>
        <NewField>Description</NewField>
        <NewFieldDataType>10</NewFieldDataType>
        <KeyField>False</KeyField>
      </field>
      <field>
        <OrigField>CostPerSqFt</OrigField>
        <OrigFieldDataType>5</OrigFieldDataType>
        <NewField>UnitPrice</NewField>
        <NewFieldDataType>5</NewFieldDataType>
        <KeyField>False</KeyField>
      </field>
    </fieldMap>
  </tableset>
</dataMapping>

It doesn't make sense to go over all the code here. Hopefully I've shown enough for you to decide if it is worth checking out the download.

Updated 2009-02-28.


Centering a Form

Access forms can be centered by setting the form's AutoCenter property to True. But a recent project I did required me to cascade a set of windows for the user. After the user inspects and closes the windows the original form was left positioned in the upper left corner. This wasn't acceptable, that form had to be re-centered.

The form's Activate event was the appropriate event to use for re-positioning the form. I used the code below to re-center the form. Here is how it works:

First I display the hourglass icon and turn off screen updates. I then maximize the form within the Access window and save the inside dimensions - this gives me the size of the Access window.

After restoring the form to its original size I use the size of the window that the form is enclosed in to do the math necessary to center the window.

I wanted to generalize the code so that it could be used for any window and the code below does that by accepting a reference to the form. However this is a potential "gotcha" in this code that you should be aware of. The DoCmd statement in the code operates on whatever object currently has the focus. This might not be the object you expect!

Some DoCmd methods let you specify the object like the DoCmd.Close method. You can close a form with code like this:


Private Sub cmdClose_Click()
    DoCmd.Close acForm, Me.Name, acSaveNo
End Sub

This line of code is very specific about what is to be closed. But the DoCmd methods I use in this code sample (.Maximize, .Restore, .MoveSize) don't allow you to specify the object. Instead it applies to whatever object currently has the focus. If a user should click on another object (perhaps another form or a report that is open) then the focus has shifted and the command will be applied to that object.

I minimize the chances of this happening by explicitly setting the focus in the previous line of code to the object I want to operate on. Doesn't eliminate the risk but does reduce it. If you are uncomfortable with this risk you can move the code directly to the Form's Activate event but you'll have to duplicate the code for each form you intend to center.

To center a form just call the proc from the form's Activate event:


Private Sub Form_Activate()
    CenterForm Me
End Sub

Here is the code that should be put into a Module:


Option Compare Database
Option Explicit

Private m_bNotFirstUse As Boolean

'
Public Sub CenterForm(objForm As Access.Form)
    On Error GoTo errHandler
    
    If m_bNotFirstUse = False Then
        m_bNotFirstUse = True
        Exit Sub
    End If
    
    Dim nScreenWidth As Long, nScreenHeight As Long, nFormHeight As Long
    
    ' show the user the wait cursor
    
    DoCmd.Hourglass True
    Application.Echo False
    
    ' save the form's window height
    
    nFormHeight = objForm.WindowHeight
    
    ' try to ensure this object has the focus prior to running a general cmd
    objForm.SetFocus
    
    ' maximize this form to the full size of the Access window
    DoCmd.Maximize
    
    DoEvents
        
    ' get the current size of the form so we can determine the size
    ' of the Access window
        
    nScreenHeight = objForm.InsideHeight
    nScreenWidth = objForm.InsideWidth
        
    'Debug.Print "InsideHeight = " & objForm.InsideHeight & _
                "  and InsideWidth = " & objForm.InsideWidth
        
    ' try to ensure this object has the focus prior to running a general cmd
    objForm.SetFocus
    DoCmd.Restore       ' restore the form to its original height and width
    
    ' there is enough info to center the form
    
    ' try to ensure this object has the focus prior to running a general cmd
    objForm.SetFocus
    
    DoCmd.MoveSize (nScreenWidth - objForm.WindowWidth) \ 2 _
                , (nScreenHeight - objForm.WindowHeight) \ 2
    
exitHandler:

    Application.Echo True         ' allow user to see this form
    DoCmd.Hourglass False
    
    Exit Sub

errHandler:
    ' make sure we turn screen updates back on
    Resume exitHandler
    
End Sub

Just a note that I prevent the initial form from centering. I use a startup form in this project and it would not center correctly on startup. Most likely the Access window is not properly setup yet and so the window sizes are "off" resulting in my startup form being off-center. I used a basic flag (or semaphore) technique to prevent the centering code from working for the first form opened. An enhancement that could be made would be to check if a startup form is specified and use that value to alter this behavior.

Updated 2009-02-27.


Ensuring Line Numbers Have Been Added to Appropriate Code

Do you use the Erl() function as part of your logging or error message? Line numbers can make hunting down errors much easier and there are several utilities out there than can add/remove line numbers with the click of an icon (a popular one is MZ-Tools).

Here is a proc that will search your form, report and module code looking for procs where the Erl() call is used and list any of those procs that are missing line numbers.

This is one of the build steps I use prior to delivery of beta code to the client. Add this code to a module (perhaps a module that you'll ultimately delete prior to final delivery) and then call it from the Immediate Window (Ctrl-G) by typing: listProcsWithoutLineNumbers


'
' Quick way to check if I have used the Erl() function in code that doesn't have line numbers.
'
Public Sub listProcsWithoutLineNumbers()

10        On Error GoTo errHandler
    
          Dim modl As Module, frm As Form, rpt As Report
          Dim dbs As DAO.Database, curDoc As DAO.Document
          Dim nActualLineNumber As Long
          Dim strProcName As String, nProcType As Long
          Dim strCodeLineText As String
          Dim sFirstChar As String
          Dim bContinuationOfPreviousLine As Boolean
          Dim bFoundProcWithoutLineNumbers As Boolean

20        Set dbs = CurrentDb
    
30        DoCmd.Hourglass True
40        Application.Echo False
    
50        LogMessage "-----------------------------------------------------------------------"
    
60        For Each curDoc In dbs.Containers("Modules").Documents
70            DoCmd.OpenModule curDoc.Name
80            Set modl = Modules(curDoc.Name)
  
90            For nActualLineNumber = 1 To modl.CountOfLines
100               strCodeLineText = Trim(modl.Lines(nActualLineNumber, 1))

110               If Not bContinuationOfPreviousLine Then
120                   sFirstChar = Left$(strCodeLineText, 1)
130               End If

140               If InStr(1, strCodeLineText, "Erl()", vbTextCompare) > 0 Then
150                   If sFirstChar <> "'" Then
160                       If Not IsNumeric(sFirstChar) Then

170                           strProcName = modl.ProcOfLine(nActualLineNumber, nProcType)
  
180                           LogMessage modl.Name & " - " & strProcName _
                                          & "() at actual line " & nActualLineNumber
                                    
190                           bFoundProcWithoutLineNumbers = True
200                       End If
210                   End If
220               End If

230               bContinuationOfPreviousLine = (Right$(strCodeLineText, 1) = "_")
240           Next nActualLineNumber
  
250           DoCmd.Close acModule, curDoc.Name, acSaveNo
260       Next curDoc
    
270       bContinuationOfPreviousLine = False
    
280       For Each curDoc In dbs.Containers("Forms").Documents
290           DoCmd.OpenForm curDoc.Name, acDesign, , , , acHidden
300           Set frm = Forms(curDoc.Name)
    
310           For nActualLineNumber = 1 To frm.Module.CountOfLines
320               strCodeLineText = Trim(frm.Module.Lines(nActualLineNumber, 1))

330               If bContinuationOfPreviousLine = False Then
340                   sFirstChar = Left$(strCodeLineText, 1)
350               End If

360               If InStr(1, strCodeLineText, "Erl()", vbTextCompare) > 0 Then
370                   If sFirstChar <> "'" Then
380                       If Not IsNumeric(sFirstChar) Then
  
390                           strProcName = frm.Module.ProcOfLine(nActualLineNumber, nProcType)
  
400                           LogMessage frm.Name & " - " & strProcName _
                                          & "() at actual line " & nActualLineNumber
                                    
410                           bFoundProcWithoutLineNumbers = True
420                       End If
430                   End If
440               End If

450               bContinuationOfPreviousLine = (Right$(Trim(strCodeLineText), 1) = "_")
460           Next nActualLineNumber
    
470           DoCmd.Close acForm, curDoc.Name, acSaveNo
480       Next curDoc
    
490       bContinuationOfPreviousLine = False
    
500       For Each curDoc In dbs.Containers("Reports").Documents
510           DoCmd.OpenReport curDoc.Name, acDesign
520           Set rpt = Reports(curDoc.Name)
    
530           For nActualLineNumber = 1 To rpt.Module.CountOfLines
540               strCodeLineText = Trim(rpt.Module.Lines(nActualLineNumber, 1))

550               If Not bContinuationOfPreviousLine Then
560                   sFirstChar = Left$(strCodeLineText, 1)
570               End If

580               If InStr(1, strCodeLineText, "Erl()", vbTextCompare) > 0 Then
590                   If sFirstChar <> "'" Then
600                       If Not IsNumeric(sFirstChar) Then
  
610                           strProcName = rpt.Module.ProcOfLine(nActualLineNumber, nProcType)
  
620                           LogMessage rpt.Name & " - " & strProcName _
                                          & "() at actual line " & nActualLineNumber
                                    
630                           bFoundProcWithoutLineNumbers = True
640                       End If
650                   End If
660               End If

670               bContinuationOfPreviousLine = (Right$(strCodeLineText, 1) = "_")
680           Next nActualLineNumber
  
690           DoCmd.Close acReport, curDoc.Name, acSaveNo
700       Next curDoc
    
exitHandler:

710       If Not (dbs Is Nothing) Then Set dbs = Nothing
    
720       DoCmd.Hourglass False
730       Application.Echo True

740       If bFoundProcWithoutLineNumbers = False Then
750           LogMessage "Did not find any procs that were missing line numbers."
760       End If
    
770       LogMessage "------------------------------ Finished. ------------------------------"
    
780       Exit Sub
    
errHandler:
          Dim nErr As Long
    
790       nErr = Err.Number
    
          ' ignore error 17:
          '   error in <module name> at line xxx: Can't perform requested operation (17)
          ' log it and resume next
          ' this occurs while trying to close a module previously opened with
          ' DoCmd.OpenModule. Researching...
          '
          ' MS says:
          '   The requested operation can't be performed because it would invalidate the
          '   current state of the project. For example, the error occurs if you use the
          '   References dialog box (on the Tools menu, click Rererences) to add a
          '   reference to a new project or object library while a program is in break mode.
          '
800       If nErr = 17 Then
              'LogMessage "Error 17: " & curDoc.Name & ":" & strProcName _
              '           & " at line " & Erl() & ": " & Err.Description
810           Resume Next
820       Else
830           LogMessage "listProcsWithoutLineNumbers() error in " & curDoc.Name & ":" _
                          & strProcName & " at line " & Erl() _
                          & ": " & Err.Description & " (" & Err.Number & ")"
840       End If
    
850       Resume exitHandler
    
End Sub

Just to be complete I have added my log module code. You might your own preferred method but if not this might be a good starting point for your app.

The Log Module code lets me log messages by writing a line of code:

LogMessage "Write this to the log."

After setting up the log destination with a line of code in my startup procedure:

SetErrorLogging True, eMsgBox

The log module can write to the Immediate Window (eDebug), display in a MsgBox (eMsgBox), write to a text file (eFile) or to a table (eTable).


Option Compare Database
Option Explicit

'
' This is error logging code. Using this code you can easily change where log messages
' are displayed or saved with a line of code:
'
'         SetErrorLogging True, eMsgBox
'
'         SetErrorLogging True, eFile
'
' in your startup code. You can set the log file name (if the default "AppLog.txt"
' doesn't appeal to you:
'
'       SetErrorLogFileName "myAppLogName.txt"
'

Public Enum enumLogOutputType
    eDebug = 1
    eMsgBox
    eFile
    eTable
End Enum

Private m_bLogErrors As Boolean                 ' flag to indicate if errors should be logged
Private m_nLogOutputType As enumLogOutputType   ' set to log output type (e.g. MsgBox, File, Table, etc.)
Private m_sErrorLog As String                   ' log file for debug/problem support

'
Public Sub SetOutputLogType(eLogType As enumLogOutputType)
    m_nLogOutputType = eLogType
End Sub
'
Public Function GetOutputLogType() As enumLogOutputType

    ' if not defined then set to Debug.Print
    If m_nLogOutputType = 0 Then m_nLogOutputType = eDebug
    
    GetOutputLogType = m_nLogOutputType
    
End Function
'
Public Function ToggleErrorLogging()
    m_bLogErrors = Not m_bLogErrors
End Function
'
Public Sub SetErrorLogging(bLog As Boolean, Optional eLogType As enumLogOutputType = eDebug)
    m_bLogErrors = True
    m_nLogOutputType = eLogType
End Sub
'
Public Function IsErrorLogging() As Boolean
    IsErrorLogging = m_bLogErrors
End Function
'
Public Sub SetErrorLogFileName(sFilename As String)
   If Len(sFilename) > 0 Then
        m_sErrorLog = sFilename
   End If
End Sub
'
Public Function GetErrorLogFilePathName() As String
    
    If Len(m_sErrorLog) > 0 Then
        GetErrorLogFilePathName = CurrentProject.Path & "\" & m_sErrorLog
    Else
        GetErrorLogFilePathName = CurrentProject.Path & "\AppLog.txt"
    End If
    
End Function
'
'
'
Public Sub LogMessage(sMessage As String)
    
    Select Case GetOutputLogType()

        Case eDebug
            Debug.Print sMessage
            
        Case eMsgBox
            MsgBox sMessage, vbOKOnly Or vbInformation, "Log Output"

        Case eFile
'            MsgBox "File Log not implemented: " & sMessage, _
'                    vbOKOnly Or vbInformation, "Log Output"
            LogToFile sMessage

        Case eTable
'            MsgBox "Table Log not implemented: " & sMessage, _
'                    vbOKOnly Or vbInformation, "Log Output"
                    
            LogToTable sMessage

    End Select

End Sub
'
'
Private Sub LogToFile(sMessage As String)
    On Error Resume Next
    
    Dim F As Integer
    F = FreeFile
    
    Open GetErrorLogFilePathName() For Append As #F
    
    Print #F, Format(Now(), "yyyymmdd h:mm:ss - ") & sMessage
    
    Close #F
    
    Reset
    
    On Error GoTo 0

End Sub
'
'
Private Sub LogToTable(sMessage As String)
    On Error Resume Next

    ' table has timestamp field that defaults to "=Now()"
    CurrentDb.Execute "INSERT INTO SysLog (MessageText) VALUES (""" _
                        & sMessage & """);", dbFailOnError

End Sub

Updated 2009-02-18.


Popup Form Position

A forum member at UtterAccess asked if a pop-up form could be placed next to a control. My initial thought was the DoCmd.MoveSize command would be the answer but it wasn't that simple.

I wanted to provide a simple code solution without resorting to APIs. But that makes it difficult.

In the requested sample the popup form needs to appear to the left of the command button used to open it. Here is the code I used to do that:

Private Sub cmdPopUp_Click()

    DoCmd.OpenForm "frmPopUp", , , , , , Me.Name & ";" & Me.ActiveControl.Name

End Sub

This opens the popup form ("frmPopup") and passes the name of the current form and the (command button) control on it that the user clicked in the OpenArgs argument. Then in the pop form's Load event those values are retrieved using Me.OpenArgs:

Private Sub Form_Load()

    Const SMALL_GAP As Long = 100
    Const TITLE_BAR_SIZE_IN_TWIPS = 500

    Dim nPos As Long
    Dim sForm As String, sControl As String
    Dim nLeft As Long, nTop As Long
    
    If Len(Me.OpenArgs) > 0 Then

        ' get the top and left positions for the popup - first find the ; in .OpenArgs
nPos = InStr(Me.OpenArgs, ";") If nPos > 0 Then sForm = Left$(Me.OpenArgs, nPos - 1) sControl = Mid$(Me.OpenArgs, nPos + 1) ' first move the form to where the calling form is located
Me.Move Forms(sForm).WindowLeft, Forms(sForm).WindowTop ' and now move it to the control provided
nLeft = Me.WindowLeft + Forms(sForm).Controls(sControl).Left _ + Forms(sForm).Controls(sControl).Width + SMALL_GAP nTop = Me.WindowTop + Forms(sForm).Controls(sControl).Top _ + TITLE_BAR_SIZE_IN_TWIPS Me.Move nLeft, nTop End If End If End Sub

I also have an Access 2007 sample you can download.

Updated 2009-02-04.


Measuring Performance

A common request is the ability to measure performance perhaps as part of a profiling effort to increase performance of a query or some code.

I use the code posted below in a module to get the start and end times and wrap my test code in between like this:


    DoCmd.Hourglass True
    Init_ExactTimer

    ' call my function or query
Call DetermineNumberOfPins 'CurrentDb.Execute qryMyComplexQuery
DoCmd.Hourglass False MsgBox "Elapsed time: " & ExactTimer_Value, vbOkOnly Or vbInformation, "Results"

The timing code and some resources:


Option Compare Database
Option Explicit

' See http://support.microsoft.com/kb/q172338/ for more information 
' on QueryPerformanceFrequency and QueryPerformanceCounter.
' also see this for potential inaccurate results:
' Performance counter value may unexpectedly leap forward
' http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q274323&
' Cannot Run Certain Programs on Hyper-Threaded or Dual-Processor Computers
' with a CPU Speed of Greater Than 2 GHz
' http://support.microsoft.com/kb/327809/
'
' http://www-128.ibm.com/developerworks/library/i-seconds/
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (ByRef Frequency As Currency) As Long Private Declare Function QueryPerformanceCounter Lib "kernel32" (ByRef TimerValue As Currency) As Long 'Private Const i_Frequency As Currency = 100
Private i_Frequency As Currency ' store an approximation of the API time (performance) overhead:
Private m_curOverhead As Currency ' currency is a very accurate data type for precision timing
Private m_curStart As Currency '
' to time how long it takes for a set of instructions to be processed you would insert a call to this
' function ("Init_ExactTimer()") at the start of your code block.
' Then use the corresponding "ExactTimer_Value()"
' function (below) placed at the end of the code block to examine.
'
Public Sub Init_ExactTimer() Dim Ctr1 As Currency, Ctr2 As Currency QueryPerformanceFrequency i_Frequency Debug.Print "Count change in 1 second: " & i_Frequency Debug.Print "QueryPerformanceCounter minimum resolution: 1/" & i_Frequency * 10000; _ " sec (" & CStr(1 / (i_Frequency * 10000)) & ")" QueryPerformanceCounter Ctr1 QueryPerformanceCounter Ctr2 m_curOverhead = Ctr2 - Ctr1 ' determine API overhead
QueryPerformanceCounter m_curStart ' set a start point
End Sub '
' This proc returns the number of seconds between this call and the "Init_ExactTimer()" call.
'
Public Function ExactTimer_Value() As Currency QueryPerformanceCounter ExactTimer_Value ExactTimer_Value = ((ExactTimer_Value - m_curStart) - m_curOverhead) / i_Frequency End Function

Updated 2009-02-12.