Microsoft Access 97 to 2003 Programming Tips and Code Snippets

' 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

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

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

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

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

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

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