Can I get the name of a procedure from within the procedure? In my error
handler, I write the error to an error table. I'd like to write the name of
the procedure that's writing the error. But, rather than customizing each
error handler with the procedure name, it would be nice to be able to call a
system variable or function that gives me the procedure name and module
name. Is that possible?
Hi, there is this module I use - originaly from Access97 Developers
handbook. I have modified it a bit but it still works and I use it in
all my XP apps today.
bobh.
Option Compare Database
Option Explicit
' From Access 97 Developer's Handbook by Litwin, Getz, and Gilbert.
(Sybex)
' Copyright 1997. All Rights Reserved.
Private Declare Function adh_apiIsClipboardFormatAvailable Lib
"user32" Alias "IsClipboardFormatAvailable" (ByVal uFormat As Integer)
As Integer
Private Declare Function adh_apiOpenClipboard Lib "user32" Alias
"OpenClipboard" (ByVal hWnd As Long) As Integer
Private Declare Function adh_apiGetClipboardData Lib "user32" Alias
"GetClipboardData" (ByVal uFormat As Integer) As Long
Private Declare Function adh_apiGlobalSize Lib "kernel32" Alias
"GlobalSize" (ByVal hMem As Long) As Integer
Private Declare Function adh_apiGlobalLock Lib "kernel32" Alias
"GlobalLock" (ByVal hMem As Long) As Long
Private Declare Sub adh_apiMoveMemory Lib "kernel32" Alias
"RtlMoveMemory" (ByVal strDest As Any, ByVal lpSource As Any, ByVal
Length As Long)
Private Declare Function adh_apiGlobalUnlock Lib "kernel32" Alias
"GlobalUnlock" (ByVal hMem As Long) As Integer
Private Declare Function adh_apiCloseClipboard Lib "user32" Alias
"CloseClipboard" () As Integer
Private Declare Function adh_apiGlobalAlloc Lib "kernel32" Alias
"GlobalAlloc" (ByVal uFlags As Integer, ByVal dwBytes As Long) As Long
Private Declare Function adh_apiEmptyClipboard Lib "user32" Alias
"EmptyClipboard" () As Integer
Private Declare Function adh_apiSetClipboardData Lib "user32" Alias
"SetClipboardData" (ByVal uFormat As Integer, ByVal hData As Long) As
Long
Private Declare Function adh_apiGlobalFree Lib "kernel32" Alias
"GlobalFree" (ByVal hMem As Long) As Long
Private Const GMEM_MOVABLE = &H2&
Private Const GMEM_DDESHARE = &H2000&
Private Const CF_TEXT = 1
'Error return codes from Clipboard2Text
Public Const adhCLIPBOARDFORMATNOTAVAILABLE = 1
Public Const adhCANNOTOPENCLIPBOARD = 2
Public Const adhCANNOTGETCLIPBOARDDATA = 3
Public Const adhCANNOTGLOBALLOCK = 4
Public Const adhCANNOTCLOSECLIPBOARD = 5
Public Const adhCANNOTGLOBALALLOC = 6
Public Const adhCANNOTEMPTYCLIPBOARD = 7
Public Const adhCANNOTSETCLIPBOARDDATA = 8
Public Const adhCANNOTGLOBALFREE = 9
Public Sub ErrorHandler()
'This routine will automatically add error handling to the routine
selected if executed.
'To get it to work properly (as currently set up) have the name of the
routine selected
'when you right-mouse click and run this from the shortcut menu.
'
'This routine has been modified by Ron Allard and Bob Hynes to improve
the error message display.
'
'Adding a command to the toolbar shortcut popup menu while in vba page
design.
'Click on the View menu bar and choose Toolbars>Customize. In the
Toolbars tab of
'Customize dialog, display the Shortcut Menus by checking the box next
to it (it's the last in the list).
'After you see the "Shortcut Menus" displayed, move to the Commands
tab in the Customize dialog.
'In the File category, click on "Custom" and drag it over the
"Shortcut Menus" bar.
'Hover over the Module menu and when it drops down, go into "Module
Uncompiled"
'Now you can drop the Custom item wherever you want it to be located.
'Right click the Custom item you just dropped and name it (right click
to pull up its properties).
'Then click on the "properties" option at the bottom of the dialog
box. On the next dialog all you need
'to do is type in the "On Action" data. The name of the function you
want it to run " =ErrorHandler() "
'
Dim strRoutineName As String, strRoutineType As String
Dim str3Letters As String, strTitle As String, str As String
SendKeys "(^c)" ' capture name of
routine
DoEvents ' allow clipboard
to note the new text
'MsgBox Clipboard.GetText()
strRoutineName = ClipboardGetText("")
SendKeys "(^{LEFT})(^{LEFT})"
SendKeys "+{RIGHT}+{RIGHT}+{RIGHT}"
SendKeys "(^c)" ' capture 3
letters of word
DoEvents ' allow
clipboard to note the new text
str3Letters = ClipboardGetText("")
Select Case str3Letters
Case "Sub"
strRoutineType = "Sub"
Case "Fun"
strRoutineType = "Function"
Case "Get", "Let", "Set"
strRoutineType = "Property"
Case Else
strRoutineType = "What is this?"
End Select
strTitle = strRoutineType & " - " & strRoutineName & " in "
str = "{END}~" & "On Error GoTo Err_" & strRoutineName _
& "~Exit_" & strRoutineName & ":~{TAB} Exit " & strRoutineType
_
& "~Err_" & strRoutineName & ":~MsgBox Err.Number " & "& "" -
"" &" & " Err.Description" & ",," & """" & strTitle & """" & " & " &
"Me.Name" _
& "~Resume Exit_" & strRoutineName & "~"
SendKeys str
str = "{RIGHT}+{DOWN}(^x){up 4}(^v){UP 3}(^v){UP}~{TAB}"
SendKeys str
End Sub
Public Function ClipboardGetText(ByVal strFailureString As String) As
String
' Purpose: Gets some text from the Windows clipboard
' Params:
' strFailureString: the string to return if the function fails to
get a string from the Clipboard
' Returns: either the string in the Clipboard or the default failure
string (strFailureString)
' Note: This routine calls the Access 97 Developer Handbook routine
adhClipboardGetText().
' adhClipboardGetText returns a variant, and what is needed is a
string. This routine ensures
' the return of a string.
On Error Resume Next
Dim varReturnValue As Variant
varReturnValue = adhClipboardGetText()
ClipboardGetText = CStr(varReturnValue)
If err.Number <> 0 Then ClipboardGetText = strFailureString
End Function
Function adhClipboardSetText(strText As String) As Variant
' Puts some text on the Windows clipboard
' From Access 97 Developer's Handbook by Litwin, Getz, and Gilbert.
(Sybex)
' Copyright 1997. All Rights Reserved.
' In:
' The text to place on the clipboard
' Out:
' If IsError returns true, then the value
' is an error number. If IsError is false
' the value is meaningless.
Dim varRet As Variant
Dim fSetClipboardData As Boolean
Dim hMemory As Long
Dim lpMemory As Long
Dim lngSize As Long
varRet = False
fSetClipboardData = False
' Get the length, including one extra for a CHR$(0) at the end.
lngSize = Len(strText) + 1
hMemory = adh_apiGlobalAlloc(GMEM_MOVABLE, lngSize)
If Not CBool(hMemory) Then
varRet = CVErr(adhCANNOTGLOBALALLOC)
GoTo adhClipboardSetTextDone
End If
' Lock the object into memory
lpMemory = adh_apiGlobalLock(hMemory)
If Not CBool(lpMemory) Then
varRet = CVErr(adhCANNOTGLOBALLOCK)
GoTo adhClipboardSetTextGlobalFree
End If
' Move the string into the memory we locked
Call adh_apiMoveMemory(lpMemory, strText, lngSize)
' Don't send clipboard locked memory.
Call adh_apiGlobalUnlock(hMemory)
' Open the clipboard
If Not CBool(adh_apiOpenClipboard(0&)) Then
varRet = CVErr(adhCANNOTOPENCLIPBOARD)
GoTo adhClipboardSetTextGlobalFree
End If
' Remove the current contents of the clipboard
If Not CBool(adh_apiEmptyClipboard()) Then
varRet = CVErr(adhCANNOTEMPTYCLIPBOARD)
GoTo adhClipboardSetTextCloseClipboard
End If
' Add our string to the clipboard as text
If Not CBool(adh_apiSetClipboardData(CF_TEXT, hMemory)) Then
varRet = CVErr(adhCANNOTSETCLIPBOARDDATA)
GoTo adhClipboardSetTextCloseClipboard
Else
fSetClipboardData = True
End If
adhClipboardSetTextCloseClipboard:
' Close the clipboard
If Not CBool(adh_apiCloseClipboard()) Then
varRet = CVErr(adhCANNOTCLOSECLIPBOARD)
End If
adhClipboardSetTextGlobalFree:
If Not fSetClipboardData Then
'If we have set the clipboard data, we no longer own
' the object--Windows does, so don't free it.
If CBool(adh_apiGlobalFree(hMemory)) Then
varRet = CVErr(adhCANNOTGLOBALFREE)
End If
End If
adhClipboardSetTextDone:
adhClipboardSetText = varRet
End Function
Public Sub adhTestClipboard()
' Tests putting some text on the clipboard then reading it off again
' From Access 97 Developer's Handbook by Litwin, Getz, and Gilbert.
(Sybex)
' Copyright 1997. All Rights Reserved.
' Example:
' Call adhTestClipboard
Dim varRet As Variant
varRet = adhClipboardSetText("This is a test")
If IsError(varRet) Then
Call adhReportClipboardError(CInt(varRet))
Else
varRet = adhClipboardGetText()
If IsError(varRet) Then
Call adhReportClipboardError(CInt(varRet))
Else
MsgBox varRet
End If
End If
End Sub
Public Sub adhReportClipboardError(ByVal intError As Integer)
' Reports an error received from the clipboard
' From Access 97 Developer's Handbook by Litwin, Getz, and Gilbert.
(Sybex)
' Copyright 1997. All Rights Reserved.
' Example:
' Call adhReportClipboardError(CInt(varRet))
Select Case CInt(intError)
Case adhCLIPBOARDFORMATNOTAVAILABLE
MsgBox "Clipboard format not available"
Case adhCANNOTOPENCLIPBOARD
MsgBox "Cannot open clipboard"
Case adhCANNOTGETCLIPBOARDDATA
MsgBox "Cannot get clipboard data"
Case adhCANNOTGLOBALLOCK
MsgBox "Cannot global lock data"
Case adhCANNOTCLOSECLIPBOARD
MsgBox "Cannot close clipboard"
Case adhCANNOTGLOBALALLOC
MsgBox "Cannot global alloc"
Case adhCANNOTEMPTYCLIPBOARD
MsgBox "Cannot empty clipboard"
Case adhCANNOTSETCLIPBOARDDATA
MsgBox "Cannot set clipboard data"
Case adhCANNOTGLOBALFREE
MsgBox "Cannot global free"
Case Else
MsgBox "From module function - adhReportClipboardError",
vbExclamation, "I'm stuck!"
End Select
End Sub
Public Function adhClipboardGetText() As Variant
' Gets some text on the Windows clipboard
' From Access 97 Developer's Handbook by Litwin, Getz, and Gilbert.
(Sybex)
' Copyright 1997. All Rights Reserved.
' Out:
' The text on the clipboard.
' If IsError returns true, then the value
' is an error number
Dim hMemory As Long
Dim lpMemory As Long
Dim strText As String
Dim lngSize As Long
Dim varRet As Variant
varRet = ""
' Is there text on the clipboard? If not, error out.
If Not CBool(adh_apiIsClipboardFormatAvailable(CF_TEXT)) Then
varRet = CVErr(adhCLIPBOARDFORMATNOTAVAILABLE)
GoTo adhClipboardGetTextDone
End If
' Open the clipboard
If Not CBool(adh_apiOpenClipboard(0&)) Then
varRet = CVErr(adhCANNOTOPENCLIPBOARD)
GoTo adhClipboardGetTextDone
End If
' Get the handle to the clipboard data
hMemory = adh_apiGetClipboardData(CF_TEXT)
If Not CBool(hMemory) Then
varRet = CVErr(adhCANNOTGETCLIPBOARDDATA)
GoTo adhClipboardGetTextCloseClipboard
End If
' Find out how big it is and allocate enough space
' in a string
lngSize = adh_apiGlobalSize(hMemory)
strText = Space$(lngSize)
' Lock the handle so we can use it
lpMemory = adh_apiGlobalLock(hMemory)
If Not CBool(lpMemory) Then
varRet = CVErr(adhCANNOTGLOBALLOCK)
GoTo adhClipboardGetTextCloseClipboard
End If
' Move the information from the clipboard memory
' into our string
Call adh_apiMoveMemory(strText, lpMemory, lngSize)
' Truncate it at the first Null character because
' the value reported by lngSize is erroneously large
strText = left$(strText, InStr(1, strText, Chr$(0)) - 1)
' Free the lock
Call adh_apiGlobalUnlock(hMemory)
adhClipboardGetTextCloseClipboard:
' Close the clipboard
If Not CBool(adh_apiCloseClipboard()) Then
varRet = CVErr(adhCANNOTCLOSECLIPBOARD)
End If
adhClipboardGetTextDone:
If Not IsError(varRet) Then
adhClipboardGetText = strText
Else
adhClipboardGetText = varRet
End If
End Function
.