2013-10-12 10:56:41 +02:00
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
2013-10-27 15:05:18 +01:00
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Trace" script:language="StarBasic">REM =======================================================================================================================
REM === The Access2Base library is a part of the LibreOffice project. ===
REM === Full documentation is available on http://www.access2base.com ===
REM =======================================================================================================================
Option Explicit
2013-10-12 10:56:41 +02:00
Public Const cstLogMaxEntries = 20
REM Typical Usage
REM TraceLog("INFO", "The OK button was pressed")
REM
REM Typical Usage for error logging
REM Sub MySub()
REM On Local Error GoTo Error_Sub
REM ...
REM Exit_Sub:
REM Exit Sub
REM Error_Sub:
REM TraceError("ERROR", Err, "MySub", Erl)
REM GoTo Exit_Sub
REM End Sub
REM
REM To display the current logged traces and/or to set parameters
REM TraceConsole()
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceConsole()
' Display the Trace dialog with current trace log values and parameter choices
If _ErrorHandler() Then On Local Error Goto Error_Sub
Dim sLineBreak As String, oDialogLib As Object, oTraceDialog As Object
sLineBreak = Chr(10)
Set oDialogLib = DialogLibraries
If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base")
Set oTraceDialog = CreateUnoDialog(DialogLibraries.Access2Base.dlgTrace)
oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE") ' HelpText ???
Dim oEntries As Object, oTraceLog As Object, oClear As Object, oMinLevel As Object, oNbEntries As Object, oDump As Object
Dim oControl As Object
Dim i As Integer, sText As String, iOKCancel As Integer
Set oNbEntries = oTraceDialog.Model.getByName("numNbEntries")
oNbEntries.Value = _A2B_.TraceLogCount
oNbEntries.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP")
Set oControl = oTraceDialog.Model.getByName("lblNbEntries")
oControl.Label = _GetLabel("DLGTRACE_LBLNBENTRIES_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP")
Set oEntries = oTraceDialog.Model.getByName("numEntries")
If _A2B_.TraceLogMaxEntries = 0 Then _A2B_.TraceLogMaxEntries = cstLogMaxEntries
oEntries.Value = _A2B_.TraceLogMaxEntries
oEntries.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP")
Set oControl = oTraceDialog.Model.getByName("lblEntries")
oControl.Label = _GetLabel("DLGTRACE_LBLENTRIES_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP")
Set oDump = oTraceDialog.Model.getByName("cmdDump")
oDump.Enabled = 0
oDump.Label = _GetLabel("DLGTRACE_CMDDUMP_LABEL")
oDump.HelpText = _GetLabel("DLGTRACE_CMDDUMP_HELP")
Set oTraceLog = oTraceDialog.Model.getByName("txtTraceLog")
oTraceLog.HelpText = _GetLabel("DLGTRACE_TXTTRACELOG_HELP")
If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized
oTraceLog.HardLineBreaks = True
sText = ""
If _A2B_.TraceLogCount > 0 Then
If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast
Do
If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0
If Len(_A2B_.TraceLogs(i)) > 11 Then
sText = sText & Right(_A2B_.TraceLogs(i), Len(_A2B_.TraceLogs(i)) - 11) & sLineBreak ' Skip date in display
End If
Loop While i <> _A2B_.TraceLogLast
oDump.Enabled = 1 ' Enable DumpToFile only if there is something to dump
End If
If Len(sText) > 0 Then sText = Left(sText, Len(sText) - 1) ' Skip last linefeed
oTraceLog.Text = sText
Else
oTraceLog.Text = _GetLabel("DLGTRACE_TXTTRACELOG_TEXT")
End If
Set oClear = oTraceDialog.Model.getByName("chkClear")
oClear.State = 0 ' Unchecked
oClear.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP")
Set oControl = oTraceDialog.Model.getByName("lblClear")
oControl.Label = _GetLabel("DLGTRACE_LBLCLEAR_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP")
Set oMinLevel = oTraceDialog.Model.getByName("cboMinLevel")
If _A2B_.MinimalTraceLevel = 0 Then _A2B_.MinimalTraceLevel = _TraceLevel(TRACEERRORS)
oMinLevel.Text = _TraceLevel(_A2B_.MinimalTraceLevel)
oMinLevel.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP")
Set oControl = oTraceDialog.Model.getByName("lblMinLevel")
oControl.Label = _GetLabel("DLGTRACE_LBLMINLEVEL_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP")
Set oControl = oTraceDialog.Model.getByName("cmdOK")
oControl.Label = _GetLabel("DLGTRACE_CMDOK_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_CMDOK_HELP")
Set oControl = oTraceDialog.Model.getByName("cmdCancel")
oControl.Label = _GetLabel("DLGTRACE_CMDCANCEL_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_CMDCANCEL_HELP")
iOKCancel = oTraceDialog.Execute()
Select Case iOKCancel
Case 1 ' OK
If oClear.State = 1 Then
_A2B_.TraceLogs() = Array() ' Erase logged traces
_A2B_.TraceLogCount = 0
End If
If oMinLevel.Text <> "" Then _A2B_.MinimalTraceLevel = _TraceLevel(oMinLevel.Text)
If oEntries.Value <> 0 And oEntries.Value <> _A2B_.TraceLogMaxEntries Then
_A2B_.TraceLogs() = Array()
_A2B_.TraceLogMaxEntries = oEntries.Value
End If
Case 0 ' Cancel
Case Else
End Select
Exit_Sub:
If Not IsNull(oTraceDialog) Then oTraceDialog.Dispose()
Exit Sub
Error_Sub:
With _A2B_
.TraceLogs() = Array()
.TraceLogCount = 0
.TraceLogLast = 0
End With
GoTo Exit_Sub
End Sub ' TraceConsole V1.0.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceError(ByVal psErrorLevel As String _
, ByVal piErrorCode As Integer _
, ByVal psErrorProc As String _
, ByVal piErrorLine As Integer _
, ByVal Optional pvMsgBox As Variant _
, ByVal Optional pvArgs As Variant _
)
' store error codes in trace buffer
On Local Error Resume Next
Dim sErrorText As String, sErrorDesc As String, oDb As Object
sErrorDesc = _ErrorMessage(piErrorCode, pvArgs)
sErrorText = _GetLabel("ERR#") & CStr(piErrorCode) _
& " (" & sErrorDesc & ") " & _GetLabel("ERROCCUR") _
& Iif(piErrorLine > 0, " " & _GetLabel("ERRLINE") & " " & CStr(piErrorLine), "") _
& Iif(psErrorProc <> "", " " & _GetLabel("ERRIN") & " " & psErrorProc, Iif(_A2B_.CalledSub = "", "", " " & _Getlabel("ERRIN") & " " & _A2B_.CalledSub))
If IsMissing(pvMsgBox) Then pvMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT )
TraceLog(psErrorLevel, sErrorText, pvMsgBox)
' Unexpected error detected in user program or in Access2Base
If psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT Then
_A2B_.CalledSub = ""
If psErrorLevel = TRACEFATAL Then
Set oDb = Application.CurrentDb()
If Not IsNull(oDb) Then oDb.CloseAllrecordsets()
End If
Stop
End If
End Sub ' TraceError V0.9,5
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceLevel(ByVal Optional psTraceLevel As String)
' Set trace level to argument
If _ErrorHandler() Then On Local Error Goto Error_Sub
Select Case True
Case IsMissing(psTraceLevel) : psTraceLevel = "ERROR"
Case psTraceLevel = "" : psTraceLevel = "ERROR"
Case Utils._InList(UCase(psTraceLevel), Array( _
TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT _
)
Case Else : Goto Exit_Sub
End Select
_A2B_.MinimalTraceLevel = _TraceLevel(psTraceLevel)
Exit_Sub:
Exit Sub
Error_Sub:
With _A2B_
.TraceLogs() = Array()
.TraceLogCount = 0
.TraceLogLast = 0
End With
GoTo Exit_Sub
End Sub ' TraceLevel V0.9.5
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceLog(Byval psTraceLevel As String _
, ByVal psText As String _
, ByVal Optional pbMsgBox As Boolean _
)
' Store Text in trace log (circular buffer)
If _ErrorHandler() Then On Local Error Goto Error_Sub
Dim vTraceLogs() As String, sTraceLevel As String
With _A2B_
If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS)
If _TraceLevel(psTraceLevel) < .MinimalTraceLevel Then Exit Sub
If UBound(.TraceLogs) = -1 Then ' Initialize TraceLog
If .TraceLogMaxEntries = 0 Then .TraceLogMaxEntries = cstLogMaxEntries
Redim vTraceLogs(0 To .TraceLogMaxEntries - 1)
.TraceLogs = vTraceLogs
.TraceLogCount = 0
.TraceLogLast = -1
If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) ' Set default value
End If
.TraceLogLast = .TraceLogLast + 1
If .TraceLogLast > UBound(.TraceLogs) Then .TraceLogLast = LBound(.TraceLogs) ' Circular buffer
If Len(psTraceLevel) > 7 Then sTraceLevel = Left(psTraceLevel, 7) Else sTraceLevel = psTraceLevel & Spc(8 - Len(psTraceLevel))
.TraceLogs(.TraceLogLast) = Format(Now(), "YYYY-MM-DD hh:mm:ss") & " " & sTraceLevel & psText
If .TraceLogCount <= UBound(.TraceLogs) Then .TraceLogCount = .TraceLogCount + 1 ' # of active entries
End With
If IsMissing(pbMsgBox) Then pbMsgBox = True
Dim iMsgBox As Integer
If pbMsgBox Then
Select Case psTraceLevel
Case TRACEINFO: iMsgBox = vbInformation
Case TRACEERRORS, TRACEWARNING: iMsgBox = vbExclamation
Case TRACEFATAL, TRACEABORT: iMsgBox = vbCritical
Case Else: iMsgBox = vbInformation
End Select
MsgBox psText, vbOKOnly + iMsgBox, psTraceLevel
End If
Exit_Sub:
Exit Sub
Error_Sub:
With _A2B_
.TraceLogs() = Array()
.TraceLogCount = 0
.TraceLogLast = 0
End With
GoTo Exit_Sub
End Sub ' TraceLog V0.9.5
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _DumpToFile(oEvent As Object)
' Execute the Dump To File command from the Trace dialog
' Modified from Andrew Pitonyak's Base Macro Programming §10.4
If _ErrorHandler() Then On Local Error GoTo Error_Sub
Dim sPath as String, iFileNumber As Integer, i As Integer
sPath = _PromptFilePicker("txt")
If sPath <> "" Then ' Save button pressed
If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized
iFileNumber = FreeFile()
Open sPath For Append Access Write Lock Read As iFileNumber
If _A2B_.TraceLogCount > 0 Then
If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast
Do
If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0
Print #iFileNumber _A2B_.TraceLogs(i)
Loop While i <> _A2B_.TraceLogLast
End If
Close iFileNumber
MsgBox _GetLabel("SAVECONSOLEENTRIES"), vbOK + vbInformation, _GetLabel("SAVECONSOLE")
End If
End If
Exit_Sub:
Exit Sub
Error_Sub:
TraceError("ERROR", Err, "DumpToFile", Erl)
GoTo Exit_Sub
End Sub ' DumpToFile V0.8.5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ErrorHandler(Optional ByVal pbCheck As Boolean) As Boolean
' Indicate if error handler is activated or not
' When argument present set error handler
If Not IsMissing(pbCheck) Then _A2B_.ErrorHandler = pbCheck
_ErrorHandler = _A2B_.ErrorHandler
Exit Function
End Function
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _ErrorMessage(ByVal piErrorNumber As Integer, Optional ByVal pvArgs As Variant) As String
' Return error message corresponding to ErrorNumber (standard or not)
' and replaces %0, %1, ... , %9 by psArgs(0), psArgs(1), ...
Dim sErrorMessage As String, i As Integer, sErrLabel
_ErrorMessage = ""
If piErrorNumber > ERRINIT Then
sErrLabel = "ERR" & piErrorNumber
sErrorMessage = _Getlabel(sErrLabel)
If Not IsMissing(pvArgs) Then
If Not IsArray(pvArgs) Then
sErrorMessage = Join(Split(sErrorMessage, "%0"), Utils._CStr(pvArgs, False))
Else
For i = LBound(pvArgs) To UBound(pvArgs)
sErrorMessage = Join(Split(sErrorMessage, "%" & i), Utils._CStr(pvArgs(i), False))
Next i
End If
End If
Else
sErrorMessage = Error(piErrorNumber)
' Most (or all?) error messages terminate with a "."
If Len(sErrorMessage) > 1 And Right(sErrorMessage, 1) = "." Then sErrorMessage = Left(sErrorMessage, Len(sErrorMessage)-1)
End If
_ErrorMessage = sErrorMessage
Exit Function
End Function ' ErrorMessage V0.8.9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _PromptFilePicker(ByVal psSuffix As String) As String
' Prompt for output file name
' Return "" if Cancel
' Modified from Andrew Pitonyak's Base Macro Programming §10.4
If _ErrorHandler() Then On Local Error GoTo Error_Function
Dim oFileDialog as Object, oUcb as object, oPath As Object
Dim iAccept as Integer, sInitPath as String
Set oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
oFileDialog.Initialize(Array(com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION))
Set oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
oFileDialog.appendFilter("*." & psSuffix, "*." & psSuffix)
oFileDialog.appendFilter("*.*", "*.*")
oFileDialog.setCurrentFilter("*." & psSuffix)
Set oPath = createUnoService("com.sun.star.util.PathSettings")
sInitPath = oPath.Work ' Probably My Documents
If oUcb.Exists(sInitPath) Then oFileDialog.SetDisplayDirectory(sInitPath)
iAccept = oFileDialog.Execute()
_PromptFilePicker = ""
If iAccept = 1 Then ' Save button pressed
_PromptFilePicker = oFileDialog.Files(0)
End If
Exit_Function:
If Not IsEmpty(oFileDialog) And Not IsNull(oFileDialog) Then oFileDialog.Dispose()
Exit Function
Error_Function:
TraceError("ERROR", Err, "PromptFilePicker", Erl)
GoTo Exit_Function
End Function ' PromptFilePicker V0.8.5
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _TraceArguments(Optional psCall As String)
' Process the ERRMISSINGARGUMENTS error
' psCall is present if error detected before call to _SetCalledSub
If Not IsMissing(psCall) Then Utils._SetCalledSub(psCall)
TraceError(TRACEFATAL, ERRMISSINGARGUMENTS, Utils._CalledSub(), 0)
Exit Sub
End Sub ' TraceArguments
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _TraceLevel(ByVal pvTraceLevel As Variant) As Variant
' Convert string trace level to numeric value or the opposite
Dim vTraces As Variant, i As Integer
vTraces = Array(TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT, TRACEANY)
Select Case VarType(pvTraceLevel)
Case vbString
_TraceLevel = 4 ' 4 = Default
For i = 0 To UBound(vTraces)
If UCase(pvTraceLevel) = UCase(vTraces(i)) Then
_TraceLevel = i + 1
Exit For
End If
Next i
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
If pvTraceLevel < 1 Or pvTraceLevel > UBound(vTraces) + 1 Then _TraceLevel = TRACEERRORS Else _TraceLevel = vTraces(pvTraceLevel - 1)
End Select
End Function ' TraceLevel
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _TraceStandalone(ByVal Optional psCall As String) As Boolean
' Display error when property or method or action not applicable from a standalone form
' If 2nd argument = SILENT set silent mode. Silent mode = no error message (for tests purpose only)
Static sMode As String
Const cstSilent = "SILENT"
If Not IsMissing(psCall) Then
If psCall = cstSilent Then sMode = cstSilent Else Utils._SetCalledSub(psCall)
End If
If Application._CurrentDb()._Standalone Then
If sMode <> cstSilent Then TraceError(TRACEFATAL, ERRSTANDALONE, Utils._CalledSub(), 0)
_TraceStandalone = True
Else
_TraceStandalone = False
End If
End Function ' TraceStandalone
</script:module>
