D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
lib
/
libreoffice
/
share
/
basic
/
Access2Base
/
Filename :
Trace.xba
back
Copy
<?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> <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 Public Const cstLogMaxEntries = 99 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, oTraceDialog As Object sLineBreak = vbNewLine Set oTraceDialog = CreateUnoDialog(Utils._GetDialogLib().dlgTrace) oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE") oTraceDialog.Model.HelpText = _GetLabel("DLGTRACE_HELP") 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) - Len(sLineBreak)) ' 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.1.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 code and description in trace rolling buffer ' Display error message if errorlevel >= ERROR ' Stop program execution if errorlevel = FATAL or ABORT On Local Error Resume Next If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session 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)) With _A2B_ .LastErrorCode = piErrorCode .LastErrorLevel = psErrorLevel .ErrorText = sErrorDesc .ErrorLongText = sErrorText .CalledSub = "" End With 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 If psErrorLevel = TRACEFATAL Then Set oDb = _A2B_.CurrentDb() If Not IsNull(oDb) Then oDb.CloseAllrecordsets() End If Stop End If End Sub ' TraceError V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function TraceErrorCode() As Variant ' Return the last encountered error code, level, description in an array ' UNPUBLISHED Dim vError As Variant With _A2B_ vError = Array( _ .LastErrorCode _ , .LastErrorLevel _ , .ErrorText _ , .ErrorLongText _ ) End With TraceErrorCode = vError End Function ' TraceErrorCode V6.3 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 IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session 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 </script:module>