Quelle  Trace.xba   Sprache: unbekannt

<?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, bMsgBox As Boolean
 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 VarType(pvMsgBox) = vbError Then
  bMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT )
 ElseIf IsMissing(pvMsgBox) Then
  bMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT )
 Else
  bMsgBox = pvMsgBox
 End If
 TraceLog(psErrorLevel, sErrorText, bMsgBox)
 
 ' 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>