[Libreoffice-commits] core.git: 10 commits - wizards/Package_access2base.mk wizards/source
Jean-Pierre Ledure
jp at ledure.be
Thu Jan 12 10:41:31 UTC 2017
wizards/Package_access2base.mk | 1
wizards/source/access2base/Application.xba | 164 +++++-
wizards/source/access2base/Collect.xba | 8
wizards/source/access2base/Compatible.xba | 10
wizards/source/access2base/Control.xba | 417 ++++++++++++---
wizards/source/access2base/DataDef.xba | 14
wizards/source/access2base/Database.xba | 26
wizards/source/access2base/Dialog.xba | 16
wizards/source/access2base/Event.xba | 8
wizards/source/access2base/Field.xba | 12
wizards/source/access2base/Form.xba | 202 +++++++
wizards/source/access2base/L10N.xba | 6
wizards/source/access2base/Module.xba | 720 +++++++++++++++++++++++++++
wizards/source/access2base/OptionGroup.xba | 10
wizards/source/access2base/PropertiesGet.xba | 7
wizards/source/access2base/PropertiesSet.xba | 7
wizards/source/access2base/Recordset.xba | 12
wizards/source/access2base/Root_.xba | 13
wizards/source/access2base/SubForm.xba | 199 +++++++
wizards/source/access2base/Test.xba | 4
wizards/source/access2base/UtilProperty.xba | 183 +++++-
wizards/source/access2base/Utils.xba | 246 ++++++++-
wizards/source/access2base/acConstants.xba | 21
wizards/source/access2base/script.xlb | 1
24 files changed, 2111 insertions(+), 196 deletions(-)
New commits:
commit 9e634331a760bbca807741674d03f4c593915dd6
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Wed Dec 28 12:29:26 2016 +0100
Access2Base - Improve precision of query typing
Change-Id: I6c5246809cb533a2c69978008ea996392e2fbe6a
diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba
index 0b87055..bba8e85 100644
--- a/wizards/source/access2base/DataDef.xba
+++ b/wizards/source/access2base/DataDef.xba
@@ -490,10 +490,12 @@ Dim sSql As String, sVerb As String, iType As Integer
_PropertyGet = Query.Command
Case UCase("Type")
iType = 0
- sSql = Trim(UCase(Query.Command))
+ sSql = Utils._Trim(UCase(Query.Command))
sVerb = Split(sSql, " ")(0)
If sVerb = "SELECT" Then iType = iType + dbQSelect
- If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 Then iType = iType + dbQMakeTable
+ If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 _
+ Or sVerb = "CREATE" And InStr(sSql, " TABLE ") > 0 _
+ Then iType = iType + dbQMakeTable
If sVerb = "SELECT" And InStr(sSql, " UNION ") > 0 Then iType = iType + dbQSetOperation
If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough
If sVerb = "INSERT" Then iType = iType + dbQAppend
commit e2a1e22288a4fbe0681a8e33d25816f80799e687
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Tue Dec 27 14:40:08 2016 +0100
Access2Base - Use Empty() builtin function
... i.o. uninitialized variable
Change-Id: I732705df11ea25c2b106d542f9e97f3f32cc9867
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba
index 037d54b..46cb24a 100644
--- a/wizards/source/access2base/Application.xba
+++ b/wizards/source/access2base/Application.xba
@@ -734,13 +734,13 @@ Public Function Controls(ByVal Optional pvObject As Variant, Optional ByVal pvIn
' If no pvIndex argument, return a Collection type
If _ErrorHandler() Then On Local Error Goto Error_Function
-Dim vObject As Object, vEMPTY As variant
+Dim vObject As Object
Const cstThisSub = "Controls"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvObject) Then Call _TraceArguments()
If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
- Controls = vEMPTY
+ Controls = EMPTY
If VarType(pvObject) = vbString Then
Set vObject = Forms(pvObject)
diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba
index 9319895..859e446 100644
--- a/wizards/source/access2base/Control.xba
+++ b/wizards/source/access2base/Control.xba
@@ -1381,10 +1381,10 @@ REM ----------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant
' Return property value of the psProperty property name
-Dim vEMPTY As Variant, iArg As Integer
+Dim iArg As Integer
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Control.get" & psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
'Check Index argument
Dim iArgNr As Integer
@@ -1759,7 +1759,7 @@ Dim vSelection As Variant, sSelectedText As String
If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error
If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error
If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected
- vGet = vEMPTY ' Listbox has no value, only an array of Selected flags to identify values
+ vGet = EMPTY ' Listbox has no value, only an array of Selected flags to identify values
Else ' Mono selection
Select Case _ParentType
Case CTLPARENTISDIALOG
@@ -1768,7 +1768,7 @@ Dim vSelection As Variant, sSelectedText As String
If lListIndex > -1 And lListIndex <= UBound(ControlModel.StringItemList) Then
vGet = ControlModel.StringItemList(lListIndex)
Else
- vGet = vEMPTY
+ vGet = EMPTY
End If
End If
Case Else
@@ -1838,15 +1838,15 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Control._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet V0.9.1
diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba
index df416c0..0b87055 100644
--- a/wizards/source/access2base/DataDef.xba
+++ b/wizards/source/access2base/DataDef.xba
@@ -477,8 +477,8 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type)
Utils._SetCalledSub(cstThisSub & ".get" & psProperty)
-Dim vEMPTY As Variant, sSql As String, sVerb As String, iType As Integer
- _PropertyGet = vEMPTY
+Dim sSql As String, sVerb As String, iType As Integer
+ _PropertyGet = EMPTY
If Not hasProperty(psProperty) Then Goto Trace_Error
Select Case UCase(psProperty)
@@ -517,11 +517,11 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba
index 01c56a7..4d7513e 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -1657,8 +1657,8 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Database.get" & psProperty)
-Dim vEMPTY As Variant
- _PropertyGet = vEMPTY
+
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("Connect")
@@ -1679,11 +1679,11 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Database._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/Dialog.xba b/wizards/source/access2base/Dialog.xba
index 0fafbd9..a0b23ea 100644
--- a/wizards/source/access2base/Dialog.xba
+++ b/wizards/source/access2base/Dialog.xba
@@ -565,8 +565,7 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
Utils._SetCalledSub("Dialog.get" & psProperty)
'Execute
-Dim vEMPTY As Variant
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("Name"), UCase("IsLoaded")
@@ -599,15 +598,15 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Dialog:
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/Event.xba b/wizards/source/access2base/Event.xba
index de6aa2a..32ec17c 100644
--- a/wizards/source/access2base/Event.xba
+++ b/wizards/source/access2base/Event.xba
@@ -420,8 +420,8 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Event.get" & psProperty)
-Dim vEMPTY As Variant
- _PropertyGet = vEMPTY
+
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("ButtonLeft")
@@ -486,11 +486,11 @@ Exit_Function:
Trace_Error:
' Errors are not displayed to avoid display infinite cycling
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, False, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet V1.1.0
</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Field.xba b/wizards/source/access2base/Field.xba
index d08bcfb..35d5bc6 100644
--- a/wizards/source/access2base/Field.xba
+++ b/wizards/source/access2base/Field.xba
@@ -398,12 +398,12 @@ Dim cstThisSub As String
If Not hasProperty(psProperty) Then Goto Trace_Error
-Dim vEMPTY As Variant, bCond1 As Boolean, bCond2 As Boolean, vValue As Variant, oValue As Object, sValue As String
+Dim bCond1 As Boolean, bCond2 As Boolean, vValue As Variant, oValue As Object, sValue As String
Dim oSize As Object, lSize As Long, bNullable As Boolean, bNull As Boolean
Const cstMaxTextLength = 65535
Const cstMaxBinlength = 2 * 65535
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("DataType")
@@ -490,7 +490,7 @@ Const cstMaxBinlength = 2 * 65535
End If
oSize.closeInput()
Else
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
End If
Case UCase("Name")
_PropertyGet = _Name
@@ -594,15 +594,15 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Length:
TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk"))
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet V1.1.0
diff --git a/wizards/source/access2base/Form.xba b/wizards/source/access2base/Form.xba
index f890214..66962d1 100644
--- a/wizards/source/access2base/Form.xba
+++ b/wizards/source/access2base/Form.xba
@@ -845,10 +845,10 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
Utils._SetCalledSub("Form.get" & psProperty)
'Execute
-Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant
+Dim oDatabase As Object, vBookmark As Variant
Dim i As Integer, oObject As Object
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("Name"), UCase("IsLoaded")
@@ -937,15 +937,15 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Form:
TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Form._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/OptionGroup.xba b/wizards/source/access2base/OptionGroup.xba
index a1177ae..180591a 100644
--- a/wizards/source/access2base/OptionGroup.xba
+++ b/wizards/source/access2base/OptionGroup.xba
@@ -216,9 +216,9 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
Utils._SetCalledSub("OptionGroup.get" & psProperty)
'Execute
-Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant
+Dim oDatabase As Object, vBookmark As Variant
Dim iValue As Integer, i As Integer
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("Count")
_PropertyGet = _Count
@@ -244,15 +244,15 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "OptionGroup._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba
index 81061bd..d04f2e6 100644
--- a/wizards/source/access2base/Recordset.xba
+++ b/wizards/source/access2base/Recordset.xba
@@ -1135,8 +1135,7 @@ Dim cstThisSub As String
cstThisSub = "Recordset.get"
Utils._SetCalledSub(cstThisSub & psProperty)
-Dim vEMPTY As Variant
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("AbsolutePosition")
@@ -1203,7 +1202,7 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Forward:
TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0)
@@ -1213,7 +1212,7 @@ Trace_Closed:
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/SubForm.xba b/wizards/source/access2base/SubForm.xba
index 832e8c1..caa4a2c 100644
--- a/wizards/source/access2base/SubForm.xba
+++ b/wizards/source/access2base/SubForm.xba
@@ -570,8 +570,8 @@ Dim iArgNr As Integer
End If
'Execute
-Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant
- _PropertyGet = vEMPTY
+Dim oDatabase As Object, vBookmark As Variant
+ _PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("AllowAdditions")
@@ -652,15 +652,15 @@ Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm._PropertyGet", Erl)
- _PropertyGet = vEMPTY
+ _PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
index 6685078..7367e4e 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -211,7 +211,7 @@ Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean
' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty
' pbStrDate = True keeps dates as strings
-Dim cstEscape1 As String, cstEscape2 As String, vEMPTY As Variant
+Dim cstEscape1 As String, cstEscape2 As String
cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\
cstEscape2 = Chr(27) ' ESC used as temporary escape character for \;
@@ -242,7 +242,7 @@ Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
' Usual case
Select Case True
- Case sArg = "[EMPTY]" : _CVar = vEMPTY
+ Case sArg = "[EMPTY]" : _CVar = EMPTY
Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null
Case sArg = "[OBJECT]" : _CVar = Nothing
Case sArg = "[TRUE]" : _CVar = True
commit de5222082f6652a0ff8715ad9e908b45e893db64
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sun Dec 25 18:04:59 2016 +0100
Access2Base - Recognize correctly formatted fields
New ImplementationName introduced in LO 5.1
Change-Id: Ifa181570575622aca27520397f2e88cbc9742d1e
diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba
index f02b46c..9319895 100644
--- a/wizards/source/access2base/Control.xba
+++ b/wizards/source/access2base/Control.xba
@@ -1169,6 +1169,7 @@ Dim sControlTypes() As Variant, i As Integer, vSplit() As Variant, sTrailer As S
_ControlType = _ClassId
If _SubType = CTLTEXTFIELD Then ' Formatted fields belong to the TextField family
If _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper" _
+ Or _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper_ForcedFormatted" _
Or _ImplementationName = "com.sun.star.form.component.FormattedField" Then ' When in datagrid
_SubType = CTLFORMATTEDFIELD
_ControlType = acFormattedField
commit 92608b890928b6d10931f4aad3385bb87284181d
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sat Dec 24 16:27:22 2016 +0100
Access2Base - Addition of Module object
New Module Basic module
New AllModules() collection in Application module
Extension of regex to backward searches
Change-Id: Id58f3b29d08e9f0b73e192cfc0c2a99988e73fcf
diff --git a/wizards/Package_access2base.mk b/wizards/Package_access2base.mk
old mode 100644
new mode 100755
index 3a60e10..bf019c2
--- a/wizards/Package_access2base.mk
+++ b/wizards/Package_access2base.mk
@@ -40,6 +40,7 @@ $(eval $(call gb_Package_add_files,wizards_basicsrvaccess2base,$(LIBO_SHARE_FOLD
Form.xba \
L10N.xba \
Methods.xba \
+ Module.xba \
OptionGroup.xba \
PropertiesGet.xba \
PropertiesSet.xba \
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba
index 19a8720..037d54b 100644
--- a/wizards/source/access2base/Application.xba
+++ b/wizards/source/access2base/Application.xba
@@ -45,6 +45,7 @@ Global Const ERRSQLSTATEMENT = 1523
Global Const ERROBJECTNOTFOUND = 1524
Global Const ERROPENOBJECT = 1525
Global Const ERRCLOSEOBJECT = 1526
+Global Const ERRMETHOD = 1527
Global Const ERRACTION = 1528
Global Const ERRSENDMAIL = 1529
Global Const ERRFORMYETOPEN = 1530
@@ -74,6 +75,8 @@ Global Const ERRSUBFORMNOTFOUND = 1553
Global Const ERRWINDOW = 1554
Global Const ERRCOMPATIBILITY = 1555
Global Const ERRPRECISION = 1556
+Global Const ERRMODULENOTFOUND = 1557
+Global Const ERRPROCEDURENOTFOUND = 1558
REM -----------------------------------------------------------------------------------------------------------------------
Global Const DBCONNECTBASE = 1 ' Connection from Base document (OpenConnection)
@@ -94,6 +97,7 @@ Global Const DBMS_SQLITE = 8
REM -----------------------------------------------------------------------------------------------------------------------
Global Const COLLALLDIALOGS = "ALLDIALOGS"
Global Const COLLALLFORMS = "ALLFORMS"
+Global Const COLLALLMODULES = "ALLMODULES"
Global Const COLLCOMMANDBARS = "COMMANDBARS"
Global Const COLLCOMMANDBARCONTROLS = "COMMANDBARCONTROLS"
Global Const COLLCONTROLS = "CONTROLS"
@@ -116,6 +120,7 @@ Global Const OBJDIALOG = "DIALOG"
Global Const OBJEVENT = "EVENT"
Global Const OBJFIELD = "FIELD"
Global Const OBJFORM = "FORM"
+Global Const OBJMODULE = "MODULE"
Global Const OBJOPTIONGROUP = "OPTIONGROUP"
Global Const OBJPROPERTY = "PROPERTY"
Global Const OBJQUERYDEF = "QUERYDEF"
@@ -160,6 +165,10 @@ Global Const CTLPARENTISGRID = "GRID"
Global Const CTLPARENTISGROUP = "OPTIONGROUP"
REM -----------------------------------------------------------------------------------------------------------------------
+Global Const MODDOCUMENT = "DOCUMENT"
+Global Const MODGLOBAL = "GLOBAL"
+
+REM -----------------------------------------------------------------------------------------------------------------------
Type DocContainer
Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
Active As Boolean
@@ -205,9 +214,11 @@ Const cstSepar = "!"
Set oMacLibraries = DialogLibraries
vMacLibraries = oMacLibraries.getElementNames()
'Remove Access2Base from the list
- For i = 0 To UBound(vMacLibraries)
- If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
- Next i
+ If _A2B_.ExcludeA2B Then
+ For i = 0 To UBound(vMacLibraries)
+ If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
+ Next i
+ End If
vMacLibraries = Utils._TrimArray(vMacLibraries)
If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library
@@ -394,6 +405,149 @@ Error_Function:
End Function ' AllForms V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
+Public Function AllModules(ByVal Optional pvIndex As Variant, ByVal Optional pbAllModules As Boolean) As Variant
+' Return either a Collection or a Module object
+' The modules are selected only if library is loaded
+' (UNPUBLISHED) pbAllModules = False collects only the modules located in the currently open document
+
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+Const cstThisSub = "AllModules"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim iMode As Integer, vModules() As Variant, i As Integer, j As Integer, iCount As Integer
+Dim oMacLibraries As Object, vAllModules As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean
+Dim sScript As String, sLibrary As String, oDocLibraries As Object, sStorage As String
+Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
+Const cstCount = 0, cstByIndex = 1, cstByName = 2
+Const cstDot = "."
+
+ If IsMissing(pvIndex) Then
+ iMode = cstCount
+ Else
+ If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ If VarType(pvIndex) = vbString Then
+ iMode = cstByName
+ ' Dtermine full name STORAGE.LIBRARY.MODULE
+ vNames = Split(pvIndex, cstDot)
+ If UBound(vNames) = 2 Then
+ ElseIf UBound(vNames) = 1 Then
+ pvIndex = MODDOCUMENT & cstDot & pvIndex
+ ElseIf UBound(vNames) = 0 Then
+ pvIndex = MODDOCUMENT & cstDot & "STANDARD" & cstDot & pvIndex
+ Else
+ GoTo Trace_Not_Found
+ End If
+ Else
+ iMode = cstByIndex
+ End If
+ End If
+
+ If IsMissing(pbAllModules) Then pbAllModules = True
+ If Not Utils._CheckArgument(pbAllModules, 2, vbBoolean) Then Goto Exit_Function
+
+ Set vAllModules = Nothing
+
+ Set oDocLibraries = ThisComponent.BasicLibraries
+ vDocLibraries = oDocLibraries.getElementNames()
+ If pbAllModules Then
+ Set oMacLibraries = GlobalScope.BasicLibraries
+ vMacLibraries = oMacLibraries.getElementNames()
+ 'Remove Access2Base from the list
+ If _A2B_.ExcludeA2B Then
+ For i = 0 To UBound(vMacLibraries)
+ If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
+ Next i
+ End If
+ vMacLibraries = Utils._TrimArray(vMacLibraries)
+ End If
+
+ If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library
+ Set vAllModules = New Collect
+ vAllModules._CollType = COLLALLMODULES
+ vAllModules._ParentType = OBJAPPLICATION
+ vAllModules._ParentName = ""
+ vAllModules._Count = 0
+ Goto Exit_Function
+ End If
+
+ iCount = 0
+ For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1
+ bFound = False
+ If i <= UBound(vDocLibraries) Then
+ sLibrary = vDocLibraries(i)
+ sStorage = MODDOCUMENT
+ Set oDocMacLib = oDocLibraries
+ ' Sometimes library not loaded as should ??
+ If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary)
+ Else
+ sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1)
+ sStorage = MODGLOBAL
+ Set oDocMacLib = oMacLibraries
+ End If
+ If oDocMacLib.IsLibraryLoaded(sLibrary) Then
+ Set oLibrary = oDocMacLib.getByName(sLibrary)
+ If oLibrary.hasElements() Then
+ vModules = oLibrary.getElementNames()
+ Select Case iMode
+ Case cstCount
+ iCount = iCount + UBound(vModules) + 1
+ Case cstByIndex, cstByName
+ For j = 0 To UBound(vModules)
+ If iMode = cstByIndex Then
+ If pvIndex = iCount Then bFound = True
+ iCount = iCount + 1
+ Else
+ If UCase(pvIndex) = UCase(sStorage & cstDot & sLibrary & cstDot & vModules(j)) Then bFound = True
+ End If
+ If bFound Then
+ sScript = oLibrary.getByName(vModules(j)) ' Initiate Module object
+ iCount = i
+ Exit For
+ End If
+ Next j
+ End Select
+ End If
+ End If
+ If bFound Then Exit For
+ Next i
+
+ If iMode = cstCount Then
+ Set vAllModules = New Collect
+ vAllModules._CollType = COLLALLMODULES
+ vAllModules._ParentType = OBJAPPLICATION
+ vAllModules._ParentName = ""
+ vAllModules._Count = iCount
+ Else
+ If Not bFound Then
+ If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found
+ End If
+ Set vAllModules = New Module
+ vAllModules._Name = vModules(j)
+ vAllModules._LibraryName = sLibrary
+ Set vAllModules._Library = oLibrary
+ vAllModules._Storage = sStorage
+ vAllModules._Script = sScript
+ vAllModules._Initialize()
+ End If
+
+Exit_Function:
+ Set AllModules = vAllModules
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+Trace_Not_Found:
+ TraceError(TRACEFATAL, ERRMODULENOTFOUND, Utils._CalledSub(), 0, , pvIndex)
+ Goto Exit_Function
+Trace_Error_Index:
+ TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
+ Set vModules = Nothing
+ Goto Exit_Function
+Error_Function:
+ TraceError(TRACEABORT, Err, cstThisSub, Erl)
+ Set vModules = Nothing
+ GoTo Exit_Function
+End Function ' AllModules V1.7.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
Public Sub CloseConnection ()
' Close all connections established by current document to free memory.
diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba
index ad33cc7..d0adbe0 100644
--- a/wizards/source/access2base/Collect.xba
+++ b/wizards/source/access2base/Collect.xba
@@ -10,7 +10,7 @@ Option ClassModule
Option Explicit
-REM MODULE NAME <> COLLECTION (seems a reserved name ?)
+REM MODULE NAME <> COLLECTION (is a reserved name for ... collections)
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS ---
@@ -77,6 +77,8 @@ Dim vNames() As Variant, oProperty As Object
Set Item = Application.AllDialogs(pvItem)
Case COLLALLFORMS
Set Item = Application.AllForms(pvItem)
+ Case COLLALLMODULES
+ Set Item = Application.AllModules(pvItem)
Case COLLCOMMANDBARS
Set Item = Application.CommandBars(pvItem)
Case COLLCOMMANDBARCONTROLS
diff --git a/wizards/source/access2base/Dialog.xba b/wizards/source/access2base/Dialog.xba
index 9d633cd..0fafbd9 100644
--- a/wizards/source/access2base/Dialog.xba
+++ b/wizards/source/access2base/Dialog.xba
@@ -14,7 +14,7 @@ REM ----------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS ---
REM -----------------------------------------------------------------------------------------------------------------------
-Private _Type As String ' Must be FORM
+Private _Type As String ' Must be DIALOG
Private _Name As String
Private _Shortcut As String
Private _Dialog As Object ' com.sun.star.io.XInputStreamProvider
@@ -199,7 +199,11 @@ Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' a Collection object if pvIndex absent
' a Property object otherwise
+Const cstThisSub = "Dialog.Properties"
+ Utils._SetCalledSub(cstThisSub)
+
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
+
vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
@@ -211,6 +215,7 @@ Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
Exit_Function:
Set Properties = vProperty
+ Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Properties
diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba
index 7782779..f6e6d8f 100644
--- a/wizards/source/access2base/L10N.xba
+++ b/wizards/source/access2base/L10N.xba
@@ -80,6 +80,8 @@ Dim sLocal As String
Case "ERR" & ERRWINDOW : sLocal = "Current window is not a document"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Field '%0' could not be converted due to incompatibility of field types between the respective database systems"
Case "ERR" & ERRPRECISION : sLocal = "Field '%0' could not be loaded in record #%1 due to capacity shortage"
+ Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries"
+ Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Object"
Case "TABLE" : sLocal = "Table"
@@ -191,6 +193,8 @@ Dim sLocal As String
Case "ERR" & ERRWINDOW : sLocal = "La fenêtre courante n'est pas un document"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Le champ '%0' n'a pas pu être converti à cause d'une incompatibilité entre les types de champs supportés par les systèmes de bases de données respectifs"
Case "ERR" & ERRPRECISION : sLocal = "Le champ '%0' n'a pas pu être chargé dans l'enregistrement #%1 par manque de capacité"
+ Case "ERR" & ERRMODULENOTFOUND : sLocal = "Le module '%0' est introuvable dans les librairies chargées actuellement"
+ Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "La procédure '%0' est introuvable dans le module '%1'"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Objet"
Case "TABLE" : sLocal = "Table"
@@ -305,6 +309,8 @@ Dim sLocal As String
Case "ERR" & ERRWINDOW : sLocal = "La ventana actual no es un documento"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "El campo '%0' no se ha convertido debido a una incompatibilidad de los tipos de campo soportados entre las dos bases de datos"
Case "ERR" & ERRPRECISION : sLocal = "El campo '%0' no se ha cargado en el registro #%1 por falta de capacidad"
+ Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries"
+ Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Objeto"
Case "TABLE" : sLocal = "Tabla"
diff --git a/wizards/source/access2base/Module.xba b/wizards/source/access2base/Module.xba
new file mode 100644
index 0000000..64eea2f
--- /dev/null
+++ b/wizards/source/access2base/Module.xba
@@ -0,0 +1,720 @@
+<?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="Module" 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 Compatible
+Option ClassModule
+
+Option Explicit
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CLASS ROOT FIELDS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+Private _Type As String ' Must be MODULE
+Private _Name As String
+Private _Library As Object ' com.sun.star.container.XNameAccess
+Private _LibraryName As String
+Private _Storage As String ' GLOBAL or DOCUMENT
+Private _Script As String ' Full script (string with vbLf's)
+Private _Lines As Variant ' Array of script lines
+Private _CountOfLines As Long
+Private _ProcsParsed As Boolean ' To test before use of proc arrays
+Private _ProcNames() As Variant ' All procedure names
+Private _ProcDecPositions() As Variant ' All procedure declarations
+Private _ProcEndPositions() As Variant ' All end procedure statements
+Private _ProcTypes() As Variant ' One of the vbext_pk_* constants
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CONSTRUCTORS / DESTRUCTORS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Sub Class_Initialize()
+ _Type = OBJMODULE
+ _Name = ""
+ Set _Library = Nothing
+ _LibraryName = ""
+ _Storage = ""
+ _Script = ""
+ _Lines = Array()
+ _CountOfLines = 0
+ _ProcsParsed = False
+ _ProcNames = Array()
+ _ProcDecPositions = Array()
+ _ProcEndPositions = Array()
+End Sub ' Constructor
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Sub Class_Terminate()
+ On Local Error Resume Next
+ Call Class_Initialize()
+End Sub ' Destructor
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Sub Dispose()
+ Call Class_Terminate()
+End Sub ' Explicit destructor
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CLASS GET/LET/SET PROPERTIES ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get CountOfDeclarationLines() As Long
+ CountOfDeclarationLines = _PropertyGet("CountOfDeclarationLines")
+End Property ' CountOfDeclarationLines (get)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get CountOfLines() As Long
+ CountOfLines = _PropertyGet("CountOfLines")
+End Property ' CountOfLines (get)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get Name() As String
+ Name = _PropertyGet("Name")
+End Property ' Name (get)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get ObjectType() As String
+ ObjectType = _PropertyGet("ObjectType")
+End Property ' ObjectType (get)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function Lines(Optional ByVal pvLine As Variant, Optional ByVal pvNumLines As Variant) As String
+' Returns a string containing the contents of a specified line or lines in a standard module or a class module
+
+Const cstThisSub = "Module.Lines"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim sLines As String, lLine As Long
+ sLines = ""
+
+ If IsMissing(pvLine) Or IsMissing(pvNumLines) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
+ If Not Utils._CheckArgument(pvNumLines, 1, _AddNumeric()) Then GoTo Exit_Function
+
+ lLine = pvLine
+ Do While lLine < _CountOfLines And lLine < pvLine + pvNumLines
+ sLines = sLines & _Lines(lLine - 1) & vbLf
+ lLine = lLine + 1
+ Loop
+ If Len(sLines) > 0 Then sLines = Left(sLines, Len(sLines) - 1)
+
+Exit_Function:
+ Lines = sLines
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' Lines
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function ProcBodyLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
+' Return the number of the line at which the body of a specified procedure begins
+
+Const cstThisSub = "Module.ProcBodyLine"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim iIndex As Integer
+
+ If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
+ If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
+
+ iIndex = _FindProcIndex(pvProc, pvProcType)
+ If iIndex >= 0 Then ProcBodyLine = _LineOfPosition(_ProcDecPositions(iIndex)) Else ProcBodyLine = iIndex
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' ProcBodyline
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function ProcCountLines(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
+' Return the number of lines in the specified procedure
+
+Const cstThisSub = "Module.ProcCountLines"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim iIndex As Integer, lStart As Long, lEnd As Long
+
+ If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
+ If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
+
+ iIndex = _FindProcIndex(pvProc, pvProcType)
+ lStart = ProcStartLine(pvProc, pvProcType)
+ lEnd = _LineOfPosition(_ProcEndPositions(iIndex))
+ ProcCountLines = lEnd - lStart + 1
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' ProcCountLines
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function ProcOfLine(Optional ByVal pvLine As Variant, Optional ByRef pvProcType As Variant) As String
+' Return the name and type of the procedure containing line pvLine
+
+Const cstThisSub = "Module.ProcOfLine"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim sProcedure As String, iProc As Integer, lLineDec As Long, lLineEnd As Long
+
+ If IsMissing(pvLine) Or IsMissing(pvProcType) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
+ If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
+
+ If Not _ProcsParsed Then _ParseProcs()
+
+ sProcedure = ""
+ For iProc = 0 To UBound(_ProcNames)
+ lLineEnd = _LineOfPosition(_ProcEndPositions(iProc))
+ If pvLine <= lLineEnd Then
+ lLineDec = _LineOfPosition(_ProcDecPositions(iProc))
+ If pvLine < lLineDec Then ' Line between 2 procedures
+ sProcedure = ""
+ Else
+ sProcedure = _ProcNames(iProc)
+ pvProcType = _ProcTypes(iProc)
+ End If
+ Exit For
+ End If
+ Next iProc
+
+Exit_Function:
+ ProcOfLine = sProcedure
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' ProcOfline
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function ProcStartLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
+' Return the number of the line at which the specified procedure begins
+
+Const cstThisSub = "Module.ProcStartLine"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim lLine As Long, lIndex As Long, sLine As String
+
+ If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
+ If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
+
+ lLine = ProcBodyLine(pvProc, pvProcType)
+ ' Search baclIndexward for comment lines
+ lIndex = lLine - 1
+ Do While lIndex > 0
+ sLine = _Trim(_Lines(lIndex - 1))
+ If UCase(Left(sLine, 4)) = "REM " Or Left(sLine, 1) = "'" Then
+ lLine = lIndex
+ Else
+ Exit Do
+ End If
+ lIndex = lIndex - 1
+ Loop
+
+ ProcStartLine = lLine
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' ProcStartLine
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
+' Return
+' a Collection object if pvIndex absent
+' a Property object otherwiseREM -----------------------------------------------------------------------------------------------------------------------
+
+
+Const cstThisSub = "Module.Properties"
+ Utils._SetCalledSub(cstThisSub)
+
+Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
+
+ vPropertiesList = _PropertiesList()
+ sObject = Utils._PCase(_Type)
+ If IsMissing(pvIndex) Then
+ vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList)
+ Else
+ vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
+ vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
+ End If
+
+Exit_Function:
+ Set Properties = vProperty
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' Properties
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get pType() As String
+ pType = _PropertyGet("Type")
+End Property ' Type (get)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CLASS METHODS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function Find(Optional ByVal pvTarget As Variant _
+ , Optional ByRef pvStartLine As Variant _
+ , Optional ByRef pvStartColumn As Variant _
+ , Optional ByRef pvEndLine As Variant _
+ , Optional ByRef pvEndColumn As Variant _
+ , Optional ByVal pvWholeWord As Boolean _
+ , Optional ByVal pvMatchCase As Boolean _
+ , Optional ByVal pvPatternSearch As Boolean _
+ ) As Boolean
+' Finds specified text in the module
+' xxLine and xxColumn arguments are mainly to return the position of the found string
+' If they are initialized but nonsense, the function returns False
+
+Const cstThisSub = "Module.Find"
+ Utils._SetCalledSub(cstThisSub)
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+
+Dim bFound As Boolean, lPosition As Long, lStartLine As Long, lStartColumn As Long, lStartPosition As Long
+Dim lEndLine As Long, lEndColumn As Long, lEndPosition As Long
+Dim sMatch As String, vOptions As Variant, sPattern As String
+Dim i As Integer, sSpecChar As String
+
+Const cstSpecialCharacters = "\[^$.|?*+()"
+
+ bFound = False
+
+ If IsMissing(pvTarget) Or IsMissing(pvStartLine) Or IsMissing(pvStartColumn) Or IsMissing(pvEndLine) Or IsMissing(pvEndColumn) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvTarget, 1, vbString) Then GoTo Exit_Function
+ If Len(pvTarget) = 0 Then GoTo Exit_Function
+ If Not IsEmpty(pvStartLine) Then
+ If Not Utils._CheckArgument(pvStartLine, 2, _AddNumeric()) Then GoTo Exit_Function
+ End If
+ If Not IsEmpty(pvStartColumn) Then
+ If Not Utils._CheckArgument(pvStartColumn, 3, _AddNumeric()) Then GoTo Exit_Function
+ End If
+ If Not IsEmpty(pvEndLine) Then
+ If Not Utils._CheckArgument(pvEndLine, 4, _AddNumeric()) Then GoTo Exit_Function
+ End If
+ If Not IsEmpty(pvEndColumn) Then
+ If Not Utils._CheckArgument(pvEndColumn, 5, _AddNumeric()) Then GoTo Exit_Function
+ End If
+ If IsMissing(pvWholeWord) Then pvWholeWord = False
+ If Not Utils._CheckArgument(pvWholeWord, 6, vbBoolean) Then GoTo Exit_Function
+ If IsMissing(pvMatchCase) Then pvMatchCase = False
+ If Not Utils._CheckArgument(pvMatchCase, 7, vbBoolean) Then GoTo Exit_Function
+ If IsMissing(pvPatternSearch) Then pvPatternSearch = False
+ If Not Utils._CheckArgument(pvPatternSearch, 8, vbBoolean) Then GoTo Exit_Function
+
+ ' Initialize starting values
+ If IsEmpty(pvStartLine) Then lStartLine = 1 Else lStartLine = pvStartLine
+ If lStartLine <= 0 Or lStartLine > UBound(_Lines) + 1 Then GoTo Exit_Function
+ If IsEmpty(pvStartColumn) Then lStartColumn = 1 Else lStartColumn = pvStartColumn
+ If lStartColumn <= 0 Then GoTo Exit_Function
+ If lStartColumn > 1 And lStartColumn > Len(_Lines(lStartLine + 1)) Then GoTo Exit_Function
+ lStartPosition = _PositionOfLine(lStartline) + lStartColumn - 1
+ If IsEmpty(pvEndLine) Then lEndLine = UBound(_Lines) + 1 Else lEndLine = pvEndLine
+ If lEndLine < lStartLine Or lEndLine > UBound(_Lines) + 1 Then GoTo Exit_Function
+ If IsEmpty(pvEndColumn) Then lEndColumn = Len(_Lines(lEndLine - 1)) Else lEndColumn = pvEndColumn
+ If lEndColumn < 0 Then GoTo Exit_Function
+ If lEndColumn = 0 Then lEndColumn = 1
+ If lEndColumn > Len(_Lines(lEndLine - 1)) + 1 Then GoTo Exit_Function
+ lEndPosition = _PositionOfLine(lEndline) + lEndColumn - 1
+
+ If pvMatchCase Then
+ Set vOptions = _A2B_.SearchOptions
+ vOptions.transliterateFlags = 0
+ End If
+
+ ' Define pattern to search for
+ sPattern = pvTarget
+ ' Protect special characters in regular expressions
+ For i = 1 To Len(cstSpecialCharacters)
+ sSpecChar = Mid(cstSpecialCharacters, i, 1)
+ sPattern = Replace(sPattern, sSpecChar, "\" & sSpecChar)
+ Next i
+ If pvPatternSearch Then sPattern = Replace(Replace(sPattern, "\*", ".*"), "\?", ".")
+ If pvWholeWord Then sPattern = "\b" & sPattern & "\b"
+
+ lPosition = lStartPosition
+ sMatch = Utils._RegexSearch(_Script, sPattern, lPosition)
+ ' Re-establish default options for later searches
+ If pvMatchCase Then vOptions.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
+
+ ' Found within requested bounds ?
+ If sMatch <> "" And lPosition >= lStartPosition And lPosition <= lEndPosition Then
+ pvStartLine = _LineOfPosition(lPosition)
+ pvStartColumn = lPosition - _PositionOfLine(pvStartLine) + 1
+ pvEndLine = _LineOfPosition(lPosition + Len(sMatch) - 1)
+ If pvEndLine > pvStartLine Then
+ pvEndColumn = lPosition + Len(sMatch) - 1 - _PositionOfLine(pvEndLine)
+ Else
+ pvEndColumn = pvStartColumn + Len(sMatch) - 1
+ End If
+ bFound = True
+ End If
+
+Exit_Function:
+ Find = bFound
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+Error_Function:
+ TraceError(TRACEABORT, Err, "Module.Find", Erl)
+ bFound = False
+ GoTo Exit_Function
+End Function ' Find
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
+' Return property value of psProperty property nameREM -----------------------------------------------------------------------------------------------------------------------
+
+
+Const cstThisSub = "Module.Properties"
+
+ Utils._SetCalledSub(cstThisSub)
+ If IsMissing(pvProperty) Then Call _TraceArguments()
+ getProperty = _PropertyGet(pvProperty)
+ Utils._ResetCalledSub(cstThisSub)
+
+End Function ' getProperty
+
+REM --------------------------------Mid(a._Script, iCtl, 25)---------------------------------------------------------------------------------------
+Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
+' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
+
+Const cstThisSub = "Module.hasProperty"
+
+ Utils._SetCalledSub(cstThisSub)
+ If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+
+End Function ' hasProperty
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- PRIVATE FUNCTIONS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _BeginStatement(ByVal plStart As Long) As Long
+' Return the position in _Script of the beginning of the current statement as defined by plStart
+
+Dim sProc As String, iProc As Integer, iType As Integer
+Dim lPosition As Long, lPrevious As Long, sFind As String
+
+ sProc = ProcOfLine(_LineOfPosition(plStart), iType)
+ iProc = _FindProcIndex(sProc, iType)
+ If iProc < 0 Then lPosition = 1 Else lPosition = _ProcDecPositions(iProc)
+
+ sFind = "Any"
+ Do While lPosition < plStart And sFind <> ""
+ lPrevious = lPosition
+ sFind = _FindPattern("%^\w", lPosition)
+ If sFind = "" Then Exit Do
+ Loop
+
+ _BeginStatement = lPrevious
+
+End Function ' _EndStatement
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _EndStatement(ByVal plStart As Long) As Long
+' Return the position in _Script of the end of the current statement as defined by plStart
+' plStart is assumed not to be in the middle of a comment or a string
+
+Dim sMatch As String, lPosition As Long
+ lPosition = plStart
+ sMatch = _FindPattern("%$", lPosition)
+ _EndStatement = lPosition
+
+End Function ' _EndStatement
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _FindPattern(ByVal psPattern As Variant, Optional ByRef plStart As Long) As String
+' Find first occurrence of any of the patterns in |-delimited string psPattern
+' Special escapes
+' - for word breaks: "%B" (f.i. for searching "END%BFUNCTION")
+' - for statement start: "%^" (f.i. for searching "%^END%BFUNCTION"). Necessarily first 2 characters of pattern
+' - for statement end: "%$". Pattern should not contain anything else
+' If quoted string searched, pattern should start and end with a double quote
+' Return "" if none found, otherwise returns the matching string
+' plStart = start position of _Script to search (starts at 1)
+' In output plStart contains the first position of the matching string or is left unchanged
+' To search again the same or another pattern => plStart = plStart + Len(matching string)
+' Comments and strings are skipped
+
+' Common patterns
+Const cstComment = "('|\bREM\b)[^\n]*$"
+Const cstString = """[^""]*"""
+Const cstBeginStatement = "(^|:|\bthen\b|\belse\b|\n)[ \t]*"
+Const cstEndStatement = "[ \t]*($|:|\bthen\b|\belse\b|\n)"
+Const cstContinuation = "[ \t]_\n"
+Const cstWordBreak = "\b[ \t]+(_\n[ \t]*)?\b"
+Const cstAlt = "|"
+
+Dim sRegex As String, lStart As Long, bContinue As Boolean, sMatch As String
+Dim bEndStatement As Boolean, bQuote As Boolean
+
+ If psPattern = "%$" Then
+ sRegex = cstEndStatement
+ Else
+ sRegex = psPattern
+ If Left(psPattern, 2) = "%^" Then sRegex = cstBeginStatement & Right(sRegex, Len(sregex) - 2)
+ sregex = Replace(sregex, "%B", cstWordBreak)
+ End If
+ ' Add all to ignore patterns to regex. If pattern = quoted string do not add cstString
+ If Len(psPattern) > 2 And Left(psPattern, 1) = """" And Right(psPattern, 1) = """" Then
+ bQuote = True
+ sRegex = sRegex & cstAlt & cstComment & cstAlt & cstContinuation
+ Else
+ bQuote = False
+ sRegex = sRegex & cstAlt & cstComment & cstAlt & cstString & cstAlt & cstContinuation
+ End If
+
+ If IsMissing(plStart) Then plStart = 1
+ lStart = plStart
+
+ bContinue = True
+ Do While bContinue
+ bEndStatement = False
+ sMatch = Utils._RegexSearch(_Script, sRegex, lStart)
+ Select Case True
+ Case sMatch = ""
+ bContinue = False
+ Case Left(sMatch, 1) = "'"
+ bEndStatement = True
+ Case Left(sMatch, 1) = """"
+ If bQuote Then
+ plStart = lStart
+ bContinue = False
+ End If
+ Case Left(smatch, 1) = ":" Or Left(sMatch, 1) = vbLf
+ If psPattern = "%$" Then
+ bEndStatement = True
+ Else
+ bContinue = False
+ plStart = lStart + 1
+ sMatch = Right(sMatch, Len(sMatch) - 1)
+ End If
+ Case UCase(Left(sMatch, 3)) = "REM"
+ bEndStatement = True
+ Case UCase(Left(sMatch, 4)) = "THEN" Or UCase(Left(sMatch, 4)) = "ELSE"
+ If psPattern = "%$" Then
+ bEndStatement = True
+ Else
+ bContinue = False
+ plStart = lStart + 4
+ sMatch = Right(sMatch, Len(sMatch) - 4)
+ End If
+ Case sMatch = " _" & vbLf
+ Case Else ' Found
+ plStart = lStart
+ bContinue = False
+ End Select
+ If bEndStatement And psPattern = "%$" Then
+ bContinue = False
+ plStart = lStart - 1
+ sMatch = ""
+ End If
+ lStart = lStart + Len(sMatch)
+ Loop
+
+ _FindPattern = sMatch
+
+End Function ' _FindPattern
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _FindProcIndex(ByVal psProc As String, ByVal piType As Integer) As Integer
+' Return index of entry in _Procnames corresponding with pvProc
+
+Dim i As Integer, iIndex As Integer
+
+ If Not _ProcsParsed Then _ParseProcs
+
+ iIndex = -1
+ For i = 0 To UBound(_ProcNames)
+ If UCase(psProc) = UCase(_ProcNames(i)) And piType = _ProcTypes(i) Then
+ iIndex = i
+ Exit For
+ End If
+ Next i
+ If iIndex < 0 Then TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, Utils._CalledSub(), 0, , Array(psProc, _Name))
+
+Exit_Function:
+ _FindProcIndex = iIndex
+ Exit Function
+End Function ' _FindProcIndex
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Sub _Initialize()
+
+ _Script = Replace(_Script, vbCr, "")
+ _Lines = Split(_Script, vbLf)
+ _CountOfLines = UBound(_Lines) + 1
+
+End Sub ' _Initialize
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _LineOfPosition(ByVal plPosition) As Long
+' Return the line number of a position in _Script
+
+Dim lLine As Long, lLength As Long
+ ' Start counting from start or end depending on how close position is
+ If plPosition <= Len(_Script) / 2 Then
+ lLength = 0
+ For lLine = 0 To UBound(_Lines)
+ lLength = lLength + Len(_Lines(lLine)) + 1 ' + 1 for line feed
+ If lLength >= plPosition Then
+ _LineOfPosition = lLine + 1
+ Exit Function
+ End If
+ Next lLine
+ Else
+ If Right(_Script, 1) = vbLf Then lLength = Len(_Script) + 1 Else lLength = Len(_Script)
+ For lLine = UBound(_Lines) To 0 Step -1
+ lLength = lLength - Len(_Lines(lLine)) - 1 ' - 1 for line feed
+ If lLength <= plPosition Then
+ _LineOfPosition = lLine + 1
+ Exit Function
+ End If
+ Next lLine
+ End If
+
+End Function ' _LineOfPosition
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Sub _ParseProcs()
+' Fills the Proc arrays: name, start and end position
+' Executed at first request needing this processing
+
+Dim lPosition As Long, iProc As Integer, sDecProc As String, sEndProc As String, sNameProc As String, sType As String
+Const cstDeclaration = "%^(private%B|public%B)?\b(property%Bget|property%Blet|property%Bset|function|sub)\b"
+Const cstEnd = "%^end%B(property|function|sub)\b"
+Const cstName = "\w*" '"[A-Za-z_][A-Za-z_0-9]*"
+
+ If _ProcsParsed Then Exit Sub ' Do not redo if already done
+ _ProcNames = Array()
+ _ProcDecPositions = Array()
+ _ProcEndPositions = Array()
+ _ProcTypes = Array()
+
+ lPosition = 1
+ iProc = -1
+ sDecProc = "???"
+ Do While sDecProc <> ""
+ ' Identify Function/Sub declaration string
+ sDecProc = _FindPattern(cstDeclaration, lPosition)
+ If sDecProc <> "" Then
+ iProc = iProc + 1
+ ReDim Preserve _ProcNames(0 To iProc)
+ ReDim Preserve _ProcDecPositions(0 To iProc)
+ ReDim Preserve _ProcEndPositions(0 To iProc)
+ ReDim Preserve _ProcTypes(0 To iProc)
+ _ProcDecpositions(iProc) = lPosition
+ lPosition = lPosition + Len(sDecProc)
+ ' Identify procedure type
+ Select Case True
+ Case InStr(UCase(sDecProc), "FUNCTION") > 0 : _ProcTypes(iProc) = vbext_pk_Proc
+ Case InStr(UCase(sDecProc), "SUB") > 0 : _ProcTypes(iProc) = vbext_pk_Proc
+ Case InStr(UCase(sDecProc), "GET") > 0 : _ProcTypes(iProc) = vbext_pk_Get
+ Case InStr(UCase(sDecProc), "LET") > 0 : _ProcTypes(iProc) = vbext_pk_Let
+ Case InStr(UCase(sDecProc), "SET") > 0 : _ProcTypes(iProc) = vbext_pk_Set
+ End Select
+ ' Identify name of Function/Sub
+ sNameProc = _FindPattern(cstName, lPosition)
+ If sNameProc = "" Then Exit Do ' Should never happen
+ _ProcNames(iProc) = sNameProc
+ lPosition = lPosition + Len(sNameProc)
+ ' Identify End statement
+ sEndProc = _FindPattern(cstEnd, lPosition)
+ If sEndProc = "" Then Exit Do ' Should never happen
+ _ProcEndPositions(iProc) = lPosition
+ lPosition = lPosition + Len(sEndProc)
+ End If
+ Loop
+
+ _ProcsParsed = True
+
+End Sub
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _PositionOfLine(ByVal plLine) As Long
+' Return the position of the first character of the given line in _Script
+
+Dim lLine As Long, lPosition As Long
+ ' Start counting from start or end depending on how close line is
+ If plLine <= (UBound(_Lines) + 1) / 2 Then
+ lPosition = 0
+ For lLine = 0 To plLine - 1
+ lPosition = lPosition + 1 ' + 1 for line feed
+ If lLine < plLine - 1 Then lPosition = lPosition + Len(_Lines(lLine))
+ Next lLine
+ Else
+ lPosition = Len(_Script) + 2 ' Anticipate an ending null-string and a line feed
+ For lLine = UBound(_Lines) To plLine - 1 Step -1
+ lPosition = lPosition - Len(_Lines(lLine)) - 1 ' - 1 for line feed
+ Next lLine
+ End If
+
+ _PositionOfLine = lPosition
+
+End Function ' _LineOfPosition
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _PropertiesList() As Variant
+
+ _PropertiesList = Array("CountOfDeclarationLines", "CountOfLines", "Name", "ObjectType", "Type")
+
+End Function ' _PropertiesList
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _PropertyGet(ByVal psProperty As String) As Variant
+' Return property value of the psProperty property name
+
+Dim cstThisSub As String
+Const cstDot = "."
+
+Dim sText As String
+
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+ cstThisSub = "Module.get" & psProperty
+ Utils._SetCalledSub(cstThisSub)
+ _PropertyGet = Null
+
+ Select Case UCase(psProperty)
+ Case UCase("CountOfDeclarationLines")
+ If Not _ProcsParsed Then _ParseProcs()
+ If UBound(_ProcNames) >= 0 Then
+ _PropertyGet = ProcStartLine(_ProcNames(0), _ProcTypes(0)) - 1
+ Else
+ _PropertyGet = _CountOfLines
+ End If
+ Case UCase("CountOfLines")
+ _PropertyGet = _CountOfLines
+ Case UCase("Name")
+ _PropertyGet = _Storage & cstDot & _LibraryName & cstDot & _Name
+ Case UCase("ObjectType")
+ _PropertyGet = _Type
+ Case UCase("Type")
+ ' Find option statement before any procedure declaration
+ sText = _FindPattern("%^option%Bclassmodule\b|\bfunction\b|\bsub\b|\bproperty\b")
+ If UCase(Left(sText, 6)) = "OPTION" Then _PropertyGet = acClassModule Else _PropertyGet = acStandardModule
+ Case Else
+ Goto Trace_Error
+ End Select
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+Trace_Error:
+ TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
+ _PropertyGet = Nothing
+ Goto Exit_Function
+Error_Function:
+ TraceError(TRACEABORT, Err, "Module._PropertyGet", Erl)
+ _PropertyGet = Null
+ GoTo Exit_Function
+End Function ' _PropertyGet
+
+
+</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Root_.xba b/wizards/source/access2base/Root_.xba
index 42475c9..01f5092 100644
--- a/wizards/source/access2base/Root_.xba
+++ b/wizards/source/access2base/Root_.xba
@@ -29,7 +29,9 @@ Private DebugPrintShort As Boolean
Private Introspection As Object ' com.sun.star.beans.Introspection
Private VersionNumber As String ' Actual Access2Base version number
Private Locale As String
+Private ExcludeA2B As Boolean
Private TextSearch As Object
+Private SearchOptions As Variant
Private FindRecord As Object
Private StatusBar As Object
Private Dialogs As Object ' Collection
@@ -51,8 +53,15 @@ Dim vCurrentDoc() As Variant
CalledSub = ""
DebugPrintShort = True
Locale = L10N._GetLocale()
+ ExcludeA2B = True
Set Introspection = CreateUnoService("com.sun.star.beans.Introspection")
Set TextSearch = CreateUnoService("com.sun.star.util.TextSearch")
+ SearchOptions = New com.sun.star.util.SearchOptions
+ With SearchOptions
+ .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
+ .searchFlag = 0
+ .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
+ End With
Set FindRecord = Nothing
Set StatusBar = Nothing
Set Dialogs = New Collection
diff --git a/wizards/source/access2base/Test.xba b/wizards/source/access2base/Test.xba
index b69d93f..bada744 100644
--- a/wizards/source/access2base/Test.xba
+++ b/wizards/source/access2base/Test.xba
@@ -4,6 +4,10 @@
'Option Compatible
Sub Main
+Dim a, b()
+ _ErrorHandler(False)
+ TraceConsole()
+ exit sub
End Sub
</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
index 6028df4..6685078 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -913,9 +913,10 @@ Error_Function:
End Function ' _ReadFileIntoArray V1.4.0
REM -----------------------------------------------------------------------------------------------------------------------
-Function _RegexSearch(ByRef psString As String _
+Public Function _RegexSearch(ByRef psString As String _
, ByVal psRegex As String _
, Optional ByRef plStart As Long _
+ , Optional ByVal bForward As Boolean _
) As String
' Search is not case-sensitive
' Return "" if regex not found, otherwise returns the matching string
@@ -924,26 +925,35 @@ Function _RegexSearch(ByRef psString As String _
' To search again the same or another pattern => plStart = plStart + Len(matching string)
Dim oTextSearch As Object
-Dim vOptions As New com.sun.star.util.SearchOptions, vResult As Object
-Dim lEnd As Long
+Dim vOptions As Variant 'com.sun.star.util.SearchOptions
+Dim lEnd As Long, vResult As Object
_RegexSearch = ""
Set oTextSearch = _A2B_.TextSearch ' UNO XTextSearch service
- With vOptions
- .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
- .searchFlag = 0
- .searchString = psRegex ' Pattern to be searched
- .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
- End With
+ vOptions = _A2B_.SearchOptions
+ vOptions.searchString = psRegex ' Pattern to be searched
oTextSearch.setOptions(vOptions)
If IsMissing(plStart) Then plStart = 1
- If plStart <= 0 Then Exit Function
- lEnd = Len(psString)
- vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd)
+ If plStart <= 0 Or plStart > Len(psString) Then Exit Function
+ If IsMissing(bForWard) Then bForward = True
+ If bForward Then
+ lEnd = Len(psString)
+ vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd)
+ Else
+ lEnd = 1
+ vResult = oTextSearch.searchForward(psString, plStart, lEnd - 1)
+ End If
With vResult
If .subRegExpressions >= 1 Then
- plStart = .startOffset(0) + 1
- lEnd = .endOffset(0) + 1
+ ' http://www.openoffice.org/api/docs/common/ref/com/sun/star/util/SearchResult.html
+ Select Case bForward
+ Case True
+ plStart = .startOffset(0) + 1
+ lEnd = .endOffset(0) + 1
+ Case False
+ plStart = .endOffset(0) + 1
+ lEnd = .startOffset(0)
+ End Select
_RegexSearch = Mid(psString, plStart, lEnd - plStart)
Else
plStart = 0
@@ -953,7 +963,7 @@ Dim lEnd As Long
End Function
REM -----------------------------------------------------------------------------------------------------------------------
-Function _RegisterEventScript(poObject As Object _
+Public Function _RegisterEventScript(poObject As Object _
, ByVal psEvent As String _
, ByVal psListener As String _
, ByVal psScriptCode As String _
@@ -1061,12 +1071,12 @@ End Function ' Surround
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Trim(ByVal psString As String) As String
-' Remove leading and trailing spaces, remove surrounding square brackets
+' Remove leading and trailing spaces, remove surrounding square brackets, replace tabs by spaces
Const cstSquareOpen = "["
Const cstSquareClose = "]"
Dim sTrim As String
- sTrim = Trim(psString)
+ sTrim = Trim(Replace(psString, vbTab, " "))
_Trim = sTrim
If Len(sTrim) <= 2 Then Exit Function
diff --git a/wizards/source/access2base/acConstants.xba b/wizards/source/access2base/acConstants.xba
index a7dcda8..e382996 100644
--- a/wizards/source/access2base/acConstants.xba
+++ b/wizards/source/access2base/acConstants.xba
@@ -385,11 +385,26 @@ Global Const msoBarTypeFloater = 12 ' Floating window
Global Const msoControlButton = 1 ' Command button
Global Const msoControlPopup = 10 ' Popup, submenu
-REM New Line
+REM New Lines
REM -----------------------------------------------------------------
+Public Function vbCr() As String : vbCr = Chr(13) : End Function
+Public Function vbLf() As String : vbLf = Chr(10) : End Function
Public Function vbNewLine() As String
Const cstWindows = 1
- If GetGuiType() = cstWindows Then vbNewLine = Chr(13) & Chr(10) Else vbNewLine = Chr(10)
+ If GetGuiType() = cstWindows Then vbNewLine = vbCR & vbLF Else vbNewLine = vbLF
End Function ' vbNewLine V1.4.0
+Public Function vbTab() As String : vbTab = Chr(9) : End Function
+
+REM Module types
+REM -----------------------------------------------------------------
+Global Const acClassModule = 1
+Global Const acStandardModule = 0
+
+REM (Module) procedure types
+REM -----------------------------------------------------------------
+Global Const vbext_pk_Get = 1 ' A Property Get procedure
+Global Const vbext_pk_Let = 2 ' A Property Let procedure
+Global Const vbext_pk_Proc = 0 ' A Sub or Function procedure
+Global Const vbext_pk_Set = 3 ' A Property Set procedure
</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/script.xlb b/wizards/source/access2base/script.xlb
index 67000bc..a3e5c78 100644
--- a/wizards/source/access2base/script.xlb
+++ b/wizards/source/access2base/script.xlb
@@ -30,4 +30,5 @@
<library:element library:name="UtilProperty"/>
<library:element library:name="CommandBar"/>
<library:element library:name="CommandBarControl"/>
+ <library:element library:name="Module"/>
</library:library>
\ No newline at end of file
commit 9017bcc76bd27b97c065dacf511f7fcdfe3060cb
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sat Dec 3 14:11:05 2016 +0100
Access2Base - Reorder functions in Database module
Change-Id: I62fb5d0722363fdcd7d464d0490b1f6e890221a4
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba
index 405eb65..01c56a7 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -1221,6 +1221,14 @@ Const cstSQLITE = "SQLite"
End Sub ' _LoadMetadata V1.6.0
REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _OutputBinaryToHTML() As String
+' Converts Binary value to HTML compatible string
+
+ _OutputBinaryToHTML = " "
+
+End Function ' _OutputBinaryToHTML V1.4.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
' Converts input boolean value to HTML compatible string
@@ -1369,14 +1377,6 @@ Error_Function:
End Function ' _OutputDataToHTML V1.4.0
REM -----------------------------------------------------------------------------------------------------------------------
-Private Function _OutputBinaryToHTML() As String
-' Converts Binary value to HTML compatible string
-
- _OutputBinaryToHTML = " "
-
-End Function ' _OutputBinaryToHTML V1.4.0
-
-REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputDateToHTML(ByVal psDate As Date) As String
' Converts input date to HTML compatible string
commit fa69125cb0239ee9660481fbe2f3200f1d0c53fd
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sat Dec 3 13:00:52 2016 +0100
Access2Base - Review UtilProperty module
Insert dates and 2-dim arrays in property values
Export array or property values to string for file or database temporary storage
Reimport from string into array or property values
(for later use)
Change-Id: I7f2dc2ad6adde6249e68a6cb51b52e2a4dad79b7
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba
index 72445e0..405eb65 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -1322,6 +1322,8 @@ Const cstMaxRows = 200
If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, "lastcol")
If Not vFieldsBin(i) Then
If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j)
+ If vDataCell Is Nothing Then vDataCell = Null ' Necessary because Null object has not a VarType = vbNull
+ If IsDate(vDataCell) And VarType(vDataCell) = vbString Then vDataCell = CDate(vDataCell)
Select Case VarType(vDataCell)
Case vbEmpty, vbNull
vTdClass() = _AddArray(vTdClass, "null")
diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba
index 0f7be5b..81061bd 100644
--- a/wizards/source/access2base/Recordset.xba
+++ b/wizards/source/access2base/Recordset.xba
@@ -581,11 +581,13 @@ Const cstThisSub = "Recordset.getProperty"
End Function ' getProperty
REM -----------------------------------------------------------------------------------------------------------------------
-Public Function GetRows(ByVal Optional pvNumRows As variant) As Variant
+Public Function GetRows(ByVal Optional pvNumRows As variant, ByVal Optional pbStrDate As Boolean) As Variant
+' UNPUBLISHED - pbStrDate = True forces all dates to be converted into strings
If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Recordset.GetRows"
Utils._SetCalledSub(cstThisSub)
+ If IsMissing(pbStrDate) Then pbStrDate = False
Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer
vMatrix() = Array()
@@ -609,6 +611,7 @@ Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer
lSize = lSize + 1
For i = 0 To iNumFields
vMatrix(i, lSize) = _getResultSetColumnValue(RowSet, i + 1)
+ If pbStrDate And IsDate(vMatrix(i, lSize)) Then vMatrix(i, lSize) = _CStr(vMatrix(i, lSize))
Next i
_Move("NEXT")
Loop
diff --git a/wizards/source/access2base/UtilProperty.xba b/wizards/source/access2base/UtilProperty.xba
index 6fbe105..96e0955 100644
--- a/wizards/source/access2base/UtilProperty.xba
+++ b/wizards/source/access2base/UtilProperty.xba
@@ -22,24 +22,32 @@ REM ============================================================================
' Change Log
' Danny Brewer Revised 2004-02-25-01
' Jean-Pierre Ledure Adapted to Access2Base coding conventions
+' PropValuesToStr rewritten and addition of StrToPropValues
+' Bug corrected on date values
+' Addition of support of 2-dimensional arrays
'**********************************************************************
Option Explicit
+Private Const cstHEADER = "### PROPERTYVALUES ###"
+
REM =======================================================================================================================
Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue
' Create and return a new com.sun.star.beans.PropertyValue.
-Dim oPropertyValue As Object
- Set oPropertyValue = createUnoStruct( "com.sun.star.beans.PropertyValue" )
+Dim oPropertyValue As New com.sun.star.beans.PropertyValue
+
If Not IsMissing(psName) Then oPropertyValue.Name = psName
- If Not IsMissing(pvValue) Then oPropertyValue.Value = pvValue
+ If Not IsMissing(pvValue) Then
+ ' Date BASIC variables give error. Change them to strings
+ If VarType(pvValue) = vbDate Then oPropertyValue.Value = Utils._CStr(pvValue, False) Else oPropertyValue.Value = pvValue
+ End If
_MakePropertyValue() = oPropertyValue
End Function ' _MakePropertyValue V1.3.0
REM =======================================================================================================================
-Public Function _NumPropertyValues(pvPropertyValuesArray As Variant) As Integer
+Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer
' Return the number of PropertyValue's in an array.
' Parameters:
' pvPropertyValuesArray - an array of PropertyValue's, that is an array of com.sun.star.beans.PropertyValue.
@@ -52,7 +60,7 @@ Dim iNumProperties As Integer
End Function ' _NumPropertyValues V1.3.0
REM =======================================================================================================================
-Public Function _FindPropertyIndex(pvPropertyValuesArray, ByVal psPropName As String ) As Integer
+Public Function _FindPropertyIndex(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String ) As Integer
' Find a particular named property from an array of PropertyValue's.
' Finds the index in the array of PropertyValue's and returns it, or returns -1 if it was not found.
@@ -70,7 +78,7 @@ Dim iNumProperties As Integer, i As Integer, vProp As Variant
End Function ' _FindPropertyIndex V1.3.0
REM =======================================================================================================================
-Public Function _FindProperty(pvPropertyValuesArray, ByVal psPropName As String) As com.sun.star.beans.PropertyValue
+Public Function _FindProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) As com.sun.star.beans.PropertyValue
' Find a particular named property from an array of PropertyValue's.
' Finds the PropertyValue and returns it, or returns Null if not found.
@@ -84,43 +92,59 @@ Dim iPropIndex As Integer, vProp As Variant
End Function ' _FindProperty V1.3.0
REM =======================================================================================================================
-Function _GetPropertyValue(pvPropertyValuesArray, ByVal psPropName As String, Optional pvDefaultValue) As Variant
+Public Function _GetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, Optional pvDefaultValue) As Variant
' Get the value of a particular named property from an array of PropertyValue's.
' vDefaultValue - This value is returned if the property is not found in the array.
-Dim iPropIndex As Integer, vProp As Variant, vValue As Variant
+Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Variant, i As Integer, j As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
vValue = vProp.Value ' get the value from the PropertyValue
- _GetPropertyValue() = vValue
+ If IsArray(vValue) Then
+ If IsArray(vValue(0)) Then ' Array of arrays
+ vMatrix = Array()
+ ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0)))
+ For i = 0 To UBound(vValue)
+ For j = 0 To UBound(vValue(0))
+ vMatrix(i, j) = vValue(i)(j)
+ Next j
+ Next i
+ _GetPropertyValue() = vMatrix
+ Else
+ _GetPropertyValue() = vValue ' Simple vector OK
+ End If
+ Else
+ _GetPropertyValue() = vValue
+ End If
Else
If IsMissing(pvDefaultValue) Then pvDefaultValue = Null
_GetPropertyValue() = pvDefaultValue
EndIf
+
End Function ' _GetPropertyValue V1.3.0
REM =======================================================================================================================
-Sub _SetPropertyValue(pvPropertyValuesArray, ByVal psPropName As String, ByVal pvValue)
+Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue)
' Set the value of a particular named property from an array of PropertyValue's.
Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer
+
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
- ' Did we find it?
If iPropIndex >= 0 Then
- ' Found, the PropertyValue is already in the array. Just modify its value.
+ ' Found, the PropertyValue is already in the array. Just modify its value.
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
vProp.Value = pvValue ' set the property value.
pvPropertyValuesArray(iPropIndex) = vProp ' put it back into array
Else
- ' Not found, the array contains no PropertyValue with this name. Append new element to array.
+ ' Not found, the array contains no PropertyValue with this name. Append new element to array.
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
If iNumProperties = 0 Then
pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue))
Else
- ' Make array larger.
+ ' Make array larger.
Redim Preserve pvPropertyValuesArray(iNumProperties)
- ' Assign new PropertyValue
+ ' Assign new PropertyValue
pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue)
EndIf
EndIf
@@ -128,17 +152,17 @@ Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer
End Sub ' _SetPropertyValue V1.3.0
REM =======================================================================================================================
-Sub _DeleteProperty(pvPropertyValuesArray, ByVal psPropName As String)
+Public Sub _DeleteProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String)
' Delete a particular named property from an array of PropertyValue's.
Dim iPropIndex As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
- _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex)
+ If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex)
End Sub ' _DeletePropertyValue V1.3.0
REM =======================================================================================================================
-Public Sub _DeleteIndexedProperty(pvPropertyValuesArray, ByVal piPropIndex As Integer)
+Public Sub _DeleteIndexedProperty(ByRef pvPropertyValuesArray As Variant, ByVal piPropIndex As Integer)
' Delete a particular indexed property from an array of PropertyValue's.
Dim iNumProperties As Integer, i As Integer
@@ -146,40 +170,139 @@ Dim iNumProperties As Integer, i As Integer
' Did we find it?
If piPropIndex < 0 Then
- ' Do nothing
+ ' Do nothing
ElseIf iNumProperties = 1 Then
- ' Just return a new empty array
+ ' Just return a new empty array
pvPropertyValuesArray = Array()
Else
- ' If it is NOT the last item in the array, then shift other elements down into it's position.
+ ' If it is NOT the last item in the array, then shift other elements down into it's position.
If piPropIndex < iNumProperties - 1 Then
- ' Bump items down lower in the array.
+ ' Bump items down lower in the array.
For i = piPropIndex To iNumProperties - 2
pvPropertyValuesArray(i) = pvPropertyValuesArray(i + 1)
Next i
EndIf
- ' Redimension the array to have one fewer element.
+ ' Redimension the array to have one fewer element.
Redim Preserve pvPropertyValuesArray(iNumProperties - 2)
EndIf
End Sub ' _DeleteIndexedProperty V1.3.0
REM =======================================================================================================================
-Public Function _PropValuesToStr(pvPropertyValuesArray) As String
-' Convenience function to return a string which explains what PropertyValue's are in the array of PropertyValue's.
+Public Function _PropValuesToStr(ByRef pvPropertyValuesArray As Variant) As String
+' Return a string with dumped content of the array of PropertyValue's.
+' SYNTAX:
+' NameOfProperty = This is a string (or 12 or 2016-12-31 12:05 or 123.45 or -0.12E-05 ...)
+' NameOfArray = (10)
+' 1;2;3;4;5;6;7;8;9;10
+' NameOfMatrix = (2,10)
+' 1;2;3;4;5;6;7;8;9;10
+' A;B;C;D;E;F;G;H;I;J
+' Semicolons and backslashes are escaped with a backslash (see _CStr and _CVar functions)
+
+Dim iNumProperties As Integer, sResult As String, i As Integer, j As Integer, vProp As Variant
+Dim sName As String, vValue As Variant, iType As Integer, vVector As Variant
+Dim cstLF As String
-Dim iNumProperties As Integer, sResult As String, i As Integer, vProp As Variant
-Dim sName As String, vValue As Variant
+ cstLF = Chr(10)
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
- sResult = Cstr(iNumProperties) & " Properties:"
+ sResult = cstHEADER & cstLF
For i = 0 To iNumProperties - 1
vProp = pvPropertyValuesArray(i)
sName = vProp.Name
vValue = vProp.Value
- sResult = sResult & Chr(13) & " " & sName & " = " & _CStr(vValue)
+ iType = VarType(vValue)
+ Select Case iType
+ Case < vbArray ' Scalar
+ sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF
+ Case Else ' Vector or matrix
+ ' 1-dimension but vector of vectors must also be considered
+ If VarType(vValue(0)) >= vbArray Then
+ sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF
+ vVector = Array()
+ ReDim vVector(0 To UBound(vValue(0)))
+ For j = 0 To UBound(vValue)
+ sResult = sResult & Utils._CStr(vValue(j), False) & cstLF
+ Next j
+ Else
+ sResult = sResult & sName & " = (" & UBound(vValue, 1) + 1 & ")" & cstLF
+ sResult = sResult & Utils._CStr(vValue, False) & cstLF
+ End If
+ End Select
Next i
- _PropValuesToStr() = sResult
+
+ _PropValuesToStr() = Left(sResult, Len(sResult) - 1) ' Remove last LF
End Function ' _PropValuesToStr V1.3.0
+
+REM =======================================================================================================================
+Public Function _StrToPropValues(psString) As Variant
+' Return an array of PropertyValue's rebuilt from the string parameter
+
+Dim vString() As Variant, i As Integer,iArray As Integer, iRows As Integer, iCols As Integer
+Dim lPosition As Long, sName As String, vValue As Variant, vResult As Variant, sDim As String
+Dim lSearch As Long
+Dim cstLF As String
+Const cstEqualArray = " = (", cstEqual = " = "
+
+ cstLF = Chr(10)
+ _StrToPropValues = Array()
+ vResult = Array()
+
+ If psString = "" Then Exit Function
+ vString = Split(psString, cstLF)
+ If UBound(vString) <= 0 Then Exit Function ' There must be at least one name-value pair
+ If vString(0) <> cstHEADER Then Exit Function ' Check origin
+
+ iArray = -1
+ For i = 1 To UBound(vString)
+ If vString(i) <> "" Then ' Skip empty lines
+ If iArray < 0 Then ' Not busy with array row
+ lPosition = 1
+ sName = Utils._RegexSearch(vString(i), "^\b\w+\b", lPosition) ' Identifier
+ If sName = "" Then Exit Function
+ If InStr(vString(i), cstEqualArray) = lPosition + Len(sName) Then ' Start array processing
+ lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
+ sDim = Utils._RegexSearch(vString(i), "\([0-9]+\)", lSearch) ' e.g. (10)
+ If sDim <> "" Then
+ iCols = CInt(Mid(sDim, 2, Len(sDim) - 2)
+ iRows = 0
+ ReDim vValue(0 To iCols - 1)
+ Else
+ lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
+ sDim = Utils._RegexSearch(vString(i), "\([0-9]+,", lSearch) ' e.g. (10,
+ iRows = CInt(Mid(sDim, 2, Len(sDim) - 2)
+ sDim = Utils._RegexSearch(vString(i), ",[0-9]+\)", lSearch) ' e.g. ,20)
+ iCols = CInt(Mid(sDim, 2, Len(sDim) - 2)
+ ReDim vValue(0 To iRows - 1)
+ End If
+ iArray = 0
+ ElseIf InStr(vString(i), cstEqual) = lPosition + Len(sName) Then
+ vValue = Utils._CVar(Mid(vString(i), Len(sName) + Len(cstEqual) + 1))
+ _SetPropertyValue(vResult, sName, vValue)
+ Else
+ Exit Function
+ End If
+ Else ' Line is an array row
+ If iRows = 0 Then
+ vValue = Utils._CVar(vString(i), True) ' Keep dates as strings
+ iArray = -1
+ _SetPropertyValue(vResult, sName, vValue)
+ Else
+ vValue(iArray) = Utils._CVar(vString(i), True)
+ If iArray < iRows - 1 Then
+ iArray = iArray + 1
+ Else
+ iArray = -1
+ _SetPropertyValue(vResult, sName, vValue)
+ End If
+ End If
+ End If
+ End If
+ Next i
+
+ _StrToPropValues = vResult
+
+End Function
</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
index 583348b..6028df4 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -146,7 +146,7 @@ Const cstByteLength = 25
sArg = "[ARRAY]"
Else ' One-dimension arrays only
For i = LBound(pvArg) To UBound(pvArg)
- sArg = sArg & Utils._CStr(pvArg(i)) & ";" ' Recursive call
+ sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call
Next i
If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1)
End If
@@ -205,10 +205,11 @@ Const cstByteLength = 25
End Function ' CStr V0.9.5
REM -----------------------------------------------------------------------------------------------------------------------
-Public Function _CVar(ByRef psArg As String) As Variant
+Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant
' psArg is presumed an output of _CStr (stored in the mean time in a text file f.i.)
' _CVar returns the corresponding original variant variable or Null/Nothing if not possible
' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty
+' pbStrDate = True keeps dates as strings
Dim cstEscape1 As String, cstEscape2 As String, vEMPTY As Variant
cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\
@@ -218,6 +219,7 @@ Dim cstEscape1 As String, cstEscape2 As String, vEMPTY As Variant
If Len(psArg) = 0 Then Exit Function
Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
+ If IsMissing(pbStrDate) Then pbStrDate = False
sArg = Replace( _
Replace( _
Replace( _
@@ -232,7 +234,7 @@ Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
vVars = Array()
Redim vVars(LBound(vArgs) To UBound(vArgs))
For i = LBound(vVars) To UBound(vVars)
- vVars(i) = _CVar(vArgs(i))
+ vVars(i) = _CVar(vArgs(i), pbStrDate)
Next i
_CVar = vVars
Exit Function
@@ -245,14 +247,15 @@ Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
Case sArg = "[OBJECT]" : _CVar = Nothing
Case sArg = "[TRUE]" : _CVar = True
Case sArg = "[FALSE]" : _CVar = False
- Case IsDate(sArg) : _CVar = CDate(sArg)
+ Case IsDate(sArg)
+ If pbStrDate Then _CVar = sArg Else _CVar = CDate(sArg)
Case IsNumeric(sArg)
If InStr(sArg, ".") > 0 Then
_CVar = Val(sArg)
Else
_CVar = CLng(Val(sArg)) ' Val always returns a double
End If
- Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$" <> ""
+ Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+(e[-+]?[0-9]+)?$") <> ""
_CVar = Val(sArg) ' Scientific notation
Case Else : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";")
End Select
@@ -914,6 +917,7 @@ Function _RegexSearch(ByRef psString As String _
, ByVal psRegex As String _
, Optional ByRef plStart As Long _
) As String
+' Search is not case-sensitive
' Return "" if regex not found, otherwise returns the matching string
' plStart = start position of psString to search (starts at 1)
' In output plStart contains the first position of the matching string
@@ -929,9 +933,11 @@ Dim lEnd As Long
.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
.searchFlag = 0
.searchString = psRegex ' Pattern to be searched
+ .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
End With
oTextSearch.setOptions(vOptions)
If IsMissing(plStart) Then plStart = 1
+ If plStart <= 0 Then Exit Function
lEnd = Len(psString)
vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd)
With vResult
@@ -939,6 +945,8 @@ Dim lEnd As Long
plStart = .startOffset(0) + 1
lEnd = .endOffset(0) + 1
_RegexSearch = Mid(psString, plStart, lEnd - plStart)
+ Else
+ plStart = 0
End If
End With
commit 047d1ed3df0d5714574ebc8e278cca11f96d490b
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Thu Dec 1 16:10:54 2016 +0100
Access2Base - Implement regex search
Based on XTextSearch UNO service
_CStr also refined
Change-Id: Ibeceeeb549511e575c6842e43e5a76c8308db1aa
diff --git a/wizards/source/access2base/Root_.xba b/wizards/source/access2base/Root_.xba
index 3aceacd..42475c9 100644
--- a/wizards/source/access2base/Root_.xba
+++ b/wizards/source/access2base/Root_.xba
@@ -29,6 +29,7 @@ Private DebugPrintShort As Boolean
Private Introspection As Object ' com.sun.star.beans.Introspection
Private VersionNumber As String ' Actual Access2Base version number
Private Locale As String
+Private TextSearch As Object
Private FindRecord As Object
Private StatusBar As Object
Private Dialogs As Object ' Collection
@@ -51,6 +52,7 @@ Dim vCurrentDoc() As Variant
DebugPrintShort = True
Locale = L10N._GetLocale()
Set Introspection = CreateUnoService("com.sun.star.beans.Introspection")
+ Set TextSearch = CreateUnoService("com.sun.star.util.TextSearch")
Set FindRecord = Nothing
Set StatusBar = Nothing
Set Dialogs = New Collection
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
index 8514d95..583348b 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -127,7 +127,7 @@ End Function ' CheckArgument V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
' Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
-' pvArg may be a byte-array. Other arrays are rejected
+' pvArg may be a byte-array. Other arrays are processed recursively into a semicolon separated string
Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long
Const cstLength = 50
@@ -174,9 +174,17 @@ Const cstByteLength = 25
End If
Case vbVariant : sArg = "[VARIANT]"
Case vbString
- ' Replace CR + LF by \n
+ ' Replace CR + LF by \n and HT by \t
' Replace semicolon by \; to allow semicolon separated rows
- sArg = Replace(Replace(Replace(pvArg, Chr(13), ""), Chr(10), "\n"), ";", "\;")
+ sArg = Replace( _
+ Replace( _
+ Replace( _
+ Replace( _
+ Replace(pvArg, "\", "\\") _
+ , Chr(13), "") _
+ , Chr(10), "\n") _
+ , Chr(9), "\t") _
+ , ";", "\;")
Case vbBoolean : sArg = Iif(pvArg, "[TRUE]", "[FALSE]")
Case vbByte : sArg = Right("00" & Hex(pvArg), 2)
Case vbSingle, vbDouble, vbCurrency
@@ -197,6 +205,61 @@ Const cstByteLength = 25
End Function ' CStr V0.9.5
REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _CVar(ByRef psArg As String) As Variant
+' psArg is presumed an output of _CStr (stored in the mean time in a text file f.i.)
+' _CVar returns the corresponding original variant variable or Null/Nothing if not possible
+' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty
+
+Dim cstEscape1 As String, cstEscape2 As String, vEMPTY As Variant
+ cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\
+ cstEscape2 = Chr(27) ' ESC used as temporary escape character for \;
+
+ _CVar = ""
+ If Len(psArg) = 0 Then Exit Function
+
+Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
+ sArg = Replace( _
+ Replace( _
+ Replace( _
+ Replace(psArg, "\\", cstEscape1) _
+ , "\;", cstEscape2) _
+ , "\n", Chr(10)) _
+ , "\t", Chr(9))
+
+ ' Semicolon separated string
+ vArgs = Split(sArg, ";")
+ If UBound(vArgs) > LBound(vArgs) Then ' Process each item recursively
+ vVars = Array()
+ Redim vVars(LBound(vArgs) To UBound(vArgs))
+ For i = LBound(vVars) To UBound(vVars)
+ vVars(i) = _CVar(vArgs(i))
+ Next i
+ _CVar = vVars
+ Exit Function
+ End If
+
+ ' Usual case
+ Select Case True
+ Case sArg = "[EMPTY]" : _CVar = vEMPTY
+ Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null
+ Case sArg = "[OBJECT]" : _CVar = Nothing
+ Case sArg = "[TRUE]" : _CVar = True
+ Case sArg = "[FALSE]" : _CVar = False
... etc. - the rest is truncated
More information about the Libreoffice-commits
mailing list