Home | About Us | Feature | Programs | Support | Training | Development | Downloads | Free Tools | Newsletter | Links | Contact

Microsoft Access 97 to 2003 Programming Tips and Code Snippets

The tips that follow are hard-won knowledge that we didn't want to lose, that may also be useful to other Microsoft Access Programmers.  If you like them please feel free to send us your tips in exchange.
There's a series of more elementary tips in our free monthly newsletter: Click to Subscribe.
In most browsers, you can press Ctrl+F, or Edit > Find, to search this page for keywords.
To go to the main page for tips and free stuff, and to search this site, click here.

Contents:

Please Read this Disclaimer!
Our Programming Style
Start out Right!
Read an ASCII File and display in Immediate Window
Read a Binary File and display in Immediate Window
Proper Case Function
Function to Return Period as a Formatted String
Return a Binary String representing a Decimal Number
Get Name of Current User
Function to Parse (Break Up) a String at separators
Put Data on the Clipboard from Access
Send an e-mail from Access
Sub GetGlobals: Get Program Name, User Name, Group Membership
Get Name of Current Access Database
Get Path of Current Access Database, or any file
Get Name of Back-end Database
Comment or Clear Status Bar
Contributed Tips


Disclaimer:

All tips, information, programs and code are supplied "as is" and without warranty of any kind. Under no circumstances will Communication in Action (Pty) Ltd trading as Software Africa or any of its staff accept liability resulting from the use of, or the inability to use, these programs.  If you find bugs, please tell us.

Our Programming Style

We use two-character indention.  If you don't like this, ask for our free indention program to fix it.

Where a type suffix exists, we use it for variable names instead of Polish notation.  The big advantage of this is that you know for sure that a variable named (say) File$ is a string, whereas strFile could be any type, depending on how disciplined the programmer was.  The type-declaration suffixes we use are:

Suffix

Variable Type

Examples

%

Integer index (type integer or long)

I%, Cnt%

&

Long Integer

L&

!

Single (Real Number)

MyPay!

#

Double (Real Number)

Precise#

@

Currency

Cost@

$

String

Name1$

Where there isn't a type-declaration suffix, we use the usual Polish prefixes.

Sorry if our conventions offend strict Polish notation devotees!  We are considering a Software-Africa-to-Polish-conventions translator: Let us know if you are interested!

View Software Africa's Visual Basic Programming Standards.

In what follows, we assume that your are conversant with the Visual Basic language, and focus on your VB code.


Here are our code examples:

Start out Right!

Always start each module with the following statements (the first will be inserted automatically for you if you set Tools > Options > Editor – Require Variable Declaration ON.

Option Explicit
Option Compare Text  ' The default is Compare Database - not as clear!
Option Base 1        ' (Unless you need Option Base 0)

Read an ASCII File and display in Immediate Window

Public Sub ReadASCIIfile()    ' Read ASCII File.              New:  ' RIR 051011
  ' Free code from Software Africa: www.softwareafrica.co.za
  Dim File$, Line$
  File$ = "C:\Test2.CSV"
  Open File$ For Input As #1
  While Not EOF(1)
    Line Input #1, Line$
    Debug.Print Line$
  Wend
  Close
End Sub

Read a Binary File and display in Immediate Window

Public Sub ReadBINfile()      ' Read Binary File.             New:  ' RIR 051011
  ' Free code from Software Africa: www.softwareafrica.co.za
  Dim File$, Line$
  File$ = "C:\Test1.CSV"
  Open File$ For Binary As #1
  Line$ = Input(100, #1)
  Debug.Print Line$
  Close
End Sub

Proper Case Function

Public Function Proper1$(Strg$) ' Proper Case (with Specials) ' RIR 011016
  ' Free code from Software Africa: www.softwareafrica.co.za
  Dim UCas%, I%, StrOut$, St$
  UCas% = 1
  StrOut$ = ""
  For I% = 1 To Len(Strg$)
    St$ = LCase$(Mid$(Strg$, I%, 1))
    StrOut$ = StrOut$ & IIf(UCas%, UCase$(St$), St$)
    UCas% = 0
    If St$ < "a" And St$ <> "'" Then UCas% = 1
  Next I%
  Proper1$ = StrOut$
End Function

Function to Return Period as a Formatted String


Function Period$(d1 As Date, d2 As Date) ' RIR 011016
  ' Free code from Software Africa: www.softwareafrica.co.za
  Period$ = Format$(d2, "mmmm yyyy")
  If Period$ <> Format$(d1, "mmmm yyyy") Then
    If Year(d1) = Year(d2) Then
      Period$ = Format$(d1, "mmmm") & " to " & Period$
    Else
      Period$ = Format$(d1, "mmmm yyyy") & " to " & Period$
    End If
  End If
End Function

Return a Binary String representing a Decimal Number


  Function Binary$(ByVal Deci&) ' Return Binary String representing
    ' Free code from Software Africa: www.softwareafrica.co.za
    Decimal Number ' RIR 020313
    Dim B$
    While Deci& > 0
      If Deci& Mod 2 Then
        B$ = "1" & B$
      Else
        B$ = "0" & B$
      End If
      Deci& = Deci& \ 2
    Wend
    If Len(B$) < 8 Then B$ = Right$("00000000" & B$, 8)
    Binary$ = Left$(B$, 4) & " " & Mid$(B$, 5)
  End Function

Get Name of Current User

Sub User()
  MsgBox "Current user is " & Application.UserName
End Sub

Function to Parse (Break Up) a String at separators

Public Function Parse$(Line1$, Ch$)   ' PARSE LINE AT Ch$.  New Fn: ' RIR 020828
  ' Returns:  Parse$  = String before first Ch$ (NOT Trimmed).
  '           Line1$  = Remainder of Line1$ after first Ch$ (NOT Trimmed).
  '           If Ch$ not found, Parse$=old Line1$, Line1$=""
  ' Free code from Software Africa: www.softwareafrica.co.za
  Dim I&, Temp$
  ' Search Line1$ + Ch$ on end to make sure it will be found:
  I& = InStr(Line1$ & Ch$, Ch$)
  Parse$ = Left$(Line1$, I& - 1)
  Line1$ = Mid$(Line1$, I& + Len(Ch$))
End Function

Put Data on the Clipboard from Access

Why Microsoft did not build clipboard control directly into Access VB, as they did with stand-alone VB 6.0, is a mystery.  Anyway, here is a way around the problem of copying to the Clipboard: This is for Access 2000 and later (there is an Access 97 version on the Microsoft Knowledge Base too).

' From Article ID : 210216 in Microsoft Knowledge Base:
' ACC2000: How to Send Information to the Clipboard
' Last Review: June 23, 2005 - Revision : 3.0

' To use in code or in Immediate Window:
' ClipBoard_SetData("This string will go to the Clipboard!")

'=================================================================
' General Declarations
'=================================================================

Option Explicit
Option Compare Text ' case-insensitive string comparisons

Declare Function GlobalUnlock Lib "kernel32" _
  (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" _
  (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" _
  (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" _
  (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" _
  (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" _
  (ByVal wFormat As Long, ByVal hMem As Long) As Long

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

Function ClipBoard_SetData(MyString As String)
  Dim hGlobalMemory As Long, lpGlobalMemory As Long
  Dim hClipMemory As Long, X As Long
  
  ' Allocate moveable global memory.
  hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
  
  ' Lock the block to get a far pointer to this memory.
  lpGlobalMemory = GlobalLock(hGlobalMemory)
  
  ' Copy the string to this global memory.
  lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
  
  ' Unlock the memory.
  If GlobalUnlock(hGlobalMemory) <> 0 Then
     MsgBox "Could not unlock memory location. Copy aborted."
     GoTo OutOfHere2
  End If
  
  ' Open the Clipboard to copy data to.
  If OpenClipboard(0&) = 0 Then
    MsgBox "Could not open the Clipboard. Copy aborted."
    Exit Function
  End If
  
  ' Clear the Clipboard.
  X = EmptyClipboard()
  
  ' Copy the data to the Clipboard.
  hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
  
OutOfHere2:
  If CloseClipboard() = 0 Then
    MsgBox "Could not close Clipboard."
  End If
  
End Function

Send an e-mail from Access

To enable Access to create e-mails, copy this code and paste it into a new module in Access.  Then call SendMailTo with appropriate parameters.  If it returns anything other than a blank string, it's an error message.  Recent versions of Outlook will insist that you confirm running the code.

Option Compare Text
Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Declare Function FindWindowA Lib "User32" (ByVal sClass As String, _
  ByVal xTitle As Long) As Long

Public Declare Function GetUserDefaultLCID Lib "kernel32" () As Long

Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long

Function SendMailTo$(ToWhom$, CC$, BCC$, Subject$, Body$, Path$, Files$)
  ' Create e-mail Header using ShellExecute(mailto):
  '  NO attachments or immed. send!
  ' Multiple addresses must be separated by semicolons (;).
  Dim Mail$, L&, hwnd&
  Const SW_SHOWNORMAL& = 1
  
  If ToWhom$ = "" Then ToWhom$ = BCC$ Else CC$ = IIf(CC$ > "", _
    CC$ & ";", "") & BCC$
  Mail$ = "mailto:" & ToWhom$
  If CC$ > "" Then Mail$ = Mail$ & "&cc=" & CC$       ' Carbon copy
  If BCC$ > "" Then Mail$ = Mail$ & "&bcc=" & BCC$    ' Blind carbon copy
  Mail$ = Mail$ & "?Subject=" & Subject$
  Mail$ = Mail$ & "&Body=" & Replace$(Body$, vbCr, "%0A")   
' Line Feeds - Use %0A (vbCr) rather than %0D (vbLf)
  Mail$ = Replace(Mail$, " ", "%20")    ' %20 for a space (not needed?)
  hwnd& = 0 ' A zero hwnd refers to the operating system itself 
            ' FindWindowA("MSACCESSMAIN", 0)
  
  L& = ShellExecute(hwnd&, "open", Mail$, ByVal 0&, "C:\", SW_SHOWNORMAL)
  If L& <= 32 Then
    SendMailTo$ = ShellExecute_Error$(L&)
  Else
    SendMailTo$ = L&
  End If
End Function

Function ShellExecute_Error$(r&)  ' Show Shell Execute error.
  Dim Msg$
  Select Case r
  Case 2&   ' SE_ERR_FNF
    Msg = "File not found"
  Case 3&   ' SE_ERR_PNF
    Msg = "Path not found"
  Case 5&   ' SE_ERR_ACCESSDENIED
    Msg = "Access denied"
  Case 8&   ' SE_ERR_OOM
    Msg = "Out of memory"
  Case 32&   ' SE_ERR_DLLNOTFOUND
    Msg = "DLL not found"
  Case 26&   ' SE_ERR_SHARE
    Msg = "A sharing violation occurred"
  Case 27&   ' SE_ERR_ASSOCINCOMPLETE
    Msg = "Incomplete or invalid file association"
  Case 28&   ' SE_ERR_DDETIMEOUT
    Msg = "DDE Time out"
  Case 29&   ' SE_ERR_DDEFAIL
    Msg = "DDE transaction failed"
  Case 30&   ' SE_ERR_DDEBUSY
    Msg = "DDE busy"
  Case 31&   ' SE_ERR_NOASSOC
    Msg = "No association for file extension"
  Case 11&   ' ERROR_BAD_FORMAT
    Msg = "Invalid EXE file or error in EXE image"
  Case Else
    Msg = "Unknown error " & r
  End Select
  ShellExecute_Error$ = Msg
End Function

Sub GetGlobals: Get Program Name, User Name, Group Membership

Note that this Sub uses function MyName$ below.

Option Compare Text
Option Explicit

Global gUser$                     ' User Logon Name
Global gGroups$                   ' User is member of these groups
Global gAppName$                  ' Prog Name for Get/SaveSettings

Sub GetGlobals()                  ' Set Global Variables:
  Dim Gr%, Msg$
  On Error GoTo Err_

  ' Get Program Short Name for Get/SaveSettings
  gAppName$ = MyName$

  ' Get User Logon Name:
  gUser$ = DBEngine.Workspaces(0).UserName

  ' Get User Group memberships:
  gGroups$ = ""
  For Gr% = 0 To DBEngine.Workspaces(0).Users(gUser$).Groups.Count - 1
    gGroups$ = gGroups$ & ", " & _
      DBEngine.Workspaces(0).Users(gUser$).Groups(Gr%).Name
  Next Gr%
  gGroups$ = Mid$(gGroups$, 3)

Exit_:
  Exit Sub

Err_:
  MsgBox Error, vbExclamation, "Error in Sub GetGlobals"
  Resume Exit_
  Resume
End Sub

Get Name of Current Access Database

With or without extension, as you prefer.

Function MyName$()      ' RETURN THIS FILE'S NAME WITHOUT EXTENSION
  Dim MyNam1$, I%
  MyNam1 = NameOf$(CurrentDb.Name)    ' Strip Path
  I% = InStr(MyNam1, ".")             ' Strip Extension:
  If I% Then MyNam1 = Left$(MyNam1, I% - 1)
  MyName$ = MyNam1
End Function

Function MyNameExt$()   ' RETURN THIS FILE'S NAME WITH EXTENSION
  MyNameExt$ = NameOf$(CurrentDb.Name)    ' Strip Path only, keep file Ext.
End Function
Function NameOf$(MyNam1$)             '  GET NAME FROM PATH\FILENAME: All
  Dim MyPath$, I%
  MyPath = MyNam1
  I% = Len(MyPath) - 1                '  Ignore trailing "\"
  While I% > 1 And Mid$(MyPath, I%, 1) <> "\"  ' Find last "\" before end.
    I% = I% - 1
  Wend
  NameOf = MyNam1                     '  If No "\", return whole name.
  If I% > 1 Then NameOf = Mid$(MyPath, I% + 1)
End Function

Get Path of Current Access Database, or any file

Depending on whether you want the trailing backslash or not, use PathOf or PathOf1.

Function MyPath$()                    '  GET PATH OF OPEN DATABASE:
  MyPath = PathOf(CurrentDb.Name)
End Function

Function PathOf$(MyName$)             '  GET PATH FROM PATH\FILENAME: All
  Dim MyPath$, I%
  MyPath = MyName$
  '  Ignore trailing "\" (for finding parent of directory)
  I% = Len(MyPath) - 1                
  While I% > 1 And Mid$(MyPath, I%, 1) <> "\"  ' Find last "\" before end.
    I% = I% - 1
  Wend
  PathOf = ""                         '  If No "\", return blank.
  If I% > 1 Then PathOf = Left$(MyPath, I%)
End Function

Public Function PathOf1$(MyName$)     
  ' PATH FROM PATH\FILENAME - No trailing "\"
  Dim I%
  ' Ignore trailing "\" (for finding parent of directory)
  I% = Len(MyName) - 1                
  While I% > 1 And Mid$(MyName, I%, 1) <> "\"  ' Find last "\" before end.
    I% = I% - 1
  Wend
  PathOf1 = Left$(MyName, I% - 1)     ' If No "\", return blank.
End Function

Get Name of Back-end Database

If you have a split database (separated front end and back end), this function will allow you to find the name of the back end. Note that this function uses the two functions StatusBarSet and StatusBarClear in the following section.

Public Function BackEndFullName$() ' Find Path & Name of Back end.
  ' Assumption: All Linked Tables use the same back-end!
  Dim dB As Database
  Dim Cnt%, tdConnect$, Find$

  Call StatusBarSet("Finding BackEnd Name")
  Set dB = CurrentDb
  BackEndFullName$ = ""
  Find$ = ";DATABASE="

  ' Loop through all tables in the database until a linked one is found:
  For Cnt% = 0 To dB.TableDefs.Count - 1
    tdConnect$ = dB.TableDefs(Cnt%).Connect

    ' If the table has a connect string, it's a linked table.
    If Len(tdConnect$) Then
      BackEndFullName$ = Mid$(tdConnect$, _
        InStr(tdConnect$, Find$) + Len(Find$))
      Exit For
    End If
  Next Cnt%

  ' Allow for Database not yet Split:
  If BackEndFullName$ = "" Then BackEndFullName$ = dB.Name

  Set dB = Nothing
  Call StatusBarClear
End Function

Comment or Clear Status Bar Message

The status bar is at the bottom of the Access window.  It is useful for messages while you are running a lengthy operation.  Clear it at the end.  Here is how you write to it (or clear it once you have written to it). This version sets (or clears) the hourglass mouse pointer at the same time.

Sub StatusBarClear()      ' Clear Status Bar
  Call SysCmd(acSysCmdClearStatus)
  Screen.MousePointer = 0     ' No Hourglass
End Sub

Sub StatusBarSet(Strg$)  ' Set Strg$ on Status Bar (StatusBarClear clears)
  Call SysCmd(acSysCmdSetStatus, Strg$)
  Screen.MousePointer = 11    ' Hourglass
End Sub


Contributed Tips

Would you like to add a tip of your own (due acknowledgement will be given!) – click here to send tip.

See alsoExcel Programming Primer, Excel Spreadsheet Tips, Microsoft Word Tips, Microsoft Access Tips, Maximizer Tips, Tips on Windows and other Windows Programs, Free Software for Programmers.

 

Press Ctrl+F to search this page for keywords.


| Back to top | ©2000-2013 Communication in Action cc t/a Software Africa. All rights reserved.  Updated 19 June 2013 e-mail Webmaster.