diff options
Diffstat (limited to 'wizards/source/access2base')
35 files changed, 24938 insertions, 0 deletions
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba new file mode 100644 index 000000000..224cc394a --- /dev/null +++ b/wizards/source/access2base/Application.xba @@ -0,0 +1,1869 @@ +<?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="Application" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const TRACEDEBUG = "DEBUG" ' To report values of variables +Global Const TRACEINFO = "INFO" ' To report any event +Global Const TRACEWARNING = "WARNING" ' To report some abnormal event +Global Const TRACEERRORS = "ERROR" ' To report user errors - Default value +Global Const TRACEFATAL = "FATAL" ' To report programmer errors - f.i. Wrong argument +Global Const TRACEABORT = "ABORT" ' To report Access2Base internal errors +Global Const TRACEANY = "===>" ' Always reported + ' ERRORs, FATALs and ABORTs are also displayed in a MsgBox (except on specific request) + ' FATALs and ABORTs interrupt the program execution + +Global Const ERRINIT = 1500 +Global Const ERRDBNOTCONNECTED = 1501 +Global Const ERRMISSINGARGUMENTS = 1502 +Global Const ERRWRONGARGUMENT = 1503 +Global Const ERRMAINFORM = 1504 +Global Const ERRMETHOD = 1505 +Global Const ERRFILEACCESS = 1506 +Global Const ERRFORMNOTIDENTIFIED = 1507 +Global Const ERRFORMNOTFOUND = 1508 +Global Const ERRFORMNOTOPEN = 1509 +Global Const ERRDFUNCTION = 1510 +Global Const ERROPENFORM = 1511 +Global Const ERRPROPERTY = 1512 +Global Const ERRPROPERTYVALUE = 1513 +Global Const ERRINDEXVALUE = 1514 +Global Const ERRCOLLECTION = 1515 +Global Const ERRPROPERTYNOTARRAY = 1516 +Global Const ERRCONTROLNOTFOUND = 1517 +Global Const ERRNOACTIVEFORM = 1518 +Global Const ERRDATABASEFORM = 1519 +Global Const ERRFOCUSINGRID = 1520 +Global Const ERRNOGRIDINFORM = 1521 +Global Const ERRFINDRECORD = 1522 +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 +Global Const ERRPROPERTYINIT = 1531 +Global Const ERRFILENOTCREATED = 1532 +Global Const ERRDIALOGNOTFOUND = 1533 +Global Const ERRDIALOGUNDEFINED = 1534 +Global Const ERRDIALOGSTARTED = 1535 +Global Const ERRDIALOGNOTSTARTED = 1536 +Global Const ERRRECORDSETNODATA = 1537 +Global Const ERRRECORDSETCLOSED = 1538 +Global Const ERRRECORDSETRANGE = 1539 +Global Const ERRRECORDSETFORWARD = 1540 +Global Const ERRFIELDNULL = 1541 +Global Const ERROVERFLOW = 1542 +Global Const ERRNOTACTIONQUERY = 1543 +Global Const ERRNOTUPDATABLE = 1544 +Global Const ERRUPDATESEQUENCE = 1545 +Global Const ERRNOTNULLABLE = 1546 +Global Const ERRROWDELETED = 1547 +Global Const ERRRECORDSETCLONE = 1548 +Global Const ERRQUERYDEFDELETED = 1549 +Global Const ERRTABLEDEFDELETED = 1550 +Global Const ERRTABLECREATION = 1551 +Global Const ERRFIELDCREATION = 1552 +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) +Global Const DBCONNECTFORM = 2 ' Connection from a database-aware form (OpenConnection) +Global Const DBCONNECTANY = 3 ' Connection from any document for data access only (OpenDatabase) + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const DBMS_UNKNOWN = 0 +Global Const DBMS_HSQLDB1 = 1 +Global Const DBMS_HSQLDB2 = 2 +Global Const DBMS_FIREBIRD = 3 +Global Const DBMS_MSACCESS2003 = 4 +Global Const DBMS_MSACCESS2007 = 5 +Global Const DBMS_MYSQL = 6 +Global Const DBMS_POSTGRES = 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" +Global Const COLLFORMS = "FORMS" +Global Const COLLFIELDS = "FIELDS" +Global Const COLLPROPERTIES = "PROPERTIES" +Global Const COLLQUERYDEFS = "QUERYDEFS" +Global Const COLLRECORDSETS = "RECORDSETS" +Global Const COLLTABLEDEFS = "TABLEDEFS" +Global Const COLLTEMPVARS = "TEMPVARS" + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const OBJAPPLICATION = "APPLICATION" +Global Const OBJCOLLECTION = "COLLECTION" +Global Const OBJCOMMANDBAR = "COMMANDBAR" +Global Const OBJCOMMANDBARCONTROL = "COMMANDBARCONTROL" +Global Const OBJCONTROL = "CONTROL" +Global Const OBJDATABASE = "DATABASE" +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" +Global Const OBJRECORDSET = "RECORDSET" +Global Const OBJSUBFORM = "SUBFORM" +Global Const OBJTABLEDEF = "TABLEDEF" +Global Const OBJTEMPVAR = "TEMPVAR" + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const CTLCONTROL = "CONTROL" ' ClassId +Global Const CTLCHECKBOX = "CHECKBOX" ' 5 +Global Const CTLCOMBOBOX = "COMBOBOX" ' 7 +Global Const CTLCOMMANDBUTTON = "COMMANDBUTTON" ' 2 +Global Const CTLCURRENCYFIELD = "CURRENCYFIELD" ' 18 +Global Const CTLDATEFIELD = "DATEFIELD" ' 15 +Global Const CTLFILECONTROL = "FILECONTROL" ' 12 +Global Const CTLFIXEDTEXT = "FIXEDTEXT" ' 10 +Global Const CTLGRIDCONTROL = "GRIDCONTROL" ' 11 +Global Const CTLGROUPBOX = "GROUPBOX" ' 8 +Global Const CTLHIDDENCONTROL = "HIDDENCONTROL" ' 13 +Global Const CTLIMAGEBUTTON = "IMAGEBUTTON" ' 4 +Global Const CTLIMAGECONTROL = "IMAGECONTROL" ' 14 +Global Const CTLLISTBOX = "LISTBOX" ' 6 +Global Const CTLNAVIGATIONBAR = "NAVIGATIONBAR" ' 22 +Global Const CTLNUMERICFIELD = "NUMERICFIELD" ' 17 +Global Const CTLPATTERNFIELD = "PATTERNFIELD" ' 19 +Global Const CTLRADIOBUTTON = "RADIOBUTTON" ' 3 +Global Const CTLSCROLLBAR = "SCROLLBAR" ' 20 +Global Const CTLSPINBUTTON = "SPINBUTTON" ' 21 +Global Const CTLTEXTFIELD = "TEXTFIELD" ' 9 +Global Const CTLTIMEFIELD = "TIMEFIELD" ' 16 +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const CTLFORMATTEDFIELD = "FORMATTEDFIELD" ' 9 (idem TextField) +Global Const CTLFIXEDLINE = "FIXEDLINE" ' 24 (forced) +Global Const CTLPROGRESSBAR = "PROGRESSBAR" ' 23 (forced) +Global Const CTLSUBFORM = "SUBFORMCONTROL" ' None +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const CTLPARENTISFORM = "FORM" +Global Const CTLPARENTISDIALOG = "DIALOG" +Global Const CTLPARENTISSUBFORM = "SUBFORM" +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 + DbConnect As Integer ' DBCONNECTxxx constants + URL As String + DbContainers() As Variant ' One entry by (data-aware) form +End Type + +Type DbContainer + FormName As String ' name of data-aware form + Database As Object ' Database type +End Type + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- Next variable is initialized to empty at each macro execution start --- +REM --- Items in both lists correspond one by one --- +Public vFormNamesList As Variant ' (0) Buffer of hierarchical form names => "\;" separated values + ' (1) Buffer of persistent form names => "\;" separated values + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AllDialogs(ByVal Optional pvIndex As Variant) As Variant +' Return either a Collection or a Dialog object +' The dialogs are selected only if library is loaded + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "AllDialogs" + Utils._SetCalledSub(cstThisSub) + +Dim iMode As Integer, vDialogs() As Variant, i As Integer, j As Integer, iCount As Integer +Dim oMacLibraries As Object, vAllDialogs As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean +Dim oLibDialog As Object, sLibrary As String, oDocLibraries As Object, bLocalStorage As Boolean +Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object +Dim vCurrentDocument As Variant +Const cstCount = 0 +Const cstByIndex = 1 +Const cstByName = 2 +Const cstSepar = "!" + + 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 Else iMode = cstByIndex + End If + + Set vAllDialogs = Nothing + + Set vCurrentDocument = Nothing + If Not IsNull(_A2B_.CurrentDocument) Then + Set vCurrentDocument = _A2B_.CurrentDocument.Document + ElseIf Not IsNull(ThisComponent) Then + Set vCurrentDocument = ThisComponent + End If + If IsNull(vCurrentDocument) Then + Set oDocLibraries = Nothing + vDocLibraries = Array() + Else + Set oDocLibraries = vCurrentDocument.DialogLibraries + vDocLibraries = oDocLibraries.getElementNames() + End If + Set oMacLibraries = GlobalScope.DialogLibraries + 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) + + If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library + Set vAllDialogs = New Collect + Set vAllDialogs._This = vAllDialogs + vAllDialogs._CollType = COLLALLDIALOGS + vAllDialogs._Count = 0 + Goto Exit_Function + End If + + vNames = Array() + iCount = 0 + For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1 + bFound = False + If i <= UBound(vDocLibraries) Then + sLibrary = vDocLibraries(i) + bLocalStorage = True + 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) + bLocalStorage = False + Set oDocMacLib = oMacLibraries + End If + If oDocMacLib.IsLibraryLoaded(sLibrary) Then + Set oLibrary = oDocMacLib.getByName(sLibrary) + If oLibrary.hasElements() Then + vDialogs = oLibrary.getElementNames() + Select Case iMode + Case cstCount + iCount = iCount + UBound(vDialogs) + 1 + Case cstByIndex, cstByName + For j = 0 To UBound(vDialogs) + If iMode = cstByIndex Then + If pvIndex = iCount Then bFound = True + iCount = iCount + 1 + Else + If UCase(pvIndex) = UCase(vDialogs(j)) Then bFound = True + End If + If bFound Then + Set oLibDialog = oLibrary.getByName(vDialogs(j)) ' Create Dialog object + Exit For + End If + Next j + End Select + End If + End If + If bFound Then Exit For + Next i + + If iMode = cstCount Then + Set vAllDialogs = New Collect + Set vAllDialogs._This = vAllDialogs + vAllDialogs._CollType = COLLALLDIALOGS + vAllDialogs._Count = iCount + Else + If Not bFound Then + If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found + End If + Set vAllDialogs = New Dialog + With vAllDialogs + ._This = vAllDialogs + ._Name = vDialogs(j) + ._Shortcut = "Dialogs!" & vDialogs(j) + Set ._Dialog = oLibDialog + ._Library = sLibrary + ._Storage = Iif(bLocalStorage, "DOCUMENT", "GLOBAL") + End With + End If + +Exit_Function: + Set AllDialogs = vAllDialogs + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Not_Found: + TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex) + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vDialogs = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set vDialogs = Nothing + GoTo Exit_Function +End Function ' AllDialogs V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AllForms(ByVal Optional pvIndex As Variant) As Variant +' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string) +' Easiest use for standalone forms: AllForms(0) +' If no argument, return a Collection type + +Const cstThisSub = "AllForms" +Dim iIndex As Integer, vReturn As Variant +Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object +Dim ofForm As Object +Dim vAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean +Const cstSeparator = "\;" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Set vReturn = Nothing + + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + Select Case VarType(pvIndex) + Case vbString + iIndex = -1 + Case Else + iIndex = pvIndex + End Select + End If + + iCurrentDoc = _A2B_.CurrentDocIndex() + If iCurrentDoc >= 0 Then + vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) + Else + Goto Exit_Function + End If + +' Load complete list of hierarchical and persistent names when Base document + If vCurrentDoc.DbConnect = DBCONNECTBASE Then vAllForms = _GetAllHierarchicalNames() + +' Process when NO ARGUMENT + If IsMissing(pvIndex) Then ' No argument + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLALLFORMS + If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = UBound(vAllForms) + 1 + Set vReturn = oCounter + Goto Exit_Function + End If + +' Process when ARGUMENT = STRING or INDEX => Initialize form object + Set ofForm = New Form + Set ofForm._This = ofForm + Select Case vCurrentDoc.DbConnect + Case DBCONNECTBASE + ofForm._DocEntry = 0 + ofForm._DbEntry = 0 + If iIndex= -1 Then ' String argument + vName = Utils._InList(Utils._Trim(pvIndex), vAllForms, True) + If vName = False Then Goto Trace_Not_Found + ofForm._Initialize(vName) + Else + If iIndex > UBound(vAllForms) Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense + ofForm._Initialize(vAllForms(iIndex)) + End If + Case DBCONNECTFORM + With vCurrentDoc + If iIndex = -1 Then + bFound = False + For i = 0 To UBound(vCurrentDoc.DbContainers) + Set oDatabase = vCurrentDoc.DbContainers(i).Database + If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then + bFound = True + ofForm._DbEntry = i + Exit For + End If + Next i + If Not bFound Then Goto Trace_Not_Found + ElseIf iIndex < 0 Or iIndex > UBound(vCurrentDoc.DbContainers) Then + Goto Trace_Error_Index + Else + ofForm._DbEntry = iIndex + Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database + End If + End With + vName = oDatabase.FormName + ofForm._DocEntry = iCurrentDoc + ofForm._Initialize(vName) + End Select + + Set vReturn = ofForm + +Exit_Function: + Set AllForms = vReturn + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Not_Found: + TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, , pvIndex) + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vReturn = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set vReturn = Nothing + GoTo Exit_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 + ' Determine 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 = _A2B_.CurrentDocument.Document.BasicLibraries ' 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 + Set vAllModules._This = vAllModules + vAllModules._CollType = COLLALLMODULES + 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 + Set vAllModules._This =vAllModules + vAllModules._CollType = COLLALLMODULES + 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 + Set vAllModules._This = vAllModules + 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. +' - if Base document => close the one concerned database connection +' - if non-Base documents => close the connections of each individual standalone form + + If IsEmpty(_A2B_) Then Goto Exit_Sub + +Const cstThisSub = "CloseConnection" + Utils._SetCalledSub(cstThisSub) + + Call _A2B_.CloseConnection() + +Exit_Sub: + Utils._ResetCalledSub(cstThisSub) + Exit Sub +End Sub ' CloseConnection V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CommandBars(Optional ByVal pvIndex As Variant, Optional ByRef poWindow As Object) As Variant +' Return an object of type CommandBar indicated by its index or its name (CASE-INSENSITIVE string) +' If no pvIndex argument, return a Collection type +' (Unpublished) With poWindow, force the frame in which toolbars are detected + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBars" + Utils._SetCalledSub(cstThisSub) + +Dim iObjectsCount As Integer, sObjectName As String, oObject As Object +Dim oWindow As Object, iWindowType As Integer +Dim i As Integer, j As Integer, k As Integer, bFound As Boolean +Dim sSupportedModules() As Variant, vModules() As Variant, oModuleUI As Object +Dim oToolbar As Object, sToolbarName As String, vUIElements() As Variant, sToolbarFullName As String, iBuiltin As Integer + +Const cstCustom = "CUSTOM" + + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + iObjectsCount = 0 + bFound = False + + If IsMissing(poWindow) Then Set oWindow = _SelectWindow() Else Set oWindow = poWindow + If IsNull(oWindow.Frame) Then Goto Trace_WindowError + + ' List of 21 modules + vModules = CreateUnoService("com.sun.star.frame.ModuleManager").getElementNames() + + iWindowType = oWindow.WindowType + Select Case iWindowType ' Supported window types only + Case acForm + sSupportedModules = Array( "com.sun.star.sdb.FormDesign" ) + Case acBasicIDE + sSupportedModules = Array( "com.sun.star.script.BasicIDE" ) + Case acDatabaseWindow + sSupportedModules = Array( "com.sun.star.sdb.OfficeDatabaseDocument" ) + Case acReport + sSupportedModules = Array( "com.sun.star.sdb.TextReportDesign" ) + Case acDocument + Select Case oWindow.DocumentType + Case docCalc : sSupportedModules = Array( "com.sun.star.sheet.SpreadsheetDocument" ) + Case docWriter : sSupportedModules = Array( "com.sun.star.text.TextDocument" ) + Case docImpress : sSupportedModules = Array( "com.sun.star.presentation.PresentationDocument" ) + Case docDraw : sSupportedModules = Array( "com.sun.star.drawing.DrawingDocument" ) + Case docMath : sSupportedModules = Array( "com.sun.star.formula.FormulaProperties" ) + Case Else : sSupportedModules = Array() + End Select + Case acTable, acQuery + sSupportedModules = Array( "com.sun.star.sdb.DataSourceBrowser" _ + , "com.sun.star.sdb.TableDataView" _ + ) + Case acDiagram + sSupportedModules = Array( "com.sun.star.sdb.RelationDesign" ) + Case acWelcome + sSupportedModules = Array( "com.sun.star.frame.StartModule" ) + Case Else + sSupportedModules = Array() + End Select + + ' Find all standard and custom toolbars stored in LibO/AOO Base + Set oModuleUI = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier") + For k = 0 To UBound(vModules) + For j = 0 To UBound(sSupportedModules) + iBuiltin = 1 ' Default = builtin + If vModules(k) = sSupportedModules(j) Then ' Supported modules only + Set oToolbar = oModuleUI.getUIConfigurationManager(vModules(k)) + vUIElements() = oToolbar.getUIElementsInfo(0) + For i = 0 To UBound(vUIElements) + sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL") + sToolbarName = Split(sToolbarFullName, "/")(2) + If _IsLeft(UCase(sToolbarName), UCase(cstCustom)) Then + sToolbarName = _GetPropertyValue(vUIElements(i), "UIName") + iBuiltin = 2 + End If + + iObjectsCount = iObjectsCount + 1 + Select Case True + Case IsMissing(pvIndex) + Case VarType(pvIndex) = vbString + If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True + Case Else + If pvIndex < 0 Then Goto Trace_IndexError + If pvIndex = iObjectsCount - 1 Then bFound = True + End Select + + If bFound Then + Set oObject = _NewCommandBar(vModules(k), sToolbarName, sToolbarFullName, iBuiltin) + Set oObject._Window = oWindow.Frame + Set oObject._Toolbar = oToolbar + Goto Exit_Function + End If + Next i + End If + Next j + Next k + + ' Find all (not builtin) toolbars stored in current document (typically forms) + iBuiltin = 3 ' Stored in form itself + Set oToolbar = oWindow.Frame.Controller.Model.getUIConfigurationManager + vUIElements() = oToolbar.getUIElementsInfo(0) + For i = 0 To UBound(vUIElements) + sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL") + sToolbarName = _GetPropertyValue(vUIElements(i), "UIName") + iObjectsCount = iObjectsCount + 1 + Select Case True + Case IsMissing(pvIndex) + Case VarType(pvIndex) = vbString + If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True + Case Else + If pvIndex = iObjectsCount - 1 Then bFound = True + End Select + If bFound Then + Set oObject = _NewCommandBar("", sToolbarName, sToolbarFullName, iBuiltin) + Set oObject._Window = oWindow.Frame + Set oObject._Toolbar = oToolbar + Goto Exit_Function + End If + Next i + + ' MISSING : CUSTOM POPUPS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLCOMMANDBARS + oObject._Count = iObjectsCount + Case VarType(pvIndex) = vbString + Goto Trace_NotFound + Case Else ' pvIndex is numeric + Goto Trace_IndexError + End Select + +Exit_Function: + Set CommandBars = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("COMMANDBAR"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_WindowError: + TraceError(TRACEFATAL, ERRWINDOW, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' CommandBars V1,3,0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(ByVal Optional pvObject As Variant, Optional ByVal pvIndex As Variant) As Variant +' Return an object of type Control indicated by either its index (integer) or its name (CASE-INSENSITIVE string) +' The 1st argument pvObject can be either +' an object of type FORM (1) +' a main form name as string +' an object of type SUBFORM (2) +' The Form property in the returned variant contains a SUBFORM type +' an object of type CONTROL and subtype GRIDCONTROL (3) +' an object of type OPTIONGROUP (4) 2nd argument, if any, must be numeric +' If no pvIndex argument, return a Collection type + +If _ErrorHandler() Then On Local Error Goto Error_Function +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 = EMPTY + + If VarType(pvObject) = vbString Then + Set vObject = Forms(pvObject) + If IsNull(vObject) Then Goto Exit_Function + Else + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM, OBJOPTIONGROUP, CTLGRIDCONTROL)) Then Goto Exit_Function + Set vObject = pvObject + End If + + If IsMissing(pvIndex) Then + Controls = vObject.Controls() + Else + If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function + Controls = vObject.Controls(pvIndex) + End If + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEERROR, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Controls V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties + +Const cstThisSub = "CurrentDb" + Utils._SetCalledSub(cstThisSub) + + Set CurrentDb = Nothing + If IsEmpty(_A2B_) Then GoTo Exit_Function + Set CurrentDb = _A2B_.CurrentDb() + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentUser() As String + +Dim oPath As Object, sUser As String + + Set oPath = CreateUnoService("com.sun.star.util.PathSubstitution") + sUser = oPath.getSubstituteVariableValue("$(username)") ' New since LibreOffice 5.2 + CurrentUser = sUser + +End Function ' CurrentUser V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DAvg( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return average of scope +Const cstThisSub = "DAvg" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DAvg + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DCount( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return # of occurrences of scope +Const cstThisSub = "DCount" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DLookup( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + +' Return a value within a table + 'Arguments: psExpr: an SQL expression + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + 'Return: Value of the psExpr if found, else Null. + 'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html + 'Examples: + ' 1. To find the last value, include DESC in the OrderClause, e.g.: + ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC") + ' 2. To find the lowest non-null value of a field, use the Criteria, e.g.: + ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname") + +Const cstThisSub = "DLookup" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _ + , Iif(IsMissing(pvCriteria), "", pvCriteria) _ + , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _ + ) + Utils._ResetCalledSub(cstThisSub) +End Function ' DLookup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMax( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return maximum of scope +Const cstThisSub = "DMax" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMax + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMin( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return minimum of scope +Const cstThisSub = "DMin" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMin + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDev( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "DStDev" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDev + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDevP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "DStDevP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDevP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DSum( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return sum of scope +Const cstThisSub = "DSum" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DSum + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVar( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "DVar" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVarP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "DVarP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVarP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Events(Optional poEvent As Variant) As Variant +' Return an event object corresponding with actual event + +Dim vEvent As Variant + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Events" + Utils._SetCalledSub(cstThisSub) + + Set vEvent = Nothing + If IsMissing(poEvent) Then Goto Exit_Function + If IsNull(poEvent) Then Goto Exit_Function + + If Not Utils._CheckArgument(poEvent, 1, vbObject, , False) Then Goto Exit_Function ' No error handling in CheckArgument + If Not Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error + Set vEvent = New Event + vEvent._Initialize(poEvent) + +Exit_Function: + Set Events = vEvent + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEWARNING, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + ' Errors are not displayed to avoid display infinite cycling + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent))) + Set vEvent = Nothing + Goto Exit_Function +End Function ' Events V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Forms(ByVal Optional pvIndex As Variant) As Variant +' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string) +' The concerned form must be loaded. +' If no argument, return a Collection type + +Const cstThisSub = "Forms" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim ofForm As Object, oCounter As Variant, vForms As Variant, oIndex As Object + Set vForms = Nothing + +Dim iCount As Integer + If IsMissing(pvIndex) Then + iCount = Application._CountOpenForms() + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLFORMS + oCounter._Count = iCount + Forms = oCounter + Exit Function + Else + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + Select Case VarType(pvIndex) + Case vbString + Set ofForm = Application.AllForms(Utils._Trim(pvIndex)) + Case Else + iCount = Application._CountOpenForms() + If iCount <= pvIndex Then Goto Trace_Error_Index + Set ofForm = Application._CountOpenForms(pvIndex) + End Select + + If IsNull(ofForm) Then Goto Trace_Error + If ofForm.IsLoaded Then + Set vForms = ofForm + Else + Set vForms = Nothing + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , ofForm._Name) + Goto Exit_Function + End If + +Exit_Function: + Set Forms = vForms + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvIndex)) + Set vForms = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vForms = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Forms V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getObject(Optional pvShortcut As Variant) As Variant +' Return the object described by pvShortcut ignoring its final property +' Example: "Forms!myForm!myControl.myProperty" => Controls(Forms("myForm"), "myControl")) + +Const cstEXCLAMATION = "!" +Const cstDOT = "." + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "getObject" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvShortcut) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvShortcut, 1, vbString) Then Goto Exit_Function + +Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String +Dim sComponents() As String, sSubComponents() As String, sDialog As String +Dim oDoc As Object + Set vCurrentObject = Nothing + sComponents = Split(Trim(pvShortcut), cstEXCLAMATION) + If UBound(sComponents) = 0 Then Goto Trace_Error + If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS", "TEMPVARS")) Then Goto Trace_Error + If sComponents(1) = "0" Or Left(sComponents(1), 2) = "0." Then + Set oDoc = _A2B_.CurrentDocument() + If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error + End If + + sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT) + sComponents(UBound(sComponents)) = sSubComponents(0) ' Ignore final property, if any + + Set vCurrentObject = New Collect + Set vCurrentObject._This = vCurrentObject + Select Case UCase(sComponents(0)) + Case "FORMS" : vCurrentObject._CollType = COLLFORMS + Case "DIALOGS" : vCurrentObject._CollType = COLLALLDIALOGS + Case "TEMPVARS" : vCurrentObject._CollType = COLLTEMPVARS + End Select + For iCurrentIndex = 1 To UBound(sComponents) ' Start parsing ... + sSubComponents = Split(sComponents(iCurrentIndex), cstDOT) + sComponents(iCurrentIndex) = Utils._Trim(sSubComponents(0)) + Select Case UBound(sSubComponents) + Case 0 + sCurrentProperty = "" + Case 1 + sCurrentProperty = sSubComponents(1) + Case Else + Goto Trace_Error + End Select + Select Case vCurrentObject._Type + Case OBJCOLLECTION + Select Case vCurrentObject._CollType + Case COLLFORMS + vCurrentObject = Application.AllForms(sComponents(iCurrentIndex)) + Case COLLALLDIALOGS + sDialog = UCase(sComponents(iCurrentIndex)) + vCurrentObject = Application.AllDialogs(sDialog) + If Not vCurrentObject.IsLoaded Then Goto Trace_Error + Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog) + Case COLLTEMPVARS + If UBound(sComponents) > 1 Then Goto Trace_Error + vCurrentObject = Application.TempVars(sComponents(1)) + 'Case Else + End Select + Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG + vCurrentObject = vCurrentObject.Controls(sComponents(iCurrentIndex)) + End Select + If sCurrentProperty <> "" Then vCurrentObject = vCurrentObject.getProperty(sCurrentProperty) + Next iCurrentIndex + + Set getObject = vCurrentObject + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvShortcut)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' getObject V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getValue(Optional pvObject As Variant) As Variant +' getValue also interprets shortcut strings !! +Dim vItem As Variant, sProperty As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getValue") + If VarType(pvObject) = vbString Then + Utils._SetCalledSub("getValue") + Set vItem = getObject(pvObject) + sProperty = Utils._FinalProperty(pvObject) + If sProperty = "" Then sProperty = "Value" ' Default value if final property in shortcut is absent + getValue = vItem.getProperty(sproperty) + Utils._ResetCalledSub("getValue") + Else + Set vItem = pvObject + getValue = vItem.getProperty("Value") + End If +End Function ' getValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Function HtmlEncode(ByVal pvString As Variant, ByVal Optional pvLength As Variant) As String +' Converts a string to an HTML-encoded string. + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "HtmlEncode" + Utils._SetCalledSub(cstThisSub) + + HtmlEncode = "" + +Dim sOutput As String, l As Long, lLength As Long + If IsMissing(pvLength) Then pvLength = 0 + If Not Utils._CheckArgument(pvString, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvLength, 1, _AddNumeric()) Then Goto Exit_Function + + sOutput = "" + lLength = CLng(pvLength) + If Len(pvString) > 0 Then + For l = 1 To Len(pvString) + If lLength > 0 And Len(sOutput) > lLength Then Exit For + sOutput = sOutput & Utils._UTF8Encode(Mid(pvString, l, 1)) + Next l + End If + + HtmlEncode = sOutput + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' HtmlEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenConnection ( _ + Optional pvComponent As Variant _ + , ByVal Optional pvUser As Variant _ + , ByVal Optional pvPassword As Variant _ + ) As Object + +' Establish connection with the database designated in the currently open front-end (.odb) document +' Call template: +' Call OpenConnection(ThisDatabaseDocument[, "", ""]) +' Call stored in the OpenDocument event of the front-end database document +'OR +' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms +' Call template: +' Call OpenConnection(ThisComponent[, "", ""]) +' Call stored in the OpenDocument event of the document +' +' User and Password arguments are obsolete (still tolerated) +' - because no mean has been found to connect protected db from .odb via API +' - because having multiple forms with multiple db's and multiple passwords is meaningless + +Dim oComponent As Object, oForms As Object, iCurrent As Integer +Dim i As Integer, bFound As Boolean +Dim vCurrentDoc() As Variant +Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object +Dim sDatabaseURL As String, oHandler As Object +Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant +Dim sFormName As String + + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session + Set OpenConnection = Nothing + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OpenConnection" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvComponent) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function + Set oComponent = pvComponent + If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(1, oComponent)) + Exit Function + End If + If IsMissing(pvUser) Then pvUser = "" + If IsMissing(pvPassword) Then pvPassword = "" + If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function + + If Not IsArray(_A2B_.CurrentDoc) Then + vCurrentDoc() = Array() + Redim vCurrentDoc(0 To 0) ' Create at least one entry for database document + Else + vCurrentDoc() = _A2B_.CurrentDoc() + End If + + ' Find index of entry to use for new connection + With oComponent + Select Case .ImplementationName + Case "com.sun.star.comp.dba.ODatabaseDocument" + iCurrent = 0 + Case Else ' "SwXTextDocument", "ScModelObj" + If UBound(vCurrentDoc) <= 0 Then ' First Calc or Writer during current session + iCurrent = 1 + Else ' Search entry already used earlier by same component + bFound = False + For i = 1 To UBound(vCurrentDoc) + If Not IsEmpty(vCurrentDoc(i)) Then + If vCurrentDoc(i).Active And vCurrentDoc(i).URL = .URL Then + iCurrent = i + bFound = True + Exit For + End If + End If + Next i + End If + If Not bFound Then + iCurrent = UBound(vCurrentDoc) + 1 ' No entry found, increment array + ReDim Preserve vCurrentDoc(0 To iCurrent) + End If + End Select + End With + + ' Initialize future entry + Set vDocContainer = New DocContainer + Set vDocContainer.Document = oComponent + vDocContainer.Active = True + vDocContainer.URL = oComponent.URL + ' Initialize each DbContainer entry + vDbContainers() = Array() + TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) + Select Case oComponent.ImplementationName + Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments + vDbContainer = New DbContainer + vDbContainer.FormName = "" + Set vDbContainer.Database = New Database + Set vDbContainer.Database._This = vDbContainer.Database + With vDbContainer.Database + If Not oComponent.CurrentController.IsConnected Then + Set oHandler = createUnoService("com.sun.star.sdb.InteractionHandler") + Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler) + oComponent.CurrentController.connect() + Else + Set .Connection = oComponent.CurrentController.ActiveConnection + End If + vDocContainer.DbConnect = DBCONNECTBASE + ._DbConnect = DBCONNECTBASE + Set .MetaData = .Connection.MetaData + ._LoadMetadata() + If .MetaData.DatabaseProductName = "MySQL" Then + ._ReadOnly = .MetaData.isReadOnly() + Else + ._ReadOnly = .Connection.isReadOnly() ' Always True in Mysql ?? + End If + Set .Document = oComponent + .Title = oComponent.Title + .URL = vDocContainer.URL + .Location = oComponent.Location + ReDim vDbContainers(0 To 0) + Set vDbContainers(0) = vDbContainer + TraceLog(TRACEANY, .Version, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False) + End With + Case Else + Set oForms = oComponent.CurrentController.Model.DrawPage.Forms + If oForms.Count < 1 Then Goto Error_MainForm + ReDim vDbContainers(0 To oForms.Count - 1) + For i = 0 To oForms.Count - 1 + vDbContainer = New DbContainer ' To make distinct entries !! + sFormName = oForms.ElementNames(i) + Set vDbContainer.Database = New Database + Set vDbContainer.Database._This = vDbContainer.Database + With vDbContainer.Database + .FormName = sFormName + vDbContainer.FormName = sFormName + Set .Form = oForms.getByName(sFormName) + Set .Connection = .Form.ActiveConnection ' Might be Nothing in Windows at AOO/LO startup (not met in Linux) + If Not IsNull(.Connection) Then + Set .MetaData = .Connection.MetaData + ._LoadMetadata() + ._ReadOnly = .Connection.isReadOnly() + TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False) + End If + Set .Document = oComponent + .Title = oComponent.Title + .URL = .Form.DataSourceName + ._DbConnect = DBCONNECTFORM + Set vDbContainers(i) = vDbContainer + vDbContainers(i).FormName = sFormName + TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False) + End With + Next i + vDocContainer.DbConnect = DBCONNECTFORM + End Select + + vDocContainer.DbContainers() = vDbContainers() + Set vCurrentDoc(iCurrent) = vDocContainer + + _A2B_.CurrentDoc = vCurrentDoc + Set OpenConnection = vDbContainers(0).Database + + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set _A2B_.CurrentDoc = Array() + GoTo Exit_Function +Error_MainForm: + TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title) + Set _A2B_.CurrentDoc = Array() + GoTo Exit_Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) + Goto Exit_Function +End Function ' OpenConnection V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenDatabase ( _ + ByVal Optional pvDatabaseURL As Variant _ + , ByVal Optional pvUser As Variant _ + , ByVal Optional pvPassword As Variant _ + , ByVal Optional pvReadOnly As Variant _ + ) As Variant + +' Return a database object based on input arguments: +' Call template: +' Call OpenDatabase("... databaseURL ..."[, "", "", True/False]) +' pvDatabaseURL may be the name of a registered database or the URL of the targeted .odb file +' Might be called from any AOO/LibO application, independently from OpenConnection + +Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object +Dim i As Integer, bFound As Boolean +Dim sDatabaseURL As String + + If IsEmpty(_A2B_) Then ' First use of Access2Base in current AOO/LibO session + Call Application._RootInit() + TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) + End If + Set OpenDatabase = Nothing + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OpenDatabase" + Utils._SetCalledSub(cstThisSub) + If pvDatabaseURL = "" Then Call _TraceArguments() + If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function + If IsMissing(pvUser) Then pvUser = "" + If IsMissing(pvPassword) Then pvPassword = "" + If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function + If IsMissing(pvReadOnly) Then pvReadOnly = False + If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function + + Set odbDatabase = New Database + Set odbDatabase._This = odbDatabase + odbDatabase._DbConnect = DBCONNECTANY + + Set oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + sDbNames() = oBaseContext.getElementNames() + bFound = False + For i = 0 To UBound(sDbNames()) ' Enumerate registered databases and check non case-sensitive equality + If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then + sDatabaseURL = sDbNames(i) + Set oBaseSource = oBaseContext.getByName(sDatabaseURL) + odbDatabase.Location = oBaseContext.getDatabaseLocation(sDbNames(i)) + bFound = True + Exit For + End If + Next i + If Not bFound Then + sDatabaseURL = ConvertToURL(pvDatabaseURL) + If UCase(Right(sDatabaseURL, 4)) <> ".ODB" Then Goto Trace_Error + If Not FileExists(sDatabaseURL) Then Goto Trace_Error + Set oBaseSource = oBaseContext.getByName(sDatabaseURL) + odbDatabase.Location = sDatabaseURL + End If + + Set odbDatabase.Connection = oBaseSource.getConnection(pvUser, pvPassword) + If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist + Set odbDatabase.MetaData = odbDatabase.Connection.MetaData + odbDatabase._LoadMetadata() + Else + Goto Trace_Error + End If + + odbDatabase.URL = sDatabaseURL + + If pvReadOnly Then + odbDatabase.Connection.isReadOnly = True + odbDatabase._ReadOnly = True + End If + + Set OpenDatabase = odbDatabase + + TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False) + + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) + Goto Exit_Function +End Function ' OpenDatabase V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ProductCode() + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session + ProductCode = "Access2Base " & _A2B_.VersionNumber +End Function ' ProductCode V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' setValue also interprets shortcut strings !! +Dim vItem As Variant, sProperty As String + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setValue") + If VarType(pvObject) = vbString Then + Utils._SetCalledSub("setValue") + Set vItem = getObject(pvObject) + sProperty = Utils._FinalProperty(pvObject) + If sProperty = "" Then sProperty = "Value" + setValue = vItem.setProperty(sProperty, pvValue) + Utils._ResetCalledSub("setValue") + Else + Set vItem = pvObject + setValue = vItem.setProperty("Value", pvValue) + End If +End Function ' setValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SysCmd(Optional pvAction As Variant _ + , Optional pvText As Variant _ + , Optional pvValue As Variant _ + ) As Variant +' Manage progress meter in the status bar +' Other values supported by MSAccess are ignored + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SysCmd" + Utils._SetCalledSub(cstThisSub) + SysCmd = False + +Const cstMissing = -1 +Const cstBarLength = 350 + If IsMissing(pvAction) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _ + acSysCmdAccessDir _ + , acSysCmdAccessVer _ + , acSysCmdClearHelpTopic _ + , acSysCmdClearStatus _ + , acSysCmdGetObjectState _ + , acSysCmdGetWorkgroupFile _ + , acSysCmdIniFile _ + , acSysCmdInitMeter _ + , acSysCmdProfile _ + , acSysCmdRemoveMeter _ + , acSysCmdRuntime _ + , acSysCmdSetStatus _ + , acSysCmdUpdateMeter _ + )) Then Goto Exit_Function + If IsMissing(pvValue) Then pvValue = cstMissing + If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function + Select Case pvAction + Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus + If IsMissing(pvText) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvText, 2, vbString) Then Goto Exit_Function + Case Else + End Select + If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function + +Dim vBar As Variant, iLen As Integer + Set vBar = _A2B_.StatusBar + Select Case pvAction + Case acSysCmdAccessVer + SysCmd = Application.Version() + Goto Exit_Function + Case acSysCmdSetStatus + If pvValue <> cstMissing Then Goto Error_Arg + iLen = Len(pvText) + vBar = _NewBar() + If Not IsNull(vBar) Then vBar.start(Iif(iLen >= cstBarLength, pvText, pvText & Space(cstBarLength - iLen)), 0) + Case acSysCmdClearStatus + If pvValue <> cstMissing Then Goto Error_Arg + If Not IsNull(vBar) Then + vBar.end() + Set _A2B_.StatusBar = Nothing + End If + Case acSysCmdInitMeter + If pvValue = cstMissing Then Call _TraceArguments() + vBar = _NewBar() + If Not IsNull(vBar) Then vBar.start(pvText, pvValue) + Case acSysCmdUpdateMeter + If pvValue = cstMissing Then Call _TraceArguments() + If Not IsNull(vBar) Then ' Otherwise ignore ! + vBar.setValue(pvValue) + If Len(pvText) > 0 Then vBar.setText(pvText) + End If + Case acSysCmdRemoveMeter + If Not IsNull(vBar) Then + vBar.end() + Set _A2B_.StatusBar = Nothing + End If + Case acSysCmdRuntime + SysCmd = False + Goto Exit_Function + Case Else + End Select + + SysCmd = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_Arg: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(3, pvValue)) + Goto Exit_Function +End Function ' SysCmd V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TempVars(ByVal Optional pvIndex As Variant) As Variant +' Return either a Collection or a TempVar object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "TempVars" + Utils._SetCalledSub(cstThisSub) + +Dim iMode As Integer, vTempVars As Variant, bFound As Boolean +Const cstCount = 0 +Const cstByIndex = 1 +Const cstByName = 2 + + 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 Else iMode = cstByIndex + End If + + Set vTempVars = Nothing + Select Case iMode + Case cstCount ' Build Collection object + Set vTempVars = New Collect + With vTempVars + ._This = vTempVars + ._CollType = COLLTEMPVARS + ._Count = _A2B_.TempVars.Count + End With + Case cstByIndex ' Build TempVar object + If pvIndex < 0 Or pvIndex >= _A2B_.TempVars.Count Then Goto Trace_Error_Index + Set vTempVars = _A2B_.TempVars.Item(pvIndex + 1) ' Builtin collections start at 1 + Case cstByName + bFound = _A2B_.hasItem(COLLTEMPVARS, pvIndex) + If Not bFound Then Goto Trace_NotFound + vTempVars = _A2B_.TempVars.Item(UCase(pvIndex)) + End Select + + Set TempVars = vTempVars + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vTempVars = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TEMPVAR"), pvIndex)) + Goto Exit_Function +End Function ' TempVars V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Version() As String + Version = Utils._GetProductName() +End Function ' Version V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _CollectNames(ByRef poCollection As Object, ByVal psPrefix As String) As Variant +' Return a "\;" separated list of hierarchical (prefixed with Prefix) and persistent names contained in Collection +' If one of those names refers to a folder, function is called recursively +' Result = 2 items array: (0) list of hierarchical names +' (1) list of persistent names +' +Dim oObject As Object, vNamesList() As Variant, vPersistentList As Variant, i As Integer, sCollect(0 To 1) As String +Dim sName As String, sType As String, sPrefix As String +Const cstFormType = "application/vnd.oasis.opendocument.text" +Const cstSeparator = "\;" + + _CollectNames = sCollect() + vPersistentList = Array() + + With poCollection + If .getCount = 0 Then Exit Function + vNamesList = .getElementNames() + ReDim vPersistentList(0 To UBound(vNamesList)) + + For i = 0 To UBound(vNamesList) + sName = vNamesList(i) + Set oObject = .getByName(sName) + sType = oObject.getContentType() + Select Case sType + Case cstFormType + vNamesList(i) = psPrefix & vNamesList(i) + vPersistentList(i) = oObject.PersistentName + Case "" ' Folder + sCollect = _CollectNames(oObject, psPrefix & sName & "/") + vNamesList(i) = sCollect(0) + vPersistentList(i) = sCollect(1) + Case Else + End Select + Next i + + End With + + Set oObject = Nothing + sCollect(0) = Join(vNamesList, cstSeparator) + sCollect(1) = Join(vPersistentList, cstSeparator) + _CollectNames = sCollect() + +End Function ' _CollectNames V6.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CountOpenForms(ByVal Optional piCountMax As Integer) As Variant +' Return # of active forms if no argument +' Return name of piCountMax-th open form if argument present + +Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant + iAllCount = AllForms._Count + iCount = 0 + If iAllCount > 0 Then + For i = 0 To iAllCount - 1 + Set ofForm = Application.AllForms(i) + If ofForm._IsLoaded Then iCount = iCount + 1 + If Not IsMissing(piCountMax) Then + If iCount = piCountMax + 1 Then + _CountOpenForms = ofForm ' OO3.2 aborts when Set verb present ?!? + Exit For + End If + End If + Next i + End If + + If IsMissing(piCountMax) Then _CountOpenForms = iCount + +End Function ' CountOpenForms V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant +REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use) +REM With 2 arguments return the corresponding entry in Root + +Dim oCurrentDb As Object + If IsEmpty(_A2B_) Then GoTo Trace_Error + If IsMissing(piDocEntry) Then Set oCurrentDb = Application.CurrentDb() _ + Else Set oCurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry) + If IsNull(oCurrentDb) Then Goto Trace_Error Else Set _CurrentDb = oCurrentDb + +Exit_Function: + Exit Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) + Goto Exit_Function +End Function ' _CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetAllHierarchicalNames() As Variant +' Return the full hierarchical names list of a database document +' Get it from the vFormNamesList buffer if the latter is not empty + +Dim vNamesList As Variant, iCurrentDoc As Integer, vCurrentDoc As Variant +Dim oForms As Object +Const cstSeparator = "\;" + + _GetAllHierarchicalNames = Array() + +' Load complete list of names when Base document + iCurrentDoc = _A2B_.CurrentDocIndex() + If iCurrentDoc >= 0 Then vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) Else Exit Function + If vCurrentDoc.DbConnect = DBCONNECTBASE Then + If IsEmpty(vFormNamesList) Then + Set oForms = vCurrentDoc.Document.getFormDocuments() + vFormNamesList = _CollectNames(oForms, "") + End If + vNamesList = Split(vFormNamesList(0), cstSeparator) + Else + Exit Function + End If + + _GetAllHierarchicalNames = vNamesList + Set oForms = Nothing + +End Function ' _GetAllHierarchicalNames V 6.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetHierarchicalName(ByVal psPersistent As String) As String +' Return the full hierarchical name from the persistent name of a form/report + +Dim vPersistentList As Variant, vNamesList As Variant, i As Integer +Const cstSeparator = "\;" + + _GetHierarchicalName = "" + +' Load complete list of names when Base document + vNamesList = _GetAllHierarchicalNames() + If UBound(vNamesList) < 0 Then Exit Function + vPersistentList = Split(vFormNamesList(1), cstSeparator) + +' Search in list + For i = 0 To UBound(vPersistentList) + If vPersistentList(i) = psPersistent Then + _GetHierarchicalName = vNamesList(i) + Exit For + End If + Next i + +End Function ' _GetHierarchicalName V 6.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _NewBar() As Object +' Close current status bar, if any, and initialize new one + +Dim vBar As Variant, vWindow As Variant, vController As Object + On Local Error Resume Next + Set _NewBar = Nothing + + Set vBar = _A2B_.StatusBar + If Not IsNull(vBar) Then + If Utils._hasUNOMethod(vBar, "end") Then vBar.end() + Set _A2B_.StatusBar = Nothing + End If + + Set vBar = Nothing + Set vWindow = _SelectWindow() + If IsNull(vWindow.Frame) Then Exit Function + Select Case vWindow.WindowType + Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow + Case Else + Exit Function + End Select + If Utils._hasUNOMethod(vWindow.Frame, "getCurrentController") Then + Set vController = vWindow.Frame.getCurrentController() + ElseIf Utils._hasUNOMethod(vWindow.Frame, "getController") Then + Set vController = vWindow.Frame.getController() + End If + + If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator() + Set _A2B_.StatusBar = vBar + Set _NewBar = vBar + Exit Function + +End Function ' _NewBar V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _NewCommandBar(psModule As String _ + , psToolbarName As String _ + , psToolbarFullName As String _ + , piBuiltin As Integer _ + ) As Object + +Dim oObject As Object + Set oObject = New CommandBar + With oObject + ._This = oObject + ._Type = OBJCOMMANDBAR + ._Name = psToolbarName + ._ResourceURL = psToolbarFullName + ._Module = psModule + ._BarBuiltin = piBuiltin + Select Case UCase(Split(psToolbarFullName, "/")(1)) + Case "MENUBAR" : ._BarType = msoBarTypeMenuBar + Case "STATUSBAR" : ._BarType = msoBarTypeStatusBar + Case "TOOLBAR" : ._BarType = msoBarTypeNormal + Case "POPUP" : ._BarType = msoBarTypePopup + Case "FLOATER" : ._BarType = msoBarTypeFloater + Case Else : ._BarType = -1 + End Select + End With + Set _NewCommandBar = oObject + Exit Function + +End Function ' NewCommandBar V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _RootInit(Optional ByVal pbForce As Boolean) +' Initialize _A2B_ global variable. Reinit forced if pbForce = True + + If IsMissing(pbForce) Then pbForce = False + If IsEmpty(_A2B_) Or pbForce Then _A2B_ = New Root_ + +End Sub ' _RootInit V1.1.0 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba new file mode 100644 index 000000000..df964b058 --- /dev/null +++ b/wizards/source/access2base/Collect.xba @@ -0,0 +1,399 @@ +<?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="Collect" 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 MODULE NAME <> COLLECTION (is a reserved name for ... collections) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be COLLECTION +Private _This As Object ' Workaround for absence of This builtin function +Private _CollType As String +Private _Parent As Object +Private _Count As Long + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCOLLECTION + Set _This = Nothing + _CollType = "" + Set _Parent = Nothing + _Count = 0 +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 ----------------------------------------------------------------------------------------------------------------------- + +Property Get Count() As Long + Count = _PropertyGet("Count") +End Property ' Count (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Function Item(ByVal Optional pvItem As Variant) As Variant +'Return property value. +'pvItem either numeric index or property name + +Const cstThisSub = "Collection.getItem" + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvItem) Then Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error + Select Case _CollType + Case COLLCOMMANDBARCONTROLS ' Have no name + If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric()) Then Goto Exit_Function + Case Else + If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End Select + +Dim vNames() As Variant, oProperty As Object + + Set Item = Nothing + Select Case _CollType + Case COLLALLDIALOGS + 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 + If IsNull(_Parent) Then GoTo Error_Parent + Set Item = _Parent.CommandBarControls(pvItem) + Case COLLCONTROLS + If IsNull(_Parent) Then GoTo Error_Parent + Set Item = _Parent.Controls(pvItem) + Case COLLFORMS + Set Item = Application.Forms(pvItem) + Case COLLFIELDS + If IsNull(_Parent) Then GoTo Error_Parent + Set Item = _Parent.Fields(pvItem) + Case COLLPROPERTIES + If IsNull(_Parent) Then GoTo Error_Parent + Select Case _Parent._Type + Case OBJCONTROL, OBJSUBFORM, OBJDATABASE, OBJDIALOG, OBJFIELD _ + , OBJFORM, OBJQUERYDEF, OBJRECORDSET, OBJTABLEDEF + Set Item = _Parent.Properties(pvItem) + Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY + ' NOT SUPPORTED + End Select + Case COLLQUERYDEFS + Set Item = _Parent.QueryDefs(pvItem) + Case COLLRECORDSETS + Set Item = _Parent.Recordsets(pvItem) + Case COLLTABLEDEFS + Set Item = _Parent.TableDefs(pvItem) + Case COLLTEMPVARS + Set Item = Application.TempVars(pvItem) + Case Else + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + Set Item = Nothing + GoTo Exit_Function +Error_Parent: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, True, Array(_GetLabel("OBJECT"), _GetLabel("PARENT"))) + Set Item = Nothing + GoTo Exit_Function +End Function ' Item V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean +' Append a new TableDef or TempVar object to the TableDefs/TempVars collections + +Const cstThisSub = "Collection.Add" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object +Dim vObject As Variant, oTempVar As Object + Add = False + If IsMissing(pvNew) Then Call _TraceArguments() + + Select Case _CollType + Case COLLTABLEDEFS + If Not Utils._CheckArgument(pvNew, 1, vbObject) Then Goto Exit_Function + Set vObject = pvNew + With vObject + Set odbDatabase = ._ParentDatabase + If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Set oConnection = odbDatabase.Connection + If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence + Set oTables = oConnection.getTables() + oTables.appendByDescriptor(.TableDescriptor) + Set .Table = oTables.getByName(._Name) + .CatalogName = .Table.CatalogName + .SchemaName = .Table.SchemaName + .TableName = .Table.Name + .TableDescriptor.dispose() + Set .TableDescriptor = Nothing + .TableFieldsCount = 0 + .TableKeysCount = 0 + End With + Case COLLTEMPVARS + If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function + If pvNew = "" Then Goto Error_Name + If IsMissing(pvValue) Then Call _TraceArguments() + If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name + Set oTempVar = New TempVar + oTempVar._This = oTempVar + oTempVar._Name = pvNew + oTempVar._Value = pvValue + _A2B_.TempVars.Add(oTempVar, UCase(pvNew)) + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count + 1 + Add = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, vObject._Name) + Goto Exit_Function +Error_Name: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew)) + AddItem = False + Goto Exit_Function +End Function ' Add V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Delete(ByVal Optional pvName As Variant) As Boolean +' Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections + +Const cstThisSub = "Collection.Delete" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim odbDatabase As Object, oColl As Object, vName As Variant + Delete = False + If IsMissing(pvName) Then pvName = "" + If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function + If pvName = "" Then Call _TraceArguments() + + Select Case _CollType + Case COLLTABLEDEFS, COLLQUERYDEFS + If _A2B_.CurrentDocIndex() <> 0 Then Goto Error_NotApplicable + Set odbDatabase = Application._CurrentDb() + If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries() + With oColl + vName = _InList(pvName, .getElementNames(), True) + If vName = False Then Goto trace_NotFound + .dropByName(vName) + End With + odbDatabase.Document.store() + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count - 1 + Delete = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName)) + Goto Exit_Function +End Function ' Delete V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Collection.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Collection.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Remove(ByVal Optional pvName As Variant) As Boolean +' Remove a TempVar from the TempVars collection + +Const cstThisSub = "Collection.Remove" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim oColl As Object, vName As Variant + Remove = False + If IsMissing(pvName) Then pvName = "" + If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function + If pvName = "" Then Call _TraceArguments() + + Select Case _CollType + Case COLLTEMPVARS + If Not _A2B_.hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name + _A2B_.TempVars.Remove(UCase(pvName)) + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count - 1 + Remove = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Name: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName)) + AddItem = False + Goto Exit_Function +End Function ' Remove V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveAll() As Boolean +' Remove the whole TempVars collection + +Const cstThisSub = "Collection.Remove" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + + Select Case _CollType + Case COLLTEMPVARS + Set _A2B_.TempVars = New Collection + _Count = 0 + Case Else + Goto Error_NotApplicable + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' RemoveAll V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Count", "Item", "ObjectType") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Collection.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Count") + _PropertyGet = _Count + Case UCase("Item") + Case UCase("ObjectType") + _PropertyGet = _Type + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Collection.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Collection._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/CommandBar.xba b/wizards/source/access2base/CommandBar.xba new file mode 100644 index 000000000..c30f696fb --- /dev/null +++ b/wizards/source/access2base/CommandBar.xba @@ -0,0 +1,396 @@ +<?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="CommandBar" 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 COMMANDBAR +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _ResourceURL As String +Private _Window As Object ' com.sun.star.frame.XFrame +Private _Module As String +Private _Toolbar As Object +Private _BarBuiltin As Integer ' 1 = builtin, 2 = custom stored in LO/AOO (Base), 3 = custom stored in document (Form) +Private _BarType As Integer ' See msoBarTypeXxx constants + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCOMMANDBAR + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _ResourceURL = "" + Set _Window = Nothing + _Module = "" + Set _Toolbar = Nothing + _BarBuiltin = 0 + _BarType = -1 +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 BuiltIn() As Boolean + BuiltIn = _PropertyGet("BuiltIn") +End Property ' BuiltIn (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _Parent +End Function ' Parent (get) V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CommandBarControls(Optional ByVal pvIndex As Variant) As Variant +' Return an object of type CommandBarControl indicated by its index +' Index is different from UNO index: separators do not count +' If no pvIndex argument, return a Collection type + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBar.CommandBarControls" + Utils._SetCalledSub(cstThisSub) + +Dim oLayout As Object, vElements() As Variant, iIndexToolbar As Integer, oToolbar As Object +Dim i As Integer, iItemsCount As Integer, oSettings As Object, vItem() As Variant, bSeparator As Boolean +Dim oObject As Object + + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < 0 Then Goto Trace_IndexError + End If + + Select Case _BarType + Case msoBarTypeNormal, msoBarTypeMenuBar + Case Else : Goto Error_NotApplicable ' Status bar not supported + End Select + + Set oLayout = _Window.LayoutManager + vElements = oLayout.getElements() + iIndexToolbar = _FindElement(vElements()) + If iIndexToolbar < 0 Then Goto Error_NotApplicable ' Toolbar not visible + Set oToolbar = vElements(iIndexToolbar) + + iItemsCount = 0 + Set oSettings = oToolbar.getSettings(False) + + bSeparator = False + For i = 0 To oSettings.getCount() - 1 + Set vItem() = oSettings.getByIndex(i) + If _GetPropertyValue(vItem, "Type", 1) <> 1 Then ' Type = 1 indicates separator + iItemsCount = iItemsCount + 1 + If Not IsMissing(pvIndex) Then + If pvIndex = iItemsCount - 1 Then + Set oObject = New CommandBarControl + With oObject + Set ._This = oObject + Set ._Parent = _This + ._ParentCommandBarName = _Name + ._ParentCommandBar = oToolbar + ._ParentBuiltin = ( _BarBuiltin = 1 ) + ._Element = vItem() + ._InternalIndex = i + ._Index = iItemsCount ' Indexes start at 1 + ._BeginGroup = bSeparator + End With + End If + bSeparator = False + End If + Else + bSeparator = True + End If + Next i + + If IsNull(oObject) Then + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLCOMMANDBARCONTROLS + Set oObject._Parent = _This + oObject._Count = iItemsCount + Case Else ' pvIndex is numeric + Goto Trace_IndexError + End Select + End If + +Exit_Function: + Set CommandBarControls = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' CommandBarControls V1,3,0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Alias for CommandBarControls (VBA) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBar.Controls" + Utils._SetCalledSub(cstThisSub) + +Dim oObject As Object + + If IsMissing(pvIndex) Then Set oObject = CommandBarControls() Else Set oObject = CommandBarControls(pvIndex) + +Exit_Function: + Set Controls = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Controls V1,3,0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("CommandBar.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("CommandBar.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Reset() As Boolean +' Reset a whole command bar to its initial values + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBar.Reset" + Utils._SetCalledSub(cstThisSub) + + _Toolbar.reload() + +Exit_Function: + Reset = True + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Reset = False + GoTo Exit_Function +End Function ' Reset V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _FindElement(pvElements As Variant) As Integer +' Return -1 if not found, otherwise return index in elements table of LayoutManager + +Dim i As Integer + + _FindElement = -1 + If Not IsArray(pvElements) Then Exit Function + + For i = 0 To UBound(pvElements) + If _ResourceURL = pvElements(i).ResourceURL Then + _FindElement = i + Exit Function + End If + Next i + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("BuiltIn", "Name", "ObjectType", "Visible") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBar.get" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertyGet = Nothing + +Dim oLayout As Object, iElementIndex As Integer + + Select Case UCase(psProperty) + Case UCase("BuiltIn") + _PropertyGet = ( _BarBuiltin = 1 ) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Visible") + Set oLayout = _Window.LayoutManager + iElementIndex = _FindElement(oLayout.getElements()) + If iElementIndex < 0 Then _PropertyGet = False Else _PropertyGet = oLayout.isElementVisible(_ResourceURL) + 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, Utils._CalledSub(), Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBar.set" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertySet = True +Dim iArgNr As Integer +Dim oLayout As Object, iElementIndex As Integer + + + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("CommandBar.setProperty") : iArgNr = 2 + Case UCase(cstThisSub) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + Set oLayout = _Window.LayoutManager + With oLayout + iElementIndex = _FindElement(.getElements()) + If iElementIndex < 0 Then + If pvValue Then + .createElement(_ResourceURL) + .showElement(_ResourceURL) + End If + Else + If pvValue <> .isElementVisible(_ResourceURL) Then + If pvValue Then .showElement(_ResourceURL) Else .hideElement(_ResourceURL) + End If + End If + End With + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/CommandBarControl.xba b/wizards/source/access2base/CommandBarControl.xba new file mode 100644 index 000000000..9cf183ba9 --- /dev/null +++ b/wizards/source/access2base/CommandBarControl.xba @@ -0,0 +1,339 @@ +<?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="CommandBarControl" 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 COMMANDBARCONTROL +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _InternalIndex As Integer ' Index in toolbar including separators +Private _Index As Integer ' Index in collection, starting at 1 !! +Private _ControlType As Integer ' 1 of the msoControl* constants +Private _ParentCommandBarName As String +Private _ParentCommandBar As Object ' com.sun.star.ui.XUIElement +Private _ParentBuiltin As Boolean +Private _Element As Variant +Private _BeginGroup As Boolean + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCOMMANDBARCONTROL + Set _This = Nothing + Set _Parent = Nothing + _Index = -1 + _ParentCommandBarName = "" + Set _ParentCommandBar = Nothing + _ParentBuiltin = False + _Element = Array() + _BeginGroup = False +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 BeginGroup() As Boolean + BeginGroup = _PropertyGet("BeginGroup") +End Property ' BeginGroup (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BuiltIn() As Boolean + BuiltIn = _PropertyGet("BuiltIn") +End Property ' BuiltIn (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Index() As Integer + Index = _PropertyGet("Index") +End Property ' Index (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnAction() As Variant + OnAction = _PropertyGet("OnAction") +End Property ' OnAction (get) + +Property Let OnAction(ByVal pvValue As Variant) + Call _PropertySet("OnAction", pvValue) +End Property ' OnAction (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Parent() As Object + Parent = _PropertyGet("Parent") +End Property ' Parent (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TooltipText() As Variant + TooltipText = _PropertyGet("TooltipText") +End Property ' TooltipText (get) + +Property Let TooltipText(ByVal pvValue As Variant) + Call _PropertySet("TooltipText", pvValue) +End Property ' TooltipText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function pType() As Integer + pType = _PropertyGet("Type") +End Function ' Type (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Execute() +' Execute the command stored in a toolbar button + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBarControl.Execute" + Utils._SetCalledSub(cstThisSub) + +Dim sExecute As String + + Execute = True + sExecute = _GetPropertyValue(_Element, "CommandURL", "") + + Select Case True + Case sExecute = "" : Execute = False + Case _IsLeft(sExecute, ".uno:") + Execute = DoCmd.RunCommand(sExecute) + Case _IsLeft(sExecute, "vnd.sun.star.script:") + Execute = Utils._RunScript(sExecute, Array(Nothing)) + Case Else + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Execute = False + GoTo Exit_Function +End Function ' Execute V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("CommandBarControl.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("CommandBar.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("BeginGroup", "BuiltIn", "Caption", "Index" _ + , "ObjectType", "OnAction", "Parent" _ + , "TooltipText", "Type", "Visible" _ + ) +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBarControl.get" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertyGet = Null + +Dim oLayout As Object, iElementIndex As Integer +Dim sValue As String +Const cstUnoPrefix = ".uno:" + + Select Case UCase(psProperty) + Case UCase("BeginGroup") + _PropertyGet = _BeginGroup + Case UCase("BuiltIn") + sValue = _GetPropertyValue(_Element, "CommandURL", "") + _PropertyGet = ( _IsLeft(sValue, cstUnoPrefix) ) + Case UCase("Caption") + _PropertyGet = _GetPropertyValue(_Element, "Label", "") + Case UCase("Index") + _PropertyGet = _Index + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnAction") + _PropertyGet = _GetPropertyValue(_Element, "CommandURL", "") + Case UCase("Parent") + Set _PropertyGet = _Parent + Case UCase("TooltipText") + sValue = _GetPropertyValue(_Element, "Tooltip", "") + If sValue <> "" Then _PropertyGet = sValue Else _PropertyGet = _GetPropertyValue(_Element, "Label", "") + Case UCase("Type") + _PropertyGet = msoControlButton + Case UCase("Visible") + _PropertyGet = _GetPropertyValue(_Element, "IsVisible", "") + 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, Utils._CalledSub(), Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBarControl.set" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertySet = True +Dim iArgNr As Integer +Dim oSettings As Object, sValue As String + + + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("CommandBar.setProperty") : iArgNr = 2 + Case UCase(cstThisSub) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + If _ParentBuiltin Then Goto Trace_Error ' Modifications of individual controls forbidden for builtin toolbars (design choice) + +Const cstUnoPrefix = ".uno:" +Const cstScript = "vnd.sun.star.script:" + + Set oSettings = _ParentCommandBar.getSettings(True) + Select Case UCase(psProperty) + Case UCase("OnAction") + If Not Utils._CheckArgument(pvValue, iArgNr, _AddNumeric(vbString), , False) Then Goto Trace_Error_Value + Select Case VarType(pvValue) + Case vbString + If _IsLeft(pvValue, cstUnoPrefix) Then + sValue = pvValue + ElseIf _IsLeft(pvValue, cstScript) Then + sValue = pvValue + Else + sValue = DoCmd.RunCommand(pvValue, True) + End If + Case Else ' Numeric + sValue = DoCmd.RunCommand(pvValue, True) + End Select + _SetPropertyValue(_Element, "CommandURL", sValue) + Case UCase("TooltipText") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + _SetPropertyValue(_Element, "Tooltip", pvValue) + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + _SetPropertyValue(_Element, "IsVisible", pvValue) + Case Else + Goto Trace_Error + End Select + oSettings.replaceByIndex(_InternalIndex, _Element) + _ParentCommandBar.setSettings(oSettings) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba new file mode 100644 index 000000000..5e241186f --- /dev/null +++ b/wizards/source/access2base/Control.xba @@ -0,0 +1,2501 @@ +<?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="Control" 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 CONTROL +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _ImplementationName As String +Private _ClassId As Integer +Private _ParentType As String ' One of CTLPARENTISxxxx constants +Private _Shortcut As String +Private _Name As String +Private _FormComponent As Object ' com.sun.star.text.TextDocument +Private _MainForm As String ' To be propagated to all subcontrols +Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure +Private _DbEntry As Integer +Private _ControlType As Integer +Private _ThisProperties As Variant ' Buffer for properties list +Private _SubType As String +Private ControlModel As Object ' com.sun.star.comp.forms.XXXModel +Private ControlView As Object ' com.sun.star.comp.forms.XXXControl (NULL if form open in edit mode) +Private BoundField As Object ' com.sun.star.sdb.ODataColumn +Private LabelControl As Object ' com.sun.star.form.component.FixedText or com.sun.star.form.component.GroupBox + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCONTROL + Set _This = Nothing + Set _Parent = Nothing + _ClassId = -1 + _ParentType = "" + _Shortcut = "" + _Name = "" + Set _FormComponent = Nothing + _MainForm = "" + _DocEntry = -1 + _DbEntry = -1 + _ThisProperties = Array() + _SubType = "" + Set ControlModel = Nothing + Set ControlView = Nothing + Set BoundField = Nothing + Set LabelControl = Nothing + +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 ----------------------------------------------------------------------------------------------------------------------- + +Property Get BackColor() As Variant + BackColor = _PropertyGet("BackColor") +End Property ' BackColor (get) + +Property Let BackColor(ByVal pvValue As Variant) + Call _PropertySet("BackColor", pvValue) +End Property ' BackColor (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BorderColor() As Variant + BorderColor = _PropertyGet("BorderColor") +End Property ' BorderColor (get) + +Property Let BorderColor(ByVal pvValue As Variant) + Call _PropertySet("BorderColor", pvValue) +End Property ' BorderColor (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BorderStyle() As Variant + BorderStyle = _PropertyGet("BorderStyle") +End Property ' BorderStyle (get) + +Property Let BorderStyle(ByVal pvValue As Variant) + Call _PropertySet("BorderStyle", pvValue) +End Property ' BorderStyle (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Cancel() As Variant + Cancel = _PropertyGet("Cancel") +End Property ' Cancel (get) + +Property Let Cancel(ByVal pvValue As Variant) + Call _PropertySet("Cancel", pvValue) +End Property ' Cancel (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ControlSource() As Variant + ControlSource = _PropertyGet("ControlSource") +End Property ' ControlSource (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ControlTipText() As Variant + ControlTipText = _PropertyGet("ControlTipText") +End Property ' ControlTipText (get) + +Property Let ControlTipText(ByVal pvValue As Variant) + Call _PropertySet("ControlTipText", pvValue) +End Property ' ControlTipText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ControlType() As Variant + ControlType = _PropertyGet("ControlType") +End Property ' ControlType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Default() As Variant + Default = _PropertyGet("Default") +End Property ' Default (get) + +Property Let Default(ByVal pvValue As Variant) + Call _PropertySet("Default", pvValue) +End Property ' Default (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get DefaultValue() As Variant + DefaultValue = _PropertyGet("DefaultValue") +End Property ' DefaultValue (get) + +Property Let DefaultValue(ByVal pvValue As Variant) + Call _PropertySet("DefaultValue", pvValue) +End Property ' DefaultValue (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Enabled() As Variant + Enabled = _PropertyGet("Enabled") +End Property ' Enabled (get) + +Property Let Enabled(ByVal pvValue As Variant) + Call _PropertySet("Enabled", pvValue) +End Property ' Enabled (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontBold() As Variant + FontBold = _PropertyGet("FontBold") +End Property ' FontBold (get) + +Property Let FontBold(ByVal pvValue As Variant) + Call _PropertySet("FontBold", pvValue) +End Property ' FontBold (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontItalic() As Variant + FontItalic = _PropertyGet("FontItalic") +End Property ' FontItalic (get) + +Property Let FontItalic(ByVal pvValue As Variant) + Call _PropertySet("FontItalic", pvValue) +End Property ' FontItalic (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontName() As Variant + FontName = _PropertyGet("FontName") +End Property ' FontName (get) + +Property Let FontName(ByVal pvValue As Variant) + Call _PropertySet("FontName", pvValue) +End Property ' FontName (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontSize() As Variant + FontSize = _PropertyGet("FontSize") +End Property ' FontSize (get) + +Property Let FontSize(ByVal pvValue As Variant) + Call _PropertySet("FontSize", pvValue) +End Property ' FontSize (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontUnderline() As Variant + FontUnderline = _PropertyGet("FontUnderline") +End Property ' FontUnderline (get) + +Property Let FontUnderline(ByVal pvValue As Variant) + Call _PropertySet("FontUnderline", pvValue) +End Property ' FontUnderline (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontWeight() As Variant + FontWeight = _PropertyGet("FontWeight") +End Property ' FontWeight (get) + +Property Let FontWeight(ByVal pvValue As Variant) + Call _PropertySet("FontWeight", pvValue) +End Property ' FontWeight (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ForeColor() As Variant + ForeColor = _PropertyGet("ForeColor") +End Property ' ForeColor (get) + +Property Let ForeColor(ByVal pvValue As Variant) + Call _PropertySet("ForeColor", pvValue) +End Property ' ForeColor (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Form() As Variant + Form = _PropertyGet("Form") +End Property ' Form (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Format() As Variant + Format = _PropertyGet("Format") +End Property ' Format (get) + +Property Let Format(ByVal pvValue As Variant) + Call _PropertySet("Format", pvValue) +End Property ' Format (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ItemData(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then ItemData = _PropertyGet("ItemData") Else ItemData = _PropertyGet("ItemData", pvIndex) +End Property ' ItemData (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ListCount() As Variant + ListCount = _PropertyGet("ListCount") +End Property ' ListCount (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ListIndex() As Variant + ListIndex = _PropertyGet("ListIndex") +End Property ' ListIndex (get) + +Property Let ListIndex(ByVal pvValue As Variant) + Call _PropertySet("ListIndex", pvValue) +End Property ' ListIndex (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Locked() As Variant + Locked = _PropertyGet("Locked") +End Property ' Locked (get) + +Property Let Locked(ByVal pvValue As Variant) + Call _PropertySet("Locked", pvValue) +End Property ' Locked (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get MultiSelect() As Variant + MultiSelect = _PropertyGet("MultiSelect") +End Property ' MultiSelect (get) + +Property Let MultiSelect(ByVal pvValue As Variant) + Call _PropertySet("MultiSelect", pvValue) +End Property ' MultiSelect (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnActionPerformed() As Variant + OnActionPerformed = _PropertyGet("OnActionPerformed") +End Property ' OnActionPerformed (get) + +Property Let OnActionPerformed(ByVal pvValue As Variant) + Call _PropertySet("OnActionPerformed", pvValue) +End Property ' OnActionPerformed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnAdjustmentValueChanged() As Variant + OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged") +End Property ' OnAdjustmentValueChanged (get) + +Property Let OnAdjustmentValueChanged(ByVal pvValue As Variant) + Call _PropertySet("OnAdjustmentValueChanged", pvValue) +End Property ' OnAdjustmentValueChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveAction() As Variant + OnApproveAction = _PropertyGet("OnApproveAction") +End Property ' OnApproveAction (get) + +Property Let OnApproveAction(ByVal pvValue As Variant) + Call _PropertySet("OnApproveAction", pvValue) +End Property ' OnApproveAction (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' OnApproveReset (get) + +Property Let OnApproveReset(ByVal pvValue As Variant) + Call _PropertySet("OnApproveReset", pvValue) +End Property ' OnApproveReset (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveUpdate() As Variant + OnApproveUpdate = _PropertyGet("OnApproveUpdate") +End Property ' OnApproveUpdate (get) + +Property Let OnApproveUpdate(ByVal pvValue As Variant) + Call _PropertySet("OnApproveUpdate", pvValue) +End Property ' OnApproveUpdate (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnChanged() As Variant + OnChanged = _PropertyGet("OnChanged") +End Property ' OnChanged (get) + +Property Let OnChanged(ByVal pvValue As Variant) + Call _PropertySet("OnChanged", pvValue) +End Property ' OnChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' OnErrorOccurred (get) + +Property Let OnErrorOccurred(ByVal pvValue As Variant) + Call _PropertySet("OnErrorOccurred", pvValue) +End Property ' OnErrorOccurred (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' OnFocusGained (get) + +Property Let OnFocusGained(ByVal pvValue As Variant) + Call _PropertySet("OnFocusGained", pvValue) +End Property ' OnFocusGained (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' OnFocusLost (get) + +Property Let OnFocusLost(ByVal pvValue As Variant) + Call _PropertySet("OnFocusLost", pvValue) +End Property ' OnFocusLost (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnItemStateChanged() As Variant + OnItemStateChanged = _PropertyGet("OnItemStateChanged") +End Property ' OnItemStateChanged (get) + +Property Let OnItemStateChanged(ByVal pvValue As Variant) + Call _PropertySet("OnItemStateChanged", pvValue) +End Property ' OnItemStateChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' OnKeyPressed (get) + +Property Let OnKeyPressed(ByVal pvValue As Variant) + Call _PropertySet("OnKeyPressed", pvValue) +End Property ' OnKeyPressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' OnKeyReleased (get) + +Property Let OnKeyReleased(ByVal pvValue As Variant) + Call _PropertySet("OnKeyReleased", pvValue) +End Property ' OnKeyReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' OnMouseDragged (get) + +Property Let OnMouseDragged(ByVal pvValue As Variant) + Call _PropertySet("OnMouseDragged", pvValue) +End Property ' OnMouseDragged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' OnMouseEntered (get) + +Property Let OnMouseEntered(ByVal pvValue As Variant) + Call _PropertySet("OnMouseEntered", pvValue) +End Property ' OnMouseEntered (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' OnMouseExited (get) + +Property Let OnMouseExited(ByVal pvValue As Variant) + Call _PropertySet("OnMouseExited", pvValue) +End Property ' OnMouseExited (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' OnMouseMoved (get) + +Property Let OnMouseMoved(ByVal pvValue As Variant) + Call _PropertySet("OnMouseMoved", pvValue) +End Property ' OnMouseMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' OnMousePressed (get) + +Property Let OnMousePressed(ByVal pvValue As Variant) + Call _PropertySet("OnMousePressed", pvValue) +End Property ' OnMousePressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' OnMouseReleased (get) + +Property Let OnMouseReleased(ByVal pvValue As Variant) + Call _PropertySet("OnMouseReleased", pvValue) +End Property ' OnMouseReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnResetted() As Variant + OnResetted = _PropertyGet("OnResetted") +End Property ' OnResetted (get) + +Property Let OnResetted(ByVal pvValue As Variant) + Call _PropertySet("OnResetted", pvValue) +End Property ' OnResetted (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnTextChanged() As Variant + OnTextChanged = _PropertyGet("OnTextChanged") +End Property ' OnTextChanged (get) + +Property Let OnTextChanged(ByVal pvValue As Variant) + Call _PropertySet("OnTextChanged", pvValue) +End Property ' OnTextChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUpdated() As Variant + OnUpdated = _PropertyGet("OnUpdated") +End Property ' OnUpdated (get) + +Property Let OnUpdated(ByVal pvValue As Variant) + Call _PropertySet("OnUpdated", pvValue) +End Property ' OnUpdated (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OptionValue() As Variant + OptionValue = _PropertyGet("OptionValue") +End Property ' OptionValue (get) + +Property Let OptionValue(ByVal pvValue As Variant) + Call _PropertySet("OptionValue", pvValue) +End Property ' OptionValue (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Page() As Variant + Page = _PropertyGet("Page") +End Property ' Page (get) + +Property Let Page(ByVal pvValue As Variant) + Call _PropertySet("Page", pvValue) +End Property ' Page (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _PropertyGet("Parent") +End Function ' Parent (get) V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Picture() As Variant + Picture = _PropertyGet("Picture") +End Property ' Picture (get) + +Property Let Picture(ByVal pvValue As Variant) + Call _PropertySet("Picture", pvValue) +End Property ' Picture (set) V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + + Utils._SetCalledSub("Control.Properties") +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub("Control.Properties") + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Required() As Variant + Required = _PropertyGet("Required") +End Property ' Required (get) + +Property Let Required(ByVal pvValue As Variant) + Call _PropertySet("Required", pvValue) +End Property ' Required (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RowSource() As Variant + RowSource = _PropertyGet("RowSource") +End Property ' RowSource (get) + +Property Let RowSource(ByVal pvValue As Variant) + Call _PropertySet("RowSource", pvValue) +End Property ' RowSource (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RowSourceType() As Variant + RowSourceType = _PropertyGet("RowSourceType") +End Property ' RowSourceType (get) + +Property Let RowSourceType(ByVal pvValue As Variant) + Call _PropertySet("RowSourceType", pvValue) +End Property ' RowSourceType (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Selected(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then Selected = _PropertyGet("Selected") Else Selected = _PropertyGet("Selected", pvIndex) +End Property ' Selected (get) + +Property Let Selected(ByVal pvValue As Variant) ' , ByVal Optional pvIndex As Variant) +' If IsMissing(pvIndex) Then Call _PropertySet("Selected", pvValue) Else Call _PropertySet("Selected", pvValue, pvIndex) + Call _PropertySet("Selected", pvValue) +End Property ' Selected (set) + +Public Function SelectedI(ByVal pvValue As variant, ByVal pvIndex As Variant) + Call _PropertySet("Selected", pvValue, pvIndex) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelLength() As Variant + SelLength = _PropertyGet("SelLength") +End Property ' SelLength (get) + +Property Let SelLength(ByVal pvValue As Variant) + Call _PropertySet("SelLength", pvValue) +End Property ' SelLength (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelStart() As Variant + SelStart = _PropertyGet("SelStart") +End Property ' SelStart (get) + +Property Let SelStart(ByVal pvValue As Variant) + Call _PropertySet("SelStart", pvValue) +End Property ' SelStart (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelText() As Variant + SelText = _PropertyGet("SelText") +End Property ' SelText (get) + +Property Let SelText(ByVal pvValue As Variant) + Call _PropertySet("SelText", pvValue) +End Property ' SelText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SpecialEffect() As Variant + SpecialEffect = _PropertyGet("SpecialEffect") +End Property ' SpecialEffect (get) + +Property Let SpecialEffect(ByVal pvValue As Variant) + Call _PropertySet("SpecialEffect", pvValue) +End Property ' SpecialEffect (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SubType() As Variant + SubType = _PropertyGet("SubType") +End Property ' SubType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TabIndex() As Variant + TabIndex = _PropertyGet("TabIndex") +End Property ' TabIndex (get) + +Property Let TabIndex(ByVal pvValue As Variant) + Call _PropertySet("TabIndex", pvValue) +End Property ' TabIndex (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TabStop() As Variant + TabStop = _PropertyGet("TabStop") +End Property ' TabStop (get) + +Property Let TabStop(ByVal pvValue As Variant) + Call _PropertySet("TabStop", pvValue) +End Property ' TabStop (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Tag() As Variant + Tag = _PropertyGet("Tag") +End Property ' Tag (get) + +Property Let Tag(ByVal pvValue As Variant) + Call _PropertySet("Tag", pvValue) +End Property ' Tag (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Text() As Variant + Text = _PropertyGet("Text") +End Property ' Text (get) + +Public Function pText() As variant + pText = _PropertyGet("Text") +End Function ' pText (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TextAlign() As Variant + TextAlign = _PropertyGet("TextAlign") +End Property ' TextAlign (get) + +Property Let TextAlign(ByVal pvValue As Variant) + Call _PropertySet("TextAlign", pvValue) +End Property ' TextAlign (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TripleState() As Variant + TripleState = _PropertyGet("TripleState") +End Property ' TripleState (get) + +Property Let TripleState(ByVal pvValue As Variant) + Call _PropertySet("TripleState", pvValue) +End Property ' TripleState (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function AddItem(ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean +' Add an item in a Listbox + + Utils._SetCalledSub("Control.AddItem") + AddItem = False + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvIndex) Then pvIndex = -1 + +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("AddItem") : iArgNr = 1 + Case UCase("Control.AddItem") : iArgNr = 0 + End Select + + If Not Utils._CheckArgument(pvItem, iArgNr + 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvIndex, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function + If _SubType <> CTLLISTBOX Then Goto Error_Control + If _ParentType <> CTLPARENTISDIALOG Then + If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control + End If + +Dim vRowSource() As Variant, iCount As Integer, i As Integer + If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList) + iCount = UBound(vRowSource) + If pvIndex < -1 Or pvIndex > iCount + 1 Then Goto Error_Index + ReDim Preserve vRowSource(0 To iCount + 1) + If pvIndex = -1 Then pvIndex = iCount + 1 + For i = iCount + 1 To pvIndex + 1 Step -1 + vRowSource(i) = vRowSource(i - 1) + Next i + vRowSource(pvIndex) = pvItem + + If _ParentType <> CTLPARENTISDIALOG Then + ControlModel.ListSource = vRowSource() + End If + ControlModel.StringItemList = vRowSource() + AddItem = True + +Exit_Function: + Utils._ResetCalledSub("Control.AddItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.AddItem", Erl) + AddItem = False + GoTo Exit_Function +Error_Control: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Control.AddItem") + AddItem = False + Goto Exit_Function +Error_Index: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(iArgNr + 2,pvIndex)) + AddItem = False + Goto Exit_Function +End Function ' AddItem V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +Const cstThisSub = "Control.Controls" +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + +Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer, oView As Object + + If _SubType <> CTLGRIDCONTROL Then Goto Trace_Error_Context + Set ocControl = Nothing + iControlCount = ControlModel.getCount() + + If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + oCounter._Count = iControlCount + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISGRID + sParentShortcut = _Shortcut + sControls() = ControlModel.getElementNames() + + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + ocControl._Name = sControls(pvIndex) + Case vbString ' Check control name validity (non case sensitive) + bFound = False + sIndex = UCase(Utils._Trim(pvIndex)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sIndex Then + bFound = True + Exit For + End If + Next i + If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + End Select + + With ocControl + ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) + Set .ControlModel = ControlModel.getByName(._Name) + ._ImplementationName = .ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? + ._FormComponent = ParentComponent + ._MainForm = _MainForm + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + ' Complex bypass to find View of grid subcontrols ! + If Not IsNull(ControlView) Then ' Anticipate absence of ControlView in grid controls when edit mode + For i = 0 to ControlView.getCount() - 1 + Set oView = ControlView.GetByIndex(i) + If Not IsNull(oView) Then + If oView.getModel.Name = ._Name Then + Set .ControlView = oView + Exit For + End If + End If + Next i + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_Context: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Grid.Controls") + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Control.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + If IsMissing(pvIndex) Then + getProperty = _PropertyGet(pvProperty) + Else + getProperty = _PropertyGet(pvProperty, pvIndex) + End If + Utils._ResetCalledSub("Control.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveItem(ByVal Optional pvIndex) As Boolean +' Remove an item from a Listbox +' Index may be a string value or an index-position + + Utils._SetCalledSub("Control.RemoveItem") + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvIndex) Then Call _TraceArguments() +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("RemoveItem") : iArgNr = 1 + Case UCase("Control.RemoveItem") : iArgNr = 0 + End Select + If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + If _SubType <> CTLLISTBOX Then Goto Error_Control + If _ParentType <> CTLPARENTISDIALOG Then + If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control + End If + +Dim vRowSource() As Variant, iCount As Integer, i As Integer, j As integer, bFound As Boolean + If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList) + iCount = UBound(vRowSource) + + Select Case VarType(pvIndex) + Case vbString + bFound = False + For i = 0 To iCount + If vRowSource(i) = pvIndex Then + For j = i To iCount - 1 + vRowSource(j) = vRowSource(j + 1) + Next j + bFound = True + Exit For ' Remove only 1st occurrence of string + End If + Next i + Case Else + If pvIndex < 0 Or pvIndex > iCount Then Goto Error_Index + For i = pvIndex To iCount - 1 + vRowSource(i) = vRowSource(i + 1) + Next i + bFound = True + End Select + + If bFound Then + If iCount > 0 Then ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=75008 + ReDim Preserve vRowSource(0 To iCount - 1) + Else + vRowSource = Array() + End If + If _ParentType <> CTLPARENTISDIALOG Then + ControlModel.ListSource = vRowSource() + End If + ControlModel.StringItemList = vRowSource() + RemoveItem = True + Else + RemoveItem = False + End If + +Exit_Function: + Utils._ResetCalledSub("Control.RemoveItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.RemoveItem", Erl) + RemoveItem = False + GoTo Exit_Function +Error_Control: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.RemoveItem") + RemoveItem = False + Goto Exit_Function +Error_Index: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(2, pvIndex)) + RemoveItem = False + Goto Exit_Function +End Function ' RemoveItem V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery() As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("Control.Requery") + If _ErrorHandler() Then On Local Error Goto Error_Function + Requery = False + + Select Case _SubType + Case CTLCOMBOBOX, CTLLISTBOX + If Utils._InList(ControlModel.ListSourceType, Array( _ + com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.TABLEFIELDS _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + )) Then + ControlModel.refresh() + End If + Case Else + Goto Error_Control + End Select + Requery = True + +Exit_Function: + Utils._ResetCalledSub("Control.Requery") + Exit Function +Error_Control: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.Requery") + Requery = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.Requery", Erl) + GoTo Exit_Function +End Function ' Requery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetFocus() As Boolean +' Execute setFocus method + Utils._SetCalledSub("Control.SetFocus") + If _ErrorHandler() Then On Local Error Goto Error_Function + SetFocus = False + +Dim i As Integer, j As Integer, iColPosition As Integer +Dim ocControl As Object, ocGrid As Variant, oGridModel As Object + + If IsNull(ControlView) Then GoTo Exit_Function + If _ParentType = CTLPARENTISGRID Then 'setFocus method does not work on controlviews in grid ?!? + ' Find column position of control + iColPosition = -1 + ocGrid = getObject(_getUpperShortcut(_Shortcut, _Name)) ' return containing grid + Set oGridModel = ocGrid.ControlModel + j = -1 + For i = 0 To oGridModel.Count - 1 + Set ocControl = oGridModel.GetByIndex(i) + If Not ocControl.Hidden Then j = j + 1 ' Skip if hidden + If oGridModel.GetByIndex(i).Name = _Name Then + iColPosition = j + Exit For + End If + Next i + If iColPosition >= 0 Then + ocGrid.ControlView.setFocus() 'Set first focus on grid itself + ocGrid.ControlView.setCurrentColumnPosition(iColPosition) 'Deprecated but no alternative found + Else + Goto Error_Grid + End If + Else + ControlView.setFocus() + End If + SetFocus = True + +Exit_Function: + Utils._ResetCalledSub("Control.SetFocus") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.SetFocus", Erl) + Goto Exit_Function +Error_Grid: + TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(_Name, ocGrid._Name)) + Goto Exit_Function +End Function ' SetFocus V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("Control.setProperty") + If IsMissing(pvIndex) Then + setProperty = _PropertySet(psProperty, pvValue) + Else + setProperty = _PropertySet(psProperty, pvValue, pvIndex) + End If + Utils._ResetCalledSub("Control.setProperty") +End Function ' setProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetSelected(ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Workaround for limitation of Basic: Property Let does not accept optional arguments + + If IsMissing(pvValue) Then Call _TraceArguments() + If IsMissing(pvIndex) Then + SetSelected = _PropertySet("Selected", pvValue) + Else + SetSelected = _PropertySet("Selected", pvValue, pvIndex) + End If + +End Function ' SetSelected + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _Formats(ByVal psControlType As String) As Variant +' Return allowed format entries for Date and Time control types + +Dim vFormats() As Variant + Select Case psControlType + Case CTLDATEFIELD + vFormats = Array( _ + "Standard (short)" _ + , "Standard (short YY)" _ + , "Standard (short YYYY)" _ + , "Standard (long)" _ + , "DD/MM/YY" _ + , "MM/DD/YY" _ + , "YY/MM/DD" _ + , "DD/MM/YYYY" _ + , "MM/DD/YYYY" _ + , "YYYY/MM/DD" _ + , "YY-MM-DD" _ + , "YYYY-MM-DD" _ + ) + Case CTLTIMEFIELD + vFormats = Array( _ + "24h short" _ + , "24h long" _ + , "12h short" _ + , "12h long" _ + ) + Case Else + vFormats = Array() + End Select + + _Formats = vFormats + +End Function ' _Formats V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnActionPerformed") + _GetListener = "XActionListener" + Case UCase("OnAdjustmentValueChanged") + _GetListener = "XAdjustmentListener" + Case UCase("OnApproveAction") + _GetListener = "XApproveActionListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveUpdate"), UCase("OnUpdated") + _GetListener = "XUpdateListener" + Case UCase("OnChanged") + _GetListener = "XChangeListener" + Case UCase("OnErrorOccurred") + _GetListener = "XErrorListener" + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnItemStateChanged") + _GetListener = "XItemListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case UCase("OnTextChanged") + _GetListener = "XTextListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize() +' Initialize new Control +' ControlModel, ParentType, Name, Shortcut, ControlView, ImplementationName, ClassId (if parent <> dialog) +' are presumed preexisting + + ' Identify SubType and ControlView +Dim sControlTypes() As Variant, i As Integer, vSplit() As Variant, sTrailer As String + sControlTypes = array( CTLCONTROL _ + , CTLCOMMANDBUTTON _ + , CTLRADIOBUTTON _ + , CTLIMAGEBUTTON _ + , CTLCHECKBOX _ + , CTLLISTBOX _ + , CTLCOMBOBOX _ + , CTLGROUPBOX _ + , CTLTEXTFIELD _ + , CTLFIXEDTEXT _ + , CTLGRIDCONTROL _ + , CTLFILECONTROL _ + , CTLHIDDENCONTROL _ + , CTLIMAGECONTROL _ + , CTLDATEFIELD _ + , CTLTIMEFIELD _ + , CTLNUMERICFIELD _ + , CTLCURRENCYFIELD _ + , CTLPATTERNFIELD _ + , CTLSCROLLBAR _ + , CTLSPINBUTTON _ + , CTLNAVIGATIONBAR _ + , CTLPROGRESSBAR _ + , CTLFIXEDLINE _ + ) + + Select Case _ParentType + Case CTLPARENTISDIALOG + vSplit = Split(ControlModel.getServiceName(), ".") + sTrailer = UCase(vSplit(UBound(vSplit))) + ' Manage homonyms + Select Case sTrailer + Case "BUTTON" : sTrailer = CTLCOMMANDBUTTON + Case "EDIT" : sTrailer = CTLTEXTFIELD + Case Else + End Select + If sTrailer <> CTLFORMATTEDFIELD Then + For i = 0 To UBound(sControlTypes) + If sControlTypes(i) = sTrailer Then + _ClassId = i + 1 + _SubType = sTrailer + _ControlType = _ClassId + Exit For + End If + Next i + Else + _ClassId = acFormattedField + _SubType = CTLFORMATTEDFIELD + _ControlType = _ClassId + End If + Case Else + 'Is ClassId one of the properties ? + If _ClassId > 0 Then ' All control types have a ClassId except subforms + _SubType = sControlTypes(_ClassId - 1) + _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 + End If + End If + Else ' Initialize subform Control + If ControlModel.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then + _SubType = CTLSUBFORM + _ControlType = acSubform + End If + End If + End Select + +End Sub ' _Initialize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ListboxBound() As Boolean +' Return True if listbox has a bound column + +Dim bListboxBound As Boolean, j As Integer +Dim vValue() As variant, vString As Variant + + bListboxBound = False + + If Not IsNull(ControlModel.ValueItemList) _ + And ControlModel.DataField <> "" _ + And Not IsNull(ControlModel.BoundField) _ + And Utils._InList(ControlModel.ListSourceType, Array( _ + com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + )) Then ' MultiSelect behaviour changed in OpenOffice >= 3.3 + If IsArray(ControlModel.ValueItemList) Then + vValue = ControlModel.ValueItemList + vString = ControlModel.StringItemList + For j = 0 To UBound(vValue) + If VarType(vValue(j)) <> VarType(vString(j)) Then + bListboxBound = True + ElseIf vValue(j) <> vString(j) Then + bListboxBound = True + End If + If bListboxBound Then Exit For + Next j + End If + End If + + _ListboxBound = bListboxBound + +End Function ' _ListboxBound V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant +' Based on ControlProperties.ods analysis + +Dim vFullPropertiesList() As Variant + + 'List established only once + If UBound(_ThisProperties) > -1 Then + _PropertiesList = _ThisProperties + Exit Function + End If + + vFullPropertiesList = Array( _ + "BackColor" _ + , "BorderColor" _ + , "BorderStyle" _ + , "Cancel" _ + , "Caption" _ + , "ControlSource" _ + , "ControlTipText" _ + , "ControlType" _ + , "Default" _ + , "DefaultValue" _ + , "Enabled" _ + , "FontBold" _ + , "FontItalic" _ + , "FontName" _ + , "FontSize" _ + , "FontUnderline" _ + , "FontWeight" _ + , "ForeColor" _ + , "Form" _ + , "Format" _ + , "ItemData" _ + , "LinkChildFields" _ + , "LinkMasterFields" _ + , "ListCount" _ + , "ListIndex" _ + , "Locked" _ + , "MultiSelect" _ + , "Name" _ + , "ObjectType" _ + , "OnActionPerformed" _ + , "OnAdjustmentValueChanged" _ + , "OnApproveAction" _ + , "OnApproveReset" _ + , "OnApproveUpdate" _ + , "OnChanged" _ + , "OnErrorOccurred" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnItemStateChanged" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "OnResetted" _ + , "OnTextChanged" _ + , "OnUpdated" _ + , "OptionValue" _ + , "Page" _ + , "Parent" _ + , "Picture" _ + , "Required" _ + , "RowSource" _ + , "RowSourceType" _ + , "Selected" _ + , "SelLength" _ + , "SelStart" _ + , "Seltext" _ + , "SpecialEffect" _ + , "SubType" _ + , "TabIndex" _ + , "TabStop" _ + , "Tag" _ + , "Text" _ + , "TextAlign" _ + , "TripleState" _ + , "Value" _ + , "Visible" _ + ) +Dim vPropertiesMatrix(25) As Variant + Select Case _ParentType + Case CTLPARENTISFORM, CTLPARENTISSUBFORM + vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,63,64,65,67,68,69,70) + vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,41,42,43,44,45,46,47,52,53,62,63,64,65,67,69,70) + vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70) + vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,48,52,62,63,64,65,66,69,70) + vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,65,67,70) + vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,70) + vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,62,65,70) + vPropertiesMatrix(acHiddenControl) = Array(7,27,28,52,62,65,69,70) + vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,36,37,39,40,41,42,43,44,45,46,52,53,62,63,64,65,70) + vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,53,54,62,63,64,65,70) + vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,63,64,65,67,69,70) + vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,63,64,65,70) + vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70) + vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70) + vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70) + vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70) + vPropertiesMatrix(0) = Array(7,18,21,22,27,28,52,62) + vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) + Case CTLPARENTISGROUP + ' To be duplicated from above !!! + vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70) + Case CTLPARENTISGRID + vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,65,67,68,69) + vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,65,66,67,69) + vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69) + vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) + vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) + vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,65,67,69) + vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69) + vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69) + vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69) + vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) + Case CTLPARENTISDIALOG + vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,61,62,63,64,65,67,68,69,70) + vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,36,37,38,39,40,41,42,43,44,45,46,48,51,52,55,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,67,70) + vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70) + vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70) + vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,67,70) + vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70) + vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,70) + vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,55,57,62,63,64,65,67,69,70) + vPropertiesMatrix(acNavigationBar) = Array(36,37,39,40,41,42,43,44,45,46) + vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70) + vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,69,70) + vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,50,51,52,61,62,63,64,65,67,69,70) + vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,69,70) + vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + End Select + +Dim i As Integer, iIndex As Integer + If _ControlType = acSubForm Then iIndex = 0 Else iIndex = _ControlType + If IsEmpty(vPropertiesMatrix(iIndex)) Then + _ThisProperties = Array() + Else + ReDim _ThisProperties(0 To UBound(vPropertiesMatrix(iIndex))) + For i = 0 To UBound(_ThisProperties) + _ThisProperties(i) = vFullPropertiesList(vPropertiesMatrix(iIndex)(i)) + Next i + End If + + _PropertiesList = _ThisProperties() + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant +' Return property value of the psProperty property name + +Dim iArg As Integer + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Control.get" & psProperty) + _PropertyGet = EMPTY + +'Check Index argument +Dim iArgNr As Integer + If Not IsMissing(pvIndex) Then + Select Case UCase(_A2B_.CalledSub) + Case UCase("getProperty") : iArgNr = 3 + Case UCase("Control.getProperty") : iArgNr = 2 + Case UCase("Control.get" & psProperty) : iArgNr = 1 + End Select + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + End If + +Dim vDefaultValue As Variant, oDefaultValue As Object, vValue As Variant, oValue As Object, iIndex As Integer +Dim lListIndex As Long, i As Integer, j As Integer, vCurrentValue As Variant, lListCount As Long +Dim vListboxValue As Variant, vListSource, bSelected() As Boolean, bListboxBound As Boolean +Dim vGet As Variant, vDate As Variant +Dim ofSubForm As Object +Dim vFormats() As Variant +Dim vSelection As Variant, sSelectedText As String +Dim oControlEvents As Object, sEventName As String + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("BackColor") + If Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then _PropertyGet = ControlModel.BackgroundColor + Case UCase("BorderColor") + If Utils._hasUNOProperty(ControlModel, "BorderColor") Then _PropertyGet = ControlModel.BorderColor + Case UCase("BorderStyle") + If Utils._hasUNOProperty(ControlModel, "Border") Then _PropertyGet = ControlModel.Border + Case UCase("Cancel") + If Utils._hasUNOProperty(ControlModel, "PushButtonType") Then _PropertyGet = ( ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL ) + Case UCase("Caption") + If Utils._hasUNOProperty(ControlModel, "Label") Then _PropertyGet = ControlModel.Label + Case UCase("ControlSource") + If Utils._hasUNOProperty(ControlModel, "DataField") Then _PropertyGet = ControlModel.DataField + Case UCase("ControlTipText") + If Utils._hasUNOProperty(ControlModel, "HelpText") Then _PropertyGet = ControlModel.HelpText + Case UCase("ControlType") + _PropertyGet = _ControlType + Case UCase("Default") + If Utils._hasUNOProperty(ControlModel, "DefaultButton") Then _PropertyGet = ControlModel.DefaultButton + Case UCase("DefaultValue") + Select Case _SubType + Case CTLCHECKBOX, CTLRADIOBUTTON + If Utils._hasUNOProperty(ControlModel, "DefaultState") Then _PropertyGet = ControlModel.DefaultState + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultText") Then _PropertyGet = ControlModel.DefaultText + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultValue") Then _PropertyGet = ControlModel.DefaultValue + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultDate") Then + Select Case VarType(ControlModel.DefaultDate) + Case vbLong ' AOO and LO <= 4.1 + vDefaultValue = ControlModel.DefaultDate + vGet = DateSerial(Left(vDefaultValue, 4), Mid(vDefaultValue, 5, 2), Right(vDefaultValue, 2)) + Case vbObject ' LO >= 4.2 com.sun.star.Util.Date + Set oDefaultValue = ControlModel.DefaultDate + vGet = DateSerial(oDefaultValue.Year,oDefaultValue.Month, oDefaultValue.Day) + Case vbEmpty + End Select + End If + Case CTLFORMATTEDFIELD + If Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then _PropertyGet = ControlModel.EffectiveDefault + Case CTLLISTBOX + If Utils._hasUNOProperty(ControlModel, "DefaultSelection") And Utils._hasUNOProperty(ControlModel, "StringItemList") Then + vDefaultValue = ControlModel.DefaultSelection + If IsArray(vDefaultValue) Then + If UBound(vDefaultValue) >= LBound(vDefaultValue) Then ' Is array initialized ? + iIndex = UBound(ControlModel.StringItemList) + If vDefaultValue(0) >= 0 And vDefaultValue(0) <= iIndex Then _PropertyGet = ControlModel.StringItemList(vDefaultValue(0)) + ' Only first default value is considered + End If + End If + End If + Case CTLSPINBUTTON + If Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then _PropertyGet = ControlModel.DefaultSpinValue + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultTime") Then + Select Case VarType(ControlModel.DefaultTime) + Case vbLong ' AOO and LO <= 4.1 + _PropertyGet = ControlModel.DefaultTime + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + Set oDefaultValue = ControlModel.DefaultTime + _PropertyGet = TimeSerial(oDefaultValue.Hours, oDefaultValue.Minutes, oDefaultValue.Seconds) + Case vbEmpty + End Select + End If + Case Else + Goto Trace_Error + End Select + Case UCase("Enabled") + If Utils._hasUNOProperty(ControlModel, "Enabled") Then _PropertyGet = ControlModel.Enabled + Case UCase("FontBold") + If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ( ControlModel.FontWeight >= com.sun.star.awt.FontWeight.BOLD ) + Case UCase("FontItalic") + If Utils._hasUNOProperty(ControlModel, "FontSlant") Then _PropertyGet = ( ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC ) + Case UCase("FontName") + If Utils._hasUNOProperty(ControlModel, "FontName") Then _PropertyGet = ControlModel.FontName + Case UCase("FontSize") + If Utils._hasUNOProperty(ControlModel, "FontHeight") Then _PropertyGet = ControlModel.FontHeight + Case UCase("FontUnderline") + If Utils._hasUNOProperty(ControlModel, "FontUnderline") Then _PropertyGet = _ + Not ( ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE _ + Or ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.DONTKNOW ) + Case UCase("FontWeight") + If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ControlModel.FontWeight + Case UCase("ForeColor") + If Utils._hasUNOProperty(ControlModel, "TextColor") Then _PropertyGet = ControlModel.TextColor + Case UCase("Form") + Set ofSubForm = New SubForm ' Start building the SUBFORM object + With ofSubForm + Set ._This = ofSubForm + Set .DatabaseForm = ControlModel + ._Name = _Name + ._Shortcut = _Shortcut & ".Form" + ._MainForm = _MainForm + .ParentComponent = _FormComponent + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + ._OrderBy = ControlModel.Order + End With + set _PropertyGet = ofSubForm + Case UCase("Format") + vFormats = _Formats(_Subtype) + Select Case _SubType + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "DateFormat") Then + If ControlModel.DateFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.DateFormat) + End If + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then + If ControlModel.TimeFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.TimeFormat) + End If + Case Else + If Utils._hasUNOProperty(ControlModel, "FormatKey") Then + If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then + _PropertyGet = ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString + End If + End If + End Select + Case UCase("ItemData") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + If IsMissing(pvIndex) Then + _PropertyGet = ControlModel.StringItemList + Else + If pvIndex < 0 Or pvIndex > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Index + _PropertyGet = ControlModel.StringItemList(pvIndex) + End If + End If + Case UCase("ListCount") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then _PropertyGet = UBound(ControlModel.StringItemList) + 1 + Case UCase("ListIndex") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + lListIndex = -1 ' Either Multiple selections or no selection at all + Select Case _SubType + Case CTLCOMBOBOX + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error + iIndex = 0 + If ControlModel.Text <> "" Then + For j = 0 To UBound(ControlModel.StringItemList) + If ControlModel.StringItemList(j) = ControlModel.Text Then + lListIndex = j + iIndex = iIndex + 1 + End If + Next j + If iIndex <> 1 Then lListIndex = -1 ' Multiselection or synonyms rejected + End If + Case CTLLISTBOX ' No mean found to access bound column !! See mail Lionel 10/5/2013 for improvement + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error + If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected + Else ' Mono selection + If _ParentType <> CTLPARENTISDIALOG Then ' getCurrentValue not found in dialog listboxes ?? + vCurrentValue = ControlModel.getCurrentValue() ' Space or uninitialized array if no selection at all + If IsArray(vCurrentValue) Then ' Is an array if MultiSelect + vListboxValue = "" + If UBound(vCurrentValue) = 0 Then vListboxValue = vCurrentValue(0) + Else + vListboxValue = vCurrentValue + End If + If vListboxValue <> "" Then ' Speed up search PM Pastim 12/02/2013 + If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) + End If + Else + If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) + End If + End If + End Select + _PropertyGet = lListIndex + End If + Case UCase("Locked") + If Utils._hasUNOProperty(ControlModel, "ReadOnly") Then _PropertyGet = ControlModel.ReadOnly + Case UCase("MultiSelect") + If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then + _PropertyGet = ControlModel.MultiSelection ' Boolean in OO, Integer (0, 1 or 2) in VBA + ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: only for GridControls !? Changed in OO >= 3,3 !? + _PropertyGet = ControlModel.MultiSelectionSimpleMode + Else + _PropertyGet = False + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _ + , UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _ + , UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _ + , UCase("OnUpdated") + Select Case _ParentType + Case CTLPARENTISDIALOG + Set oControlEvents = ControlModel.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty) + If oControlEvents.hasByName(sEventName) Then + _PropertyGet = oControlEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case Else + _PropertyGet = Utils._GetEventScriptCode(ControlModel, psProperty, _Name) + End Select + Case UCase("OptionValue") + If Utils._hasUNOProperty(ControlModel, "RefValue") Then + If ControlModel.RefValue <> "" Then + _PropertyGet = ControlModel.RefValue + ElseIf Utils._hasUNOProperty(ControlModel, "Label") Then + _PropertyGet = ControlModel.Label + End If + End If + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Page") + If Utils._hasUNOProperty(ControlModel, "Step") Then _PropertyGet = ControlModel.Step + Case UCase("Parent") + Set _PropertyGet = _Parent + Case UCase("Picture") + _PropertyGet = ConvertToUrl(ControlModel.ImageURL) + Case UCase("Required") + If Utils._hasUNOProperty(ControlModel, "InputRequired") Then _PropertyGet = ControlModel.InputRequired + Case UCase("RowSource") + Select Case _ParentType + Case CTLPARENTISDIALOG + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList) + _PropertyGet = Join(vListSource, ";") + End If + Case Else + If Utils._hasUNOProperty(ControlModel, "ListSource") Then + Select Case ControlModel.ListSourceType + Case com.sun.star.form.ListSourceType.VALUELIST _ + , com.sun.star.form.ListSourceType.TABLEFIELDS + If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList) + Case com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH + If IsArray(ControlModel.ListSource) Then vListSource = ControlModel.ListSource Else vListSource = Array(ControlModel.ListSource) + End Select + _PropertyGet = Join(vListSource, ";") + End If + End Select + Case UCase("RowSourceType") + If Utils._hasUNOProperty(ControlModel, "ListSourceType") Then _PropertyGet = ControlModel.ListSourceType + Case UCase("Selected") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + lListIndex = UBound(ControlModel.StringItemList) + If Not IsMissing(pvIndex) Then + If pvIndex < 0 Or pvIndex > lListIndex Then Goto Trace_Error_Index + End If + If lListIndex < 0 Then ' Do nothing if listbox empty + _PropertyGet = Array() + Else + Redim bSelected(0 To lListIndex) + For j = 0 To lListIndex + bSelected(j) = False + Next j + For j = 0 To UBound(ControlModel.SelectedItems) + iIndex = ControlModel.SelectedItems(j) + If iIndex >= 0 And iIndex <= lListIndex Then bSelected(iIndex) = True + Next j + If IsMissing(pvIndex) Then _PropertyGet = bSelected Else _PropertyGet = bSelected(pvIndex) + End If + End If + Case UCase("SelLength") + If Utils._hasUNOProperty(ControlView, "Selection") Then + vSelection = ControlView.getSelection() + If vSelection.Max >= vSelection.Min Then + _PropertyGet = vSelection.Max - vSelection.Min + Else + _PropertyGet = 0 ' probably control does not have focus + End If + Else + _PropertyGet = 0 + End If + Case UCase("SelStart") + If Utils._hasUNOProperty(ControlView, "Selection") Then + vSelection = ControlView.getSelection() + If vSelection.Max >= vSelection.Min Then + _PropertyGet = vSelection.Min + 1 + Else + _PropertyGet = 1 ' probably control does not have focus + End If + Else + _PropertyGet = 1 + End If + Case UCase("SelText") + If Utils._hasUNOProperty(ControlView, "SelectedText") Then + _PropertyGet = ControlView.getSelectedText() + Else + _PropertyGet = "" + End If + Case UCase("SpecialEffect") + If Utils._hasUNOProperty(ControlModel, "VisualEffect") Then _PropertyGet = ControlModel.VisualEffect + Case UCase("SubType") + _PropertyGet = _SubType + Case UCase("TabIndex") + If Utils._hasUNOProperty(ControlModel, "TabIndex") Then _PropertyGet = ControlModel.TabIndex + Case UCase("TabStop") + If Utils._hasUNOProperty(ControlModel, "Tabstop") Then _PropertyGet = ControlModel.Tabstop + Case UCase("Tag") + If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag + Case UCase("Text") + Select Case _SubType + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "Date") Then + If Utils._hasUNOProperty(ControlModel, "FormatKey") Then + If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then + Select Case VarType(ControlModel.Date) + Case vbLong ' AOO and LO <= 4.1 + vDate = DateSerial(Left(ControlModel.Date, 4), Mid(ControlModel.Date, 5, 2), Right(ControlModel.Date, 2)) + Case vbObject ' LO >= 4.2 + vDate = DateSerial(ControlModel.Date.Year, ControlModel.Date.Month, ControlModel.Date.Day) + Case vbEmpty + End Select + _PropertyGet = Format(vDate, ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString) + End If + End If + End If + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "Text") Then + Select Case VarType(ControlModel.Time) + Case vbLong ' AOO and LO <= 4.1 + _PropertyGet = Format(ControlModel.Time, "HH:MM:SS") + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + Set oValue = ControlModel.Time + _PropertyGet = Format(TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds), "HH:MM:SS") + Case vbEmpty + End Select + End If + Case Else + If Utils._hasUNOProperty(ControlModel, "Text") Then _PropertyGet = ControlModel.Text + End Select + Case UCase("TextAlign") + If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag + Case UCase("TripleState") + If Utils._hasUNOProperty(ControlModel, "TriState") Then _PropertyGet = ControlModel.TriState + Case UCase("Value") + Select Case _SubType + Case CTLCHECKBOX + If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ControlModel.State + Case CTLCOMMANDBUTTON + vGet = False + If Utils._hasUNOProperty(ControlModel, "Toggle") Then + If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ( ControlModel.State = 1 ) + End If + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Utils._hasUNOProperty(ControlModel, "Text") Then vGet = ControlModel.Text + Case CTLCURRENCYFIELD + If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "Date") Then + Select Case VarType(ControlModel.Date) + Case vbLong ' AOO and LO <= 4.1 + vValue = ControlModel.Date + vGet = DateSerial(Left(vValue, 4), Mid(vValue, 5, 2), Right(vValue, 2)) + Case vbObject ' LO >= 4.2 com.sun.star.Util.Date + Set oValue = ControlModel.Date + vGet = DateSerial(oValue.Year, oValue.Month, oValue.Day) + Case vbEmpty + End Select + End If + Case CTLFORMATTEDFIELD + If Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then vGet = ControlModel.EffectiveValue + Case CTLHIDDENCONTROL + If Utils._hasUNOProperty(ControlModel, "HiddenValue") Then vGet = ControlModel.HiddenValue + Case CTLLISTBOX + 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 = EMPTY ' Listbox has no value, only an array of Selected flags to identify values + Else ' Mono selection + Select Case _ParentType + Case CTLPARENTISDIALOG + If Ubound(ControlModel.SelectedItems) >= 0 Then + lListIndex = Controlmodel.Selecteditems(0) + If lListIndex > -1 And lListIndex <= UBound(ControlModel.StringItemList) Then + vGet = ControlModel.StringItemList(lListIndex) + Else + vGet = EMPTY + End If + End If + Case Else + 'getCurrentValue does not return any significant value anymore + ' Speed up getting value PM PASTIM 12/02/2013 + If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) Else lListIndex = -1 + ' If listbox has hidden column = real bound field, then explore ValueItemList + If _ListboxBound() Then + If lListIndex > -1 Then vGet = ControlModel.ValueItemList(lListIndex) ' PASTIM + Else + If lListIndex > -1 Then vGet = ControlModel.getItemText(lListIndex) + End If + End Select + End If + Case CTLNUMERICFIELD + If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value + Case CTLPROGRESSBAR + If Utils._hasUNOProperty(ControlModel, "ProgressValue") Then vGet = ControlModel.ProgressValue + Case CTLSCROLLBAR + If Utils._hasUNOProperty(ControlModel, "ScrollValue") Then vGet = ControlModel.ScrollValue + Case CTLSPINBUTTON + If Utils._hasUNOProperty(ControlModel, "SpinValue") Then vGet = ControlModel.SpinValue + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "Time") Then + Select Case VarType(ControlModel.Time) + Case vbLong ' AOO and LO <= 4.1 + vGet = ControlModel.Time + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + Set oValue = ControlModel.Time + vGet = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds) + Case vbEmpty + End Select + End If + Case Else + End Select + If _SubType <> CTLLISTBOX Then ' Give getCurrentValue an additional try + If IsEmpty(vGet) And Utils._hasUNOMethod(ControlModel, "getCurrentValue") Then vGet = ControlModel.getCurrentValue() + End If + _PropertyGet = vGet + Case UCase("Visible") + Select Case _SubType + Case CTLHIDDENCONTROL + _PropertyGet = False + Case Else + If Utils._hasUNOMethod(ControlView, "isVisible") Then _PropertyGet = CBool(ControlView.isVisible()) + End Select + Case Else + Goto Trace_Error + End Select + + If IsEmpty(_PropertyGet) Then TraceError(TRACEINFO, ERRPROPERTYINIT, Utils._CalledSub(), 0, , psProperty) + +Exit_Function: + Utils._ResetCalledSub("Control.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Control._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Control.set" & psProperty) + _PropertySet = True + +'Check Index argument + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function + End If +'Execute +Dim iArgNr As Integer, vButton As Variant, i As Integer +Dim odbDatabase As Object, vNames() As Variant, bFound As Boolean, sName As String +Dim bMultiSelect As Boolean, iCount As Integer, iSelectedItems() As Integer, lListCount As Long, bSelected() As Boolean +Dim vItemList() As Variant, vFormats() As Variant +Dim oStruct As Object, sValue As String +Dim vSelection As Variant, sText As String, lStart As long +Dim oControlEvents As Object, sListener As String, sEvent As String, sEventName As String, oEvent As Object + + _PropertySet = True + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("Control.setProperty") : iArgNr = 2 + Case UCase("Control.set" & psProperty) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("BackColor") + If Not Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.BackgroundColor = CLng(pvValue) + Case UCase("BorderColor") + If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.BorderColor = CLng(pvValue) + Case UCase("BorderStyle") + If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = No border, 1 = 3D border, 2 = Normal border + ControlModel.Border = CLng(pvValue) + Case UCase("Cancel") + If Not Utils._hasUNOProperty(ControlModel, "PushButtonType") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then vButton = com.sun.star.awt.PushButtonType.CANCEL Else vButton = com.sun.star.awt.PushButtonType.STANDARD + ControlModel.PushButtonType = vButton + Case UCase("Caption") + If Not Utils._hasUNOProperty(ControlModel, "Label") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.Label = pvValue + Case UCase("ControlTipText") + If Not Utils._hasUNOProperty(ControlModel, "HelpText") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.HelpText = pvValue + Case UCase("Default") + If Not Utils._hasUNOProperty(ControlModel, "DefaultButton") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.DefaultButton = pvValue + Case UCase("DefaultValue") + Select Case _SubType + Case CTLDATEFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultDate") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + Select Case VarType(ControlModel.DefaultDate) + Case vbEmpty, vbLong ' AOO and LO <= 4.1 + ControlModel.DefaultDate = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) + Case vbObject ' LO >= 4.2 com.sun.star.Util.Date + ControlModel.DefaultDate.Year = Year(pvValue) + ControlModel.DefaultDate.Month = Month(pvValue) + ControlModel.DefaultDate.Day = Day(pvValue) + End Select + Case CTLLISTBOX + If Not Utils._hasUNOProperty(ControlModel, "DefaultSelection") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + For i = 0 To UBound(ControlModel.StringItemList) + If UCase(pvValue) = UCase(ControlModel.StringItemList(i)) Then + ControlModel.DefaultSelection = Array(i) + Exit For + End If + Next i + Case CTLSPINBUTTON + If Not Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.DefaultSpinValue = pvValue + Case CTLCHECKBOX + If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know + ControlModel.DefaultState = pvValue + Case CTLRADIOBUTTON + If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 1 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked + ControlModel.DefaultState = pvValue + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultText") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.DefaultText = pvValue + Case CTLTIMEFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultTime") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue >= 0 And pvValue <= 23595999 Then + Select Case VarType(ControlModel.DefaultTime) + Case vbEmpty, vbLong ' AOO and LO <= 4.1 + ControlModel.DefaultTime = pvValue + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + ControlModel.DefaultDate.Hours = Hour(pvValue) + ControlModel.DefaultDate.Minutes = Minute(pvValue) + ControlModel.DefaultDate.Seconds = Second(pvValue) + End Select + Else Goto Trace_Error_Value + End If + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.DefaultValue = pvValue + Case CTLFORMATTEDFIELD + If Not Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.EffectiveDefault = pvValue ' Thanks, PASTIM + Case Else + Goto Trace_Error + End Select + Case UCase("Enabled") + If Not Utils._hasUNOProperty(ControlModel, "Enabled") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.Enabled = pvValue + Case UCase("FontBold") + If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ' Iif construction does not work ! + ControlModel.FontWeight = com.sun.star.awt.FontWeight.BOLD + Else + ControlModel.FontWeight = com.sun.star.awt.FontWeight.NORMAL + End If + Case UCase("FontItalic") + If Not Utils._hasUNOProperty(ControlModel, "FontSlant") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ' Iif construction does not work ! + ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC + Else + ControlModel.FontSlant = com.sun.star.awt.FontSlant.NONE + End If + Case UCase("FontName") + If Not Utils._hasUNOProperty(ControlModel, "FontName") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.FontName = pvValue + Case UCase("FontSize") + If Not Utils._hasUNOProperty(ControlModel, "FontHeight") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Or pvValue > 127 Then Goto Trace_Error_Value + ControlModel.FontHeight = pvValue + Case UCase("FontUnderline") + If Not Utils._hasUNOProperty(ControlModel, "FontUnderline") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ' Iif construction does not work ! + ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.SINGLE + Else + ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE + End If + Case UCase("FontWeight") + If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error + If Not Utils._IsScalar(CSng(pvValue), vbSingle, Array( _ + com.sun.star.awt.FontWeight.THIN _ + , com.sun.star.awt.FontWeight.ULTRALIGHT _ + , com.sun.star.awt.FontWeight.LIGHT _ + , com.sun.star.awt.FontWeight.SEMILIGHT _ + , com.sun.star.awt.FontWeight.NORMAL _ + , com.sun.star.awt.FontWeight.SEMIBOLD _ + , com.sun.star.awt.FontWeight.BOLD _ + , com.sun.star.awt.FontWeight.ULTRABOLD _ + , com.sun.star.awt.FontWeight.BLACK _ + )) Then Goto Trace_Error_Value + ControlModel.FontWeight = pvValue + Case UCase("Format") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + vFormats = _Formats(_SubType) + Select Case _SubType + Case CTLDATEFIELD, CTLTIMEFIELD + bFound = False + For i = 0 To UBound(vFormats) + If UCase(pvValue) = UCase(vFormats(i)) Then + If _SubType = CTLDATEFIELD Then + If Utils._hasUNOProperty(ControlModel, "DateFormat") Then ControlModel.DateFormat = i Else Goto Trace_Error + Else + If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then ControlModel.TimeFormat = i Else Goto Trace_Error + End If + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_Error_Value + Case Else + Goto Trace_Error + End Select + Case UCase("ForeColor") + If Not Utils._hasUNOProperty(ControlModel, "TextColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.TextColor = CLng(pvValue) + Case UCase("ListIndex") + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Value + Select Case _SubType + Case CTLCOMBOBOX + ControlModel.Text = ControlModel.StringItemList(pvValue) + Case CTLLISTBOX + ControlModel.SelectedItems = Array(pvValue) + End Select + Case UCase("Locked") + If Not Utils._hasUNOProperty(ControlModel, "ReadOnly") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.ReadOnly = pvValue + Case UCase("MultiSelect") + If Not Utils._hasUNOProperty(ControlModel, "MultiSelection") And Not Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then + ControlModel.MultiSelection = pvValue + ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then + ControlModel.MultiSelectionSimpleMode = pvValue + End If + If Not pvValue Then ControlModel.SelectedItems = Array() ' Cancel selections when MultiSelect becomes False + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _ + , UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _ + , UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _ + , UCase("OnUpdated") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Select Case _ParentType + Case CTLPARENTISDIALOG + If Not Utils._RegisterDialogEventScript(ControlModel _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + ) Then GoTo Trace_Error + Case Else + If Not Utils._RegisterEventScript(ControlModel _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + , _Name _ + ) Then GoTo Trace_Error + End Select + Case UCase("OptionValue") + If Not Utils._hasUNOProperty(ControlModel, "RefValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Not Utils._hasUNOProperty(ControlModel, "Label") Then + If pvValue = "" Then Goto Trace_Error_Value + If ControlModel.RefValue <> "" Then ControlModel.RefValue = pvValue + Else + ControlModel.Label = pvValue + End If + Case UCase("Page") + If Not Utils._hasUNOProperty(ControlModel, "Step") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + ControlModel.Step = pvValue + Case UCase("Picture") + If Not Utils._hasUNOProperty(ControlModel, "ImageURL") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.ImageURL = ConvertToUrl(pvValue) + Case UCase("Required") + If Not Utils._hasUNOProperty(ControlModel, "InputRequired") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.InputRequired = pvValue + Case UCase("RowSource") + Select Case _ParentType + Case CTLPARENTISDIALOG + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + ControlModel.StringItemList = Split(pvValue, ";") + Case Else + If Not Utils._hasUNOProperty(ControlModel, "ListSource") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Select Case ControlModel.ListSourceType + Case com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.TABLEFIELDS + Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + If ControlModel.ListSourceType = com.sun.star.form.ListSourceType.QUERY Then vNames = odbDatabase.Connection.getQueries.GetElementNames _ + Else vNames = odbDatabase.Connection.getTables.GetElementNames + bFound = False ' Check existence of table or query and find its correct (case-sensitive) name + For i = 0 To UBound(vNames) + If UCase(vNames(i)) = UCase(pvValue) Then + bFound = True + sName = vNames(i) + Exit For + End If + Next i + If Not bFound Then Goto Trace_Error_Value + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = sName Else ControlModel.ListSource = Array(sName) + ControlModel.refresh() + Case com.sun.star.form.ListSourceType.SQL + Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = odbDatabase._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(odbDatabase._ReplaceSquareBrackets(pvValue)) + ControlModel.refresh() + Case com.sun.star.form.ListSourceType.VALUELIST ' Forbidden for COMBOBOX ! + If _SubType = CTLCOMBOBOX Then Goto Trace_Error + ControlModel.ListSource = Split(pvValue, ";") + ControlModel.StringItemList = ControlModel.ListSource + Case com.sun.star.form.ListSourceType.SQLPASSTHROUGH + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = pvValue Else ControlModel.ListSource = Array(pvValue) + ControlModel.refresh() + End Select + End Select + If _SubType = CTLLISTBOX Then ControlModel.SelectedItems = Array() + Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType + If Not Utils._hasUNOProperty(ControlModel, "ListSourceType") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Not Utils._IsScalar(pvValue, Utils._AddNumeric(), Array( _ + com.sun.star.form.ListSourceType.VALUELIST _ + , com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + , com.sun.star.form.ListSourceType.TABLEFIELDS _ + )) Then Goto Trace_Error_Value + ControlModel.ListSourceType = pvValue + Case UCase("Selected") + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then + bMultiSelect = ControlModel.MultiSelection + ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then + bMultiSelect = ControlModel.MultiSelectionSimpleMode + Else: Goto Trace_Error + End If + lListCount = UBound(ControlModel.StringItemList) + 1 + If IsMissing(pvIndex) Then ' Full boolean array passed + If Not IsArray(pvValue) Then Goto Trace_Error_Array + If LBound(pvValue) <> 0 Or UBound(pvValue) < 0 Then Goto Trace_Error_Array + If Not Utils._CheckArgument(pvValue(0), iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If UBound(pvValue) <> lListCount - 1 Then Goto Trace_Error_Index + iCount = 0 + For i = 0 To UBound(pvValue) ' Count True values + If pvValue(i) Then iCount = iCount + 1 + Next i + If iCount > 0 Then + Redim iSelectedItems(0 To iCount - 1) + iCount = 0 + For i = 0 To UBound(pvValue) + If pvValue(i) Then + iSelectedItems(iCount) = i + iCount = iCount + 1 + End If + Next i + ControlModel.SelectedItems = iSelectedItems ' iSelectedItems maps OO internals (size = # of selected items) + Else + ControlModel.SelectedItems = Array() + End If + Else ' Single boolean value passed + If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < 0 Or pvIndex >= lListCount Then Goto Trace_Error_Index + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ReDim bSelected(0 To lListCount - 1) ' bSelected maps VBA internals (size = # of displayed items) + If Not bMultiSelect Then ' Set all other values to False + For i = 0 To lListCount - 1 + If i = pvIndex Then + bSelected(i) = pvValue ' All entries = False except one + Else + bSelected(i) = False + End If + Next i + Else + For i = 0 To lListCount - 1 + bSelected(i) = False + Next i + iSelectedItems = ControlModel.SelectedItems + iCount = UBound(iSelectedItems) + For i = 0 To iCount + bSelected(iSelectedItems(i)) = True + Next i + bSelected(pvIndex) = pvValue + End If + iCount = 0 ' Rebuild SelectedItems + For i = 0 To lListCount - 1 + If bSelected(i) Then iCount = iCount + 1 + Next i + If iCount > 0 Then + Redim iSelectedItems(0 To iCount - 1) + iCount = 0 + For i = 0 To lListCount - 1 + If bSelected(i) Then + iSelectedItems(iCount) = i + iCount = iCount + 1 + End If + Next i + ControlModel.SelectedItems = iSelectedItems + Else + ControlModel.SelectedItems = Array() + End If + End If + Case UCase("SelLength") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + vSelection = ControlView.getSelection() + vSelection.Max = vSelection.Min + pvValue + ControlView.setSelection(vSelection) + Case UCase("SelStart") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Or pvValue > Len(ControlModel.Text) + 1 Then Goto Trace_Error_Value + vSelection = ControlView.getSelection() + vSelection.Min = pvValue - 1 + vSelection.Max = pvValue - 1 ' Also reset length to 0 + ControlView.setSelection(vSelection) + Case UCase("SelText") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Len(pvValue) > 0 Then + vSelection = ControlView.getSelection() + sText = ControlModel.Text + lStart = InStr(1, sText, pvValue, 0) ' Case sensitive ! + If lStart > 0 Then + vSelection.Min = lStart - 1 + vSelection.Max = lStart + Len(pvValue) - 1 + ControlView.setSelection(vSelection) + End If + End If + Case UCase("SpecialEffect") + If Not Utils._hasUNOProperty(ControlModel, "VisualEffect") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = None, 1 = Look3D, 2 = Flat + ControlModel.VisualEffect = pvValue + Case UCase("TabIndex") + If Not Utils._hasUNOProperty(ControlModel, "TabIndex") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -1 Then Goto Trace_Error_Value + ControlModel.TabIndex = pvValue + Case UCase("TabStop") + If Not Utils._hasUNOProperty(ControlModel, "Tabstop") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.Tabstop = pvValue + Case UCase("Tag") + If Not Utils._hasUNOProperty(ControlModel, "Tag") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.Tag = pvValue + Case UCase("TextAlign") + If Not Utils._hasUNOProperty(ControlModel, "Align") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Left, 1 = Center, 2 = Right + ControlModel.Align = pvValue + Case UCase("TripleState") + If Not Utils._hasUNOProperty(ControlModel, "TriState") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.TriState = pvValue + Case UCase("Value") + Select Case _SubType + Case CTLCHECKBOX + If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbBoolean), , False) Then Goto Trace_Error_Value + If VarType(pvValue) = vbBoolean Then pvValue = Iif(pvValue, 1, 0) + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know + ControlModel.State = pvValue + Case CTLCOMMANDBUTTON + If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error + If Not Utils._hasUNOProperty(ControlModel, "Toggle") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ControlModel.State = 1 Else ControlModel.State = 0 + Case CTLCOMBOBOX + If Not Utils._hasUNOProperty(ControlModel, "Text") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ + Then Goto Trace_Error + If pvValue <> "" Then + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, ControlModel.StringItemList, False) Then Goto Trace_Error_Value + End If + ControlModel.Text = pvValue + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If Not Utils._hasUNOProperty(ControlModel, "Value") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.Value = pvValue + Case CTLDATEFIELD + If Not Utils._hasUNOProperty(ControlModel, "Date") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + Select Case _InspectPropertyType(ControlModel, "Date") + Case "long" ' AOO and LO <= 4.1 + 'ControlModel.Date = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) ' Gives error in dialogs ?!? + ControlModel.setPropertyValue("Date", Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue)) + Case "com.sun.star.util.Date" ' LO >= 4.2 + 'Direct assignment of ControlModel.Date.Xxx has no effect ?!? + Set oStruct = CreateUnoStruct("com.sun.star.util.Date") + oStruct.Year = Year(pvValue) + oStruct.Month = Month(pvValue) + oStruct.Day = Day(pvValue) + Set ControlModel.Date = oStruct + End Select + Case CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.Text = pvValue + Case CTLFORMATTEDFIELD + If Not Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbString), , False) Then Goto Trace_Error_Value + ControlModel.EffectiveValue = pvValue + Case CTLHIDDENCONTROL + If Not Utils._hasUNOProperty(ControlModel, "HiddenValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbBoolean, vbDate)), , False) Then Goto Trace_Error_Value + ControlModel.HiddenValue = pvValue + Case CTLLISTBOX + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ + Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbDate)), , False) Then Goto Trace_Error_Value ' PASTIM + If IsArray(pvValue) Then Goto Trace_Error_Value ' Setting the value on a listbox is allowed only if single value and value in the list + ' Check ValueItemList + bFound = False + Select Case _ParentType + Case CTLPARENTISDIALOG + vItemList = ControlModel.StringItemList + Case Else + If _ListboxBound() Then ' Performance improvement (PASTIM PM 9 Feb 2013) + If Not Utils._hasUNOProperty(ControlModel, "ValueItemList") Then Goto Trace_Error + vItemList = ControlModel.ValueItemList + Else + vItemList = ControlModel.StringItemList + End If + End Select + For i = 0 To UBound(vItemList) + If pvValue = vItemList(i) Then + bFound = True + Exit For + End If + Next i + If bFound Then ControlModel.SelectedItems = Array(i) Else Goto Trace_Error_Value + Case CTLPROGRESSBAR + If Not Utils._hasUNOProperty(ControlModel, "ProgressValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "ProgressValueMin") Then + If pvValue < ControlModel.ProgressValueMin Then Goto Trace_Error_Value + End If + If Utils._hasUNOProperty(ControlModel, "ProgressValueMax") Then + If pvValue > ControlModel.ProgressValueMax Then Goto Trace_Error_Value + End If + ControlModel.ProgressValue = pvValue + Case CTLSCROLLBAR + If Not Utils._hasUNOProperty(ControlModel, "ScrollValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "ScrollValueMin") Then + If pvValue < ControlModel.ScrollValueMin Then Goto Trace_Error_Value + End If + If Utils._hasUNOProperty(ControlModel, "ScrollValueMax") Then + If pvValue > ControlModel.ScrollValueMax Then Goto Trace_Error_Value + End If + ControlModel.ScrollValue = pvValue + Case CTLSPINBUTTON + If Not Utils._hasUNOProperty(ControlModel, "SpinValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "SpinValueMin") Then + If pvValue < ControlModel.SpinValueMin Then Goto Trace_Error_Value + End If + If Utils._hasUNOProperty(ControlModel, "SpinValueMax") Then + If pvValue > ControlModel.SpinValueMax Then Goto Trace_Error_Value + End If + ControlModel.SpinValue = pvValue + Case CTLTIMEFIELD + If Not Utils._hasUNOProperty(ControlModel, "Time") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + Select Case _InspectPropertyType(ControlModel, "Time") + Case "long" ' AOO and LO <= 4.0 + ControlModel.Time = CLng(pvValue) + Case "com.sun.star.util.Time" ' LO >= 4.1 + 'Direct assignment of ControlModel.Time.Xxx gives error ?!? + Set oStruct = CreateUnoStruct("com.sun.star.util.Time") + sValue = Right("00000000" & Str(CLng(pvValue)), 8) + oStruct.Hours = Val(Left(sValue, 2)) + oStruct.Minutes = Val(Mid(sValue, 3, 2)) + oStruct.Seconds = Val(Mid(sValue, 5, 2)) + Set ControlModel.Time = oStruct + End Select + Case Else + Goto Trace_Error + End Select + ' FINAL COMMITMENT + If Utils._hasUNOMethod(ControlModel, "commit") Then ControlModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM] + Case UCase("Visible") + If _SubType = CTLHIDDENCONTROL Then Goto Trace_Error ' Hidden remains hidden !! + If Not Utils._hasUNOMethod(ControlView, "setVisible") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ControlModel.EnableVisible = True + ControlView.setVisible(pvValue) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Control.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Array: + TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Control._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet V1.1.0 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba new file mode 100644 index 000000000..338e99c55 --- /dev/null +++ b/wizards/source/access2base/DataDef.xba @@ -0,0 +1,587 @@ +<?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="DataDef" 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 TABLEDEF or QUERYDEF +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String ' For tables: [[Catalog.]Schema.]Table +Private _ParentDatabase As Object +Private _ReadOnly As Boolean +Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable +Private CatalogName As String +Private SchemaName As String +Private TableName As String +Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery +Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable +Private TableFieldsCount As Integer +Private TableKeysCount As Integer + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = "" + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + Set _ParentDatabase = Nothing + _ReadOnly = False + Set Table = Nothing + CatalogName = "" + SchemaName = "" + TableName = "" + Set Query = Nothing + Set TableDescriptor = Nothing + TableFieldsCount = 0 + TableKeysCount = 0 +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 ----------------------------------------------------------------------------------------------------------------------- + +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 ----------------------------------------------------------------------------------------------------------------------- +Property Get SQL() As Variant + SQL = _PropertyGet("SQL") +End Property ' SQL (get) + +Property Let SQL(ByVal pvValue As Variant) + Call _PropertySet("SQL", pvValue) +End Property ' SQL (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function pType() As Integer + pType = _PropertyGet("Type") +End Function ' Type (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function CreateField(ByVal Optional pvFieldName As Variant _ + , ByVal optional pvType As Variant _ + , ByVal optional pvSize As Variant _ + , ByVal optional pvAttributes As variant _ + ) As Object +'Return a Field object +Const cstThisSub = "TableDef.CreateField" + Utils._SetCalledSub(cstThisSub) + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object +Const cstMaxKeyLength = 30 + + CreateField = Nothing + If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvFieldName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function + If pvFieldName = "" Then Call _TraceArguments() + If IsMissing(pvType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _ + dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _ + , dbNumeric, dbDecimal, dbText, dbChar, dbMemo _ + , dbDate, dbTime, dbTimeStamp _ + , dbBinary, dbVarBinary, dbLongBinary, dbBoolean _ + )) Then Goto Exit_Function + If IsMissing(pvSize) Then pvSize = 0 + If pvSize < 0 Then pvSize = 0 + If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function + If IsMissing(pvAttributes) Then pvAttributes = 0 + If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function + + If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable + If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable + + If _ReadOnly Then Goto Error_NoUpdate + + Set oNewField = New Field + With oNewField + ._This = oNewField + ._Name = pvFieldName + ._ParentName = _Name + ._ParentType = OBJTABLEDEF + If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table + Set .Column = oTable.Columns.createDataDescriptor() + End With + With oNewField.Column + .Name = pvFieldName + Select Case pvType + Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT + Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER + Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT + Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT + Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL + Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE + Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC + Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL + Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR + Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR + Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR + Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE + Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME + Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP + Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY + Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY + Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY + Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN + End Select + .Precision = Int(pvSize) + If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10 + .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE + If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName + If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName + If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName + If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1 + If pvAttributes = dbAutoIncrField Then + If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists + Set oKeys = oTable.Keys + Set oPrimaryKey = oKeys.createDataDescriptor() + Set oColumn = oPrimaryKey.Columns.createDataDescriptor() + oColumn.Name = pvFieldName + oColumn.CatalogName = CatalogName + oColumn.SchemaName = SchemaName + oColumn.TableName = TableName + oColumn.IsAutoIncrement = True + oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS + oPrimaryKey.Columns.appendByDescriptor(oColumn) + oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength) + oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY + oKeys.appendByDescriptor(oPrimaryKey) + .IsAutoIncrement = True + .IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS + oColumn.dispose() + Else + .IsAutoIncrement = False + End If + End With + oTable.Columns.appendByDescriptor(oNewfield.Column) + + Set CreateField = oNewField + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' CreateField V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean +'Execute a stored query. The query must be an ACTION query. + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".Execute" + Utils._SetCalledSub(cstThisSub) + On Local Error Goto Error_Function +Const cstNull = -1 + Execute = False + If _Type <> OBJQUERYDEF Then Goto Trace_Method + If IsMissing(pvOptions) Then + pvOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function + End If + + 'Check action query +Dim oStatement As Object, vResult As Variant +Dim iType As Integer, sSql As String + iType = pType + If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action + + 'Execute action query + Set oStatement = _ParentDatabase.Connection.createStatement() + sSql = Query.Command + If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _ + Else oStatement.EscapeProcessing = Query.EscapeProcessing + On Local Error Goto SQL_Error + vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql)) + On Local Error Goto Error_Function + + Execute = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Method: + TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub) + Goto Exit_Function +Trace_Action: + TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name) + Goto Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Execute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Fields(ByVal Optional pvIndex As variant) As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".Fields" + Utils._SetCalledSub(cstThisSub) + + Set Fields = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oFields As Object + + If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns() + sObjects = oFields.ElementNames() + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLFIELDS + Set oObject._Parent = _This + oObject._Count = UBound(sObjects) + 1 + Goto Exit_Function + Case VarType(pvIndex) = vbString + bFound = False + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + End Select + + Set oObject = New Field + Set oObject._This = oObject + oObject._Name = sObjectName + Set oObject.Column = oFields.getByName(sObjectName) + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oObject._ParentDatabase = _ParentDatabase + +Exit_Function: + Set Fields = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Fields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".getProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".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 ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object +'Return a Recordset object based on current table- or querydef object + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" + Utils._SetCalledSub(cstThisSub) +Const cstNull = -1 +Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean + + Set oObject = Nothing + If IsMissing(pvType) Then + pvType = cstNull + Else + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function + End If + If IsMissing(pvOptions) Then + pvOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + If IsMissing(pvLockEdit) Then + pvLockEdit = cstNull + Else + If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function + End If + + Select Case _Type + Case OBJTABLEDEF + lCommandType = com.sun.star.sdb.CommandType.TABLE + sCommand = _Name + Case OBJQUERYDEF + lCommandType = com.sun.star.sdb.CommandType.QUERY + sCommand = _Name + If pvOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing + End Select + + Set oObject = New Recordset + With oObject + ._CommandType = lCommandType + ._Command = sCommand + ._ParentName = _Name + ._ParentType = _Type + ._ForwardOnly = ( pvType = dbOpenForwardOnly ) + ._PassThrough = bPassThrough + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) + Set ._ParentDatabase = _ParentDatabase + Set ._This = oObject + Call ._Initialize() + End With + With _ParentDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + +Exit_Function: + Set OpenRecordset = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set oObject = Nothing + GoTo Exit_Function +End Function ' OpenRecordset V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".Properties" + Utils._SetCalledSub(cstThisSub) + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + Set vProperty._ParentDatabase = _ParentDatabase + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".setProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + Select Case _Type + Case OBJTABLEDEF + _PropertiesList = Array("Name", "ObjectType") + Case OBJQUERYDEF + _PropertiesList = Array("Name", "ObjectType", "SQL", "Type") + Case Else + End Select + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) + Utils._SetCalledSub(cstThisSub & ".get" & psProperty) +Dim sSql As String, sVerb As String, iType As Integer + _PropertyGet = EMPTY + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("SQL") + _PropertyGet = Query.Command + Case UCase("Type") + iType = 0 + 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 _ + 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 + If sVerb = "DELETE" Then iType = iType + dbQDelete + If sVerb = "UPDATE" Then iType = iType + dbQUpdate + If sVerb = "CREATE" _ + Or sVerb = "ALTER" _ + Or sVerb = "DROP" _ + Or sVerb = "RENAME" _ + Or sVerb = "TRUNCATE" _ + Then iType = iType + dbQDDL + ' dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate + ' To check Type use: If (iType And dbQxxx) <> 0 Then ... + _PropertyGet = iType + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & ".get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) + Utils._SetCalledSub(cstThisSub & ".set" & psProperty) + +'Execute +Dim iArgNr As Integer + + _PropertySet = True + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase(cstThisSub & ".setProperty") : iArgNr = 2 + Case UCase(cstThisSub & ".set" & psProperty) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + If _ReadOnly Then Goto Error_NoUpdate + + Select Case UCase(psProperty) + Case UCase("SQL") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Query.Command = pvValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & ".set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba new file mode 100644 index 000000000..2e361cecf --- /dev/null +++ b/wizards/source/access2base/Database.xba @@ -0,0 +1,1884 @@ +<?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="Database" 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 DATABASE +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _DbConnect As Integer ' DBCONNECTxxx constants +Private Title As String +Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj +Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection +Private URL As String +Private Location As String ' Different from URL for registered databases +Private _ReadOnly As Boolean +Private MetaData As Object ' interface XDatabaseMetaData +Private _RDBMS As Integer ' DBMS constants +Private _ColumnTypes() As Variant ' Part of Metadata.GetTypeInfo() +Private _ColumnTypeNames() As Variant +Private _ColumnPrecisions() As Variant +Private _ColumnTypesReference() As Variant +Private _ColumnTypesAlias() As Variant ' To what should a field whose origin is another DBMS be converted ? See DataTypes By RDBMS.ods +Private _BinaryStream As Boolean ' False = binary fields must NOT be streamed f.i. via ReadAllBytes or WriteAllBytes +Private Form As Object ' com.sun.star.form.XForm +Private FormName As String +Private RecordsetMax As Long ' To make unique names in Collection below (See bug # 121342) +Private RecordsetsColl As Object ' Collection of active recordsets + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJDATABASE + Set _This = Nothing + Set _Parent = Nothing + _DbConnect = 0 + Title = "" + Set Document = Nothing + Set Connection = Nothing + URL = "" + _ReadOnly = False + Set MetaData = Nothing + _RDBMS = DBMS_UNKNOWN + _ColumnTypes = Array() + _ColumnTypeNames = Array() + _ColumnPrecisions = Array() + _ColumnTypesReference = Array() + _ColumnTypesAlias() = Array() + _BinaryStream = False + Set Form = Nothing + FormName = "" + RecordsetMax = 0 + Set RecordsetsColl = New Collection +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call CloseAllRecordsets() + If _DbConnect <> DBCONNECTANY Then + If Not IsNull(Connection) Then + Connection.close() + Connection.dispose() + Set Connection = Nothing + End If + Else + mClose() + End If + 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 ----------------------------------------------------------------------------------------------------------------------- + +Property Get Connect() As String + Connect = _PropertyGet("Connect") +End Property ' Connect (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 ----------------------------------------------------------------------------------------------------------------------- +Property Get OnCreate() As String + OnCreate = _PropertyGet("OnCreate") +End Property ' OnCreate (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocus() As String + OnFocus = _PropertyGet("OnFocus") +End Property ' OnFocus (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoad() As String + OnLoad = _PropertyGet("OnLoad") +End Property ' OnLoad (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoadFinished() As String + OnLoadFinished = _PropertyGet("OnLoadFinished") +End Property ' OnLoadFinished (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnModifyChanged() As String + OnModifyChanged = _PropertyGet("OnModifyChanged") +End Property ' OnModifyChanged (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnNew() As String + OnNew = _PropertyGet("OnNew") +End Property ' OnNew (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnPrepareUnload() As String + OnPrepareUnload = _PropertyGet("OnPrepareUnload") +End Property ' OnPrepareUnload (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnPrepareViewClosing() As String + OnPrepareViewClosing = _PropertyGet("OnPrepareViewClosing") +End Property ' OnPrepareViewClosing (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSave() As String + OnSave = _PropertyGet("OnSave") +End Property ' OnSave (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveAs() As String + OnSaveAs = _PropertyGet("OnSaveAs") +End Property ' OnSaveAs (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveAsDone() As String + OnSaveAsDone = _PropertyGet("OnSaveAsDone") +End Property ' OnSaveAsDone (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveAsFailed() As String + OnSaveAsFailed = _PropertyGet("OnSaveAsFailed") +End Property ' OnSaveAsFailed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveDone() As String + OnSaveDone = _PropertyGet("OnSaveDone") +End Property ' OnSaveDone (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveFailed() As String + OnSaveFailed = _PropertyGet("OnSaveFailed") +End Property ' OnSaveFailed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSubComponentClosed() As String + OnSubComponentClosed = _PropertyGet("OnSubComponentClosed") +End Property ' OnSubComponentClosed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSubComponentOpened() As String + OnSubComponentOpened = _PropertyGet("OnSubComponentOpened") +End Property ' OnSubComponentOpened (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnTitleChanged() As String + OnTitleChanged = _PropertyGet("OnTitleChanged") +End Property ' OnTitleChanged (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnfocus() As String + OnUnfocus = _PropertyGet("OnUnfocus") +End Property ' OnUnfocus (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnload() As String + OnUnload = _PropertyGet("OnUnload") +End Property ' OnUnload (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnViewClosed() As String + OnViewClosed = _PropertyGet("OnViewClosed") +End Property ' OnViewClosed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnViewCreated() As String + OnViewCreated = _PropertyGet("OnViewCreated") +End Property ' OnViewCreated (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Version() As String + Version = _PropertyGet("Version") +End Property ' Version (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose() As Variant +' Close the database + +If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Database.Close" + Utils._SetCalledSub(cstThisSub) + mClose = False + If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable + + With Connection + If Utils._hasUNOMethod(Connection, "flush") Then .flush + .close() + .dispose() + End With + Set Connection = Nothing + mClose = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' (m)Close + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub CloseAllRecordsets() +' Clean all recordsets for housekeeping + +Dim sRecordsets() As String, i As Integer, oRecordset As Object + On Local Error Goto Exit_Sub + + If IsNull(RecordsetsColl) Then Exit Sub + If RecordsetsColl.Count < 1 Then Exit Sub + For i = 1 To RecordsetsColl.Count + Set oRecordset = RecordsetsColl.Item(i) + oRecordset.mClose(False) ' Do not remove entry in collection + Next i + Set RecordsetsColl = New Collection + RecordsetMax = 0 + +Exit_Sub: + Exit Sub +End Sub ' CloseAllRecordsets V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _ + , ByVal Optional pvSql As Variant _ + , ByVal Optional pvOption As Variant _ + ) As Object +'Return a (new) QueryDef object based on SQL statement +Const cstThisSub = "Database.CreateQueryDef" + Utils._SetCalledSub(cstThisSub) + +Const cstNull = -1 +Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set CreateQueryDef = Nothing + If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvQueryName) Then Call _TraceArguments() + If IsMissing(pvSql) Then Call _TraceArguments() + If IsMissing(pvOption) Then pvOption = cstNull + + If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function + If pvQueryName = "" Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function + If pvSql = "" Then Call _TraceArguments() + If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + + If _ReadOnly Then Goto Error_NoUpdate + + Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition") + oQuery.rename(pvQueryName) + oQuery.Command = _ReplaceSquareBrackets(pvSql) + oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) + + Set oQueries = Document.DataSource.getQueryDefinitions() + With oQueries + For i = 0 To .getCount() - 1 + sQueryName = .getByIndex(i).Name + If UCase(sQueryName) = UCase(pvQueryName) Then + TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName) + .removeByName(sQueryName) + Exit For + End If + Next i + .insertByName(pvQueryName, oQuery) + End With + Set CreateQueryDef = QueryDefs(pvQueryName) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CreateQueryDef V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object +'Return a (new/empty) TableDef object +Const cstThisSub = "Database.CreateTableDef" + Utils._SetCalledSub(cstThisSub) + +Dim oTable As Object, oTables As Object, sTables() As String +Dim i As Integer, sTableName As String, oNewTable As Object +Dim vNameComponents() As Variant, iNames As Integer + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set CreateTableDef = Nothing + If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvTableName) Then Call _TraceArguments() + + If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function + If pvTableName = "" Then Call _TraceArguments() + + If _ReadOnly Then Goto Error_NoUpdate + + Set oTables = Connection.getTables + With oTables + sTables = .ElementNames() + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sTables) + If UCase(pvTableName) = UCase(sTables(i)) Then + sTableName = sTables(i) + TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName) + .dropByName(sTableName) + Exit For + End If + Next i + Set oNewTable = New DataDef + Set oNewTable._This = oNewTable + oNewTable._Type = OBJTABLEDEF + oNewTable._Name = pvTableName + vNameComponents = Split(pvTableName, ".") + iNames = UBound(vNameComponents) + If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = "" + If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = "" + oNewtable.TableName = vNameComponents(iNames) + Set oNewTable._ParentDatabase = _This + Set oNewTable.TableDescriptor = .createDataDescriptor() + oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName + oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName + oNewTable.TableDescriptor.Name = oNewTable.TableName + oNewTable.TableDescriptor.Type = "TABLE" + End With + + Set CreateTabledef = oNewTable + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CreateTableDef V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DAvg( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return average of scope +Const cstThisSub = "Database.DAvg" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DAvg + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DCount( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return # of occurrences of scope +Const cstThisSub = "Database.DCount" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DLookup( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + +' Return a value within a table + 'Arguments: psExpr: an SQL expression + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + 'Return: Value of the psExpr if found, else Null. + 'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html + 'Examples: + ' 1. To find the last value, include DESC in the OrderClause, e.g.: + ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC") + ' 2. To find the lowest non-null value of a field, use the Criteria, e.g.: + ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname") + +Const cstThisSub = "Database.DLookup" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DLookup = _DFunction("", psExpr, psDomain _ + , Iif(IsMissing(pvCriteria), "", pvCriteria) _ + , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _ + ) + Utils._ResetCalledSub(cstThisSub) +End Function ' DLookup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMax( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return maximum of scope +Const cstThisSub = "Database.DMax" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMax + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMin( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return minimum of scope +Const cstThisSub = "Database.DMin" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMin + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDev( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "Database.DStDev" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDev + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDevP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "Database.DStDevP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDevP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DSum( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return sum of scope +Const cstThisSub = "Database.DSum" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DSum + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVar( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "Database.DVar" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVarP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "Database.DVarP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVarP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Database.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Database.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenRecordset(ByVal Optional pvSource As Variant _ + , ByVal Optional pvType As Variant _ + , ByVal Optional pvOptions As Variant _ + , ByVal Optional pvLockEdit As Variant _ + ) As Object +'Return a Recordset object based on Source (= SQL, table or query name) + +Const cstThisSub = "Database.OpenRecordset" + Utils._SetCalledSub(cstThisSub) +Const cstNull = -1 + +Dim lCommandType As Long, sCommand As String, oObject As Object +Dim sSource As String, i As Integer, iCount As Integer +Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + Set oObject = Nothing + If IsMissing(pvSource) Then Call _TraceArguments() + If pvSource = "" Then Call _TraceArguments() + If IsMissing(pvType) Then + pvType = cstNull + Else + If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function + End If + If IsMissing(pvOptions) Then + pvOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + If IsMissing(pvLockEdit) Then + pvLockEdit = cstNull + Else + If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function + End If + + sSource = Split(UCase(Trim(pvSource)), " ")(0) + Select Case True + Case sSource = "SELECT" + lCommandType = com.sun.star.sdb.CommandType.COMMAND + sCommand = _ReplaceSquareBrackets(pvSource) + Case Else + sSource = UCase(Trim(pvSource)) + REM Explore tables + Set oTables = Connection.getTables + sObjects = oTables.ElementNames() + bFound = False + For i = 0 To UBound(sObjects) + If sSource = UCase(sObjects(i)) Then + sCommand = sObjects(i) + bFound = True + Exit For + End If + Next i + If bFound Then + lCommandType = com.sun.star.sdb.CommandType.TABLE + Else + REM Explore queries + Set oQueries = Connection.getQueries + sObjects = oQueries.ElementNames() + For i = 0 To UBound(sObjects) + If sSource = UCase(sObjects(i)) Then + sCommand = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + lCommandType = com.sun.star.sdb.CommandType.QUERY + End If + End Select + + Set oObject = New Recordset + With oObject + ._CommandType = lCommandType + ._Command = sCommand + ._ParentName = Title + ._ParentType = _Type + ._ForwardOnly = ( pvType = dbOpenForwardOnly ) + ._PassThrough = ( pvOptions = dbSQLPassThrough ) + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) + Set ._This = oObject + Set ._ParentDatabase = _This + Call ._Initialize() + RecordsetMax = RecordsetMax + 1 + ._Name = Format(RecordsetMax, "0000000") + RecordsetsColl.Add(oObject, UCase(._Name)) + End With + + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + +Exit_Function: + Set OpenRecordset = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource)) + Goto Exit_Function +End Function ' OpenRecordset V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain a SELECT query +' pvOption can force pass through mode + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Database.OpenSQL" + Utils._SetCalledSub(cstThisSub) + + OpenSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function + End If + If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable + +Dim oURL As New com.sun.star.util.URL, oDispatch As Object +Dim vArgs(8) as New com.sun.star.beans.PropertyValue + + oURL.Complete = ".component:DB/DataSourceBrowser" + oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8) + + vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = Connection + vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND + vArgs(2).Name = "Command" : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL) + vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True + vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False + vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False + vArgs(6).Name = "Filter" : vArgs(6).Value = "" + vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False + vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough )) + + oDispatch.dispatch(oURL, vArgs) + OpenSQL = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenSQL", Erl) + GoTo Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' OpenSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OutputTo(ByVal pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvOutputFormat As Variant _ + , ByVal Optional pvOutputFile As Variant _ + , ByVal Optional pvAutoStart As Variant _ + , ByVal Optional pvTemplateFile As Variant _ + , ByVal Optional pvEncoding As Variant _ + , ByVal Optional pvQuality As Variant _ + , ByRef Optional pvHeaders As Variant _ + , ByRef Optional pvData As Variant _ + ) As Boolean +'Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries +'pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Database.OutputTo" + Utils._SetCalledSub(cstThisSub) + + OutputTo = False + + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function + If IsMissing(pvObjectName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvOutputFormat) Then pvOutputFormat = "" + If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function + If pvOutputFormat <> "" Then + If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ + UCase(acFormatHTML), "HTML" _ + , UCase(acFormatODS), "ODS" _ + , UCase(acFormatXLS), "XLS" _ + , UCase(acFormatXLSX), "XLSX" _ + , UCase(acFormatTXT), "TXT", "CSV" _ + , "")) _ + Then Goto Exit_Function ' A 2nd time to allow case unsensitivity + End If + If IsMissing(pvOutputFile) Then pvOutputFile = "" + If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function + If IsMissing(pvAutoStart) Then pvAutoStart = False + If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function + If IsMissing(pvTemplateFile) Then pvTemplateFile = "" + If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function + If IsMissing(pvEncoding) Then pvEncoding = 0 + If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function + If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint + If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function + If pvObjectType = acOutputArray Then + If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments() + pvOutputFormat = "HTML" + End If + +Dim sOutputFile As String, oTable As Object +Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String + + If pvObjectType = acOutputArray Then + Set oTable = Nothing + Else + 'Find applicable table or query + If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True) + If IsNull(oTable) Then Goto Error_NotFound + End If + + 'Determine format and parameters + If pvOutputFormat = "" Then + sOutputFormat = _PromptFormat(Array("HTML", "ODS", "XLS", "XLSX", "TXT")) ' Prompt user for format + If sOutputFormat = "" Then Goto Exit_Function + Else + sOutputFormat = UCase(pvOutputFormat) + End If + + 'Determine output file + If pvOutputFile = "" Then ' Prompt file picker to user + Select Case sOutputFormat + Case UCase(acFormatHTML), "HTML" : sSuffix = "html" + Case UCase(acFormatODS), "ODS" : sSuffix = "ods" + Case UCase(acFormatXLS), "XLS" : sSuffix = "xls" + Case UCase(acFormatXLSX), "XLSX" : sSuffix = "xlsx" + Case UCase(acFormatTXT), "TXT", "CSV" : sSuffix = "txt" + End Select + sOutputFile = _PromptFilePicker(sSuffix) + If sOutputFile = "" Then Goto Exit_Function + Else + sOutputFile = pvOutputFile + End If + sOutputFile = ConvertToURL(sOutputFile) + + 'Create file + Select Case sOutputFormat + Case UCase(acFormatHTML), "HTML" + If pvObjectType = acOutputArray Then + bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData) + Else + bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile) + End If + Case UCase(acFormatODS), "ODS" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS) + Case UCase(acFormatXLS), "XLS" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS) + Case UCase(acFormatXLS), "XLSX" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX) + Case UCase(acFormatTXT), "TXT", "CSV" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding) + End Select + + 'Launch application, if requested + If bOutput Then + If pvAutoStart Then Call _ShellExecute(sOutputFile) + Else + GoTo Error_File + End If + + OutputTo = True + +Exit_Function: + If Not IsNull(oTable) Then + oTable.Dispose() + Set oTable = Nothing + End If + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_File: + TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile) + GoTo Exit_Function +End Function ' OutputTo V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + + Utils._SetCalledSub("Database.Properties") +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + Set vProperty._ParentDatabase = _This + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub("Database.Properties") + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object +' Collect all Queries in the database +' pbCheck unpublished + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Database.QueryDefs") + If IsMissing(pbCheck) Then pbCheck = False + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oQueries As Object + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + Set oQueries = Connection.getQueries + sObjects = oQueries.ElementNames() + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLQUERYDEFS + Set oObject._Parent = _This + oObject._Count = UBound(sObjects) + 1 + Goto Exit_Function + Case VarType(pvIndex) = vbString + bFound = False + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + End Select + + Set oObject = New DataDef + Set oObject._This = oObject + oObject._Type = OBJQUERYDEF + oObject._Name = sObjectName + Set oObject._ParentDatabase = _This + oObject._readOnly = _ReadOnly + Set oObject.Query = oQueries.getByName(sObjectName) + +Exit_Function: + Set QueryDefs = oObject + Set oObject = Nothing + Utils._ResetCalledSub("Database.QueryDefs") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl) + GoTo Exit_Function +Trace_NotFound: + If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' QueryDefs V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object +' Collect all active recordsets + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Database.Recordsets") + + Set Recordsets = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oTables As Object + + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLRECORDSETS + Set oObject._Parent = _This + oObject._Count = RecordsetsColl.Count + Case VarType(pvIndex) = vbString + bFound = _hasRecordset(pvIndex) + If Not bFound Then Goto Trace_NotFound + Set oObject = RecordsetsColl.Item(pvIndex) + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex >= RecordsetsColl.Count Then Goto Trace_IndexError + Set oObject = RecordsetsColl.Item(pvIndex + 1) ' Collection members are numbered 1 ... Count + End Select + +Exit_Function: + Set Recordsets = oObject + Set oObject = Nothing + Utils._ResetCalledSub("Database.Recordsets") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Database.Recordsets", Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Recordsets V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RunSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain an ACTION query + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Database.RunSQL" + Utils._SetCalledSub(cstThisSub) + + RunSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + +Dim oStatement As Object, vResult As Variant + Set oStatement = Connection.createStatement() + oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) + On Local Error Goto SQL_Error + vResult = oStatement.execute(_ReplaceSquareBrackets(pvSQL)) + On Local Error Goto Error_Function + RunSQL = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) + Goto Exit_Function +End Function ' RunSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object +' Collect all tables in the database +' pbCheck unpublished + +Const cstThisSub = "Database.TableDefs" + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + If IsMissing(pbCheck) Then pbCheck = False + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oTables As Object + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + Set oTables = Connection.getTables + sObjects = oTables.ElementNames() + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLTABLEDEFS + Set oObject._Parent = _This + oObject._Count = UBound(sObjects) + 1 + Goto Exit_Function + Case VarType(pvIndex) = vbString + bFound = False + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + End Select + + Set oObject = New DataDef + With oObject + ._This = oObject + ._Type = OBJTABLEDEF + ._Name = sObjectName + Set ._ParentDatabase = _This + ._ReadOnly = _ReadOnly + Set .Table = oTables.getByName(sObjectName) + .CatalogName = .Table.CatalogName + .SchemaName = .Table.SchemaName + .TableName = .Table.Name + End With + +Exit_Function: + Set TableDefs = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' TableDefs V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DFunction(ByVal psFunction As String _ + , ByVal psExpr As String _ + , ByVal psDomain As String _ + , ByVal pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + 'Arguments: psFunction an optional aggregate function + ' psExpr: an SQL expression [might contain an aggregate function] + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + +If _ErrorHandler() Then On Local Error GoTo Error_Function + +Dim oResult As Object 'To retrieve the value to find. +Dim vResult As Variant 'Return value for function. +Dim sSql As String 'SQL statement. +Dim oStatement As Object 'For CreateStatement method +Dim sExpr As String 'For inclusion of aggregate function +Dim sTempField As String 'Random temporary field in SQL expression + +Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String +Dim sProductName As String + + vResult = Null + + Randomize 2^14-1 + sTempField = "[TEMP" & Right("00000" & Int(100000 * Rnd), 5) & "]" + If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = "" + If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = "" + sLimit = "" + +' Workaround for https://bugs.documentfoundation.org/show_bug.cgi?id=118767 +' awaiting solution for https://bugs.documentfoundation.org/show_bug.cgi?id=118809 + sProductName = UCase(MetaData.getDatabaseProductName()) + If sProductName = "" Then + If MetaData.URL = "sdbc:embedded:firebird" Or Left(MetaData.URL, 13) = "sdbc:firebird" Then sProductName = "FIREBIRD" + End If + + Select Case sProductName + Case "MYSQL", "SQLITE" + If psFunction = "" Then + sTarget = psExpr + sLimit = " LIMIT 1" + Else + sTarget = UCase(psFunction) & "(" & psExpr & ")" + End If + sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy & sLimit + Case "FIREBIRD" + If psFunction = "" Then sTarget = "FIRST 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")" + sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy + Case Else ' Standard syntax - Includes HSQLDB + If psFunction = "" Then sTarget = "TOP 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")" + sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy + End Select + + 'Lookup the value. + Set oStatement = Connection.createStatement() + With oStatement + .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + .EscapeProcessing = False + sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string + Set oResult = .executeQuery(sSql) + If Not IsNull(oResult) And Not IsEmpty(oResult) Then + If Not oResult.next() Then Goto Exit_Function + vResult = Utils._getResultSetColumnValue(oResult, 1, True) ' Force return of binary field + End If + End With + +Exit_Function: + 'Assign the returned value. + _DFunction = vResult + Set oResult = Nothing + Set oStatement = Nothing + Exit Function +Error_Function: + TraceError(TRACEFATAL, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) + Goto Exit_Function +End Function ' DFunction V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String +' Return the default FilterOptions string for table/query export to csv + +Dim sFieldSeparator as string +Const cstComma = "," +Const cstTextDelimitor = """" + + If _DecimalPoint() = "," Then sFieldSeparator = ";" Else sFieldSeparator = cstComma + _FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _ + & cstComma & Trim(Str(Asc(cstTextDelimitor))) _ + & cstComma & Trim(Str(plEncoding)) _ + & cstComma & "1" + +End Function ' _FilterOptionsDefault V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasRecordset(ByVal psName As String) As Boolean +' Return True if psName if in the collection of Recordsets + +Dim oRecordset As Object + If _ErrorHandler() Then On Local Error Goto Error_Function + Set oRecordset = RecordsetsColl.Item(psName) + _hasRecordset = True + +Exit_Function: + Exit Function +Error_Function: ' Item by key aborted + _hasRecordset = False + GoTo Exit_Function +End Function ' _hasRecordset V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _LoadMetadata() +' Load essentially getTypeInfo() results from Metadata + +Dim sProduct As String +Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer + +Const cstMaxInfo = 40 + ReDim _ColumnTypes(0 To cstMaxInfo) + ReDim _ColumnTypeNames(0 To cstMaxInfo) + ReDim _ColumnPrecisions(0 To cstMaxInfo) +Const cstHSQLDB1 = "HSQL Database Engine 1." +Const cstHSQLDB2 = "HSQL Database Engine 2." +Const cstFirebird = "sdbc:embedded:firebird" +Const cstMSAccess2003 = "MS Jet 0" +Const cstMSAccess2007 = "MS Jet 04." +Const cstMYSQL = "MySQL" +Const cstPOSTGRES = "PostgreSQL" +Const cstSQLITE = "SQLite" + + With com.sun.star.sdbc.DataType + _ColumnTypesReference = Array( _ + .ARRAY _ + , .BIGINT _ + , .BINARY _ + , .BIT _ + , .BLOB _ + , .BOOLEAN _ + , .CHAR _ + , .CLOB _ + , .DATE _ + , .DECIMAL _ + , .DISTINCT _ + , .DOUBLE _ + , .FLOAT _ + , .INTEGER _ + , .LONGVARBINARY _ + , .LONGVARCHAR _ + , .NUMERIC _ + , .OBJECT _ + , .OTHER _ + , .REAL _ + , .REF _ + , .SMALLINT _ + , .SQLNULL _ + , .STRUCT _ + , .TIME _ + , .TIMESTAMP _ + , .TINYINT _ + , .VARBINARY _ + , .VARCHAR _ + ) + End With + + With Metadata + sProduct = .getDatabaseProductName() & " " & .getDatabaseProductVersion + Select Case True + Case Len(sProduct) > Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1 + _RDBMS = DBMS_HSQLDB1 + _ColumnTypesAlias = Array(0, -5, -2, 16, -4, 16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2 + _RDBMS = DBMS_HSQLDB2 + _ColumnTypesAlias = Array(0, -5, -3, -7, 2004, 16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3, 12) + _BinaryStream = True + Case .URL = cstFirebird ' Only embedded 3.0 + _RDBMS = DBMS_FIREBIRD + _ColumnTypesAlias = Array(0, -5, -2, 16, 2004, 16, 1, 2005, 91, 3, 0, 8, 6, 4, -4, 2005, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, 4, 2004, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007 + _RDBMS = DBMS_MSACCESS2007 + _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003 + _RDBMS = DBMS_MSACCESS2003 + _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL + _RDBMS = DBMS_MYSQL + _ColumnTypesAlias = Array(0, -5, -2, -7, -4, -7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, -1) + _BinaryStream = False + Case Len(sProduct) > Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES + _RDBMS = DBMS_POSTGRES + _ColumnTypesAlias = Array(0, -5, -3, 16, -3, 16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE + _RDBMS = DBMS_SQLITE + _ColumnTypesAlias = Array(0, -5, -4, -7, -4, -7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4, 12) + _BinaryStream = True + Case Else + _RDBMS = DBMS_UNKNOWN + _BinaryStream = True + End Select + + iInfo = -1 + Set oTypeInfo = MetaData.getTypeInfo() + With oTypeInfo + .next() + Do While Not .isAfterLast() And iInfo < cstMaxInfo + sName = .getString(1) + lType = .getLong(2) + If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) <> "_" Or lType <> -1) Then ' Skip + Else + iInfo = iInfo + 1 + _ColumnTypeNames(iInfo) = sName + _ColumnTypes(iInfo) = lType + _ColumnPrecisions(iInfo) = CLng(.getLong(3)) + End If + .next() + Loop + End With + ReDim Preserve _ColumnTypes(0 To iInfo) + ReDim Preserve _ColumnTypeNames(0 To iInfo) + ReDim Preserve _ColumnPrecisions(0 To iInfo) + End With + +End Sub ' _LoadMetadata V1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputBinaryToHTML() As String +' Converts Binary value to HTML compatible string + + _OutputBinaryToHTML = "&nbsp;" + +End Function ' _OutputBinaryToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String +' Converts input boolean value to HTML compatible string + + _OutputBooleanToHTML = Iif(pbBool, "&#x2714;", "&#x2716;") ' ✔ and ✖ + +End Function ' _OutputBooleanToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputClassToHTML(ByVal pvArray As variant) As String +' Formats classes attribute of <tr> and <td> tags + + If Not IsArray(pvArray) Then + _OutputClassToHTML = "" + ElseIf UBound(pvArray) < LBound(pvArray) Then + _OutputClassToHTML = "" + Else + _OutputClassToHTML = " class=""" & Join(pvArray, " ") & """" + End If + +End Function ' _OutputClassToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _ + , ByRef Optional pvHeaders As Variant _ + , ByRef Optional pvData As Variant _ + ) As Boolean +' Write html tags around data found in pvTable +' Exit when error without execution stop (to avoid file remaining open ...) + +Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer +Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant +Dim bDataArray As Boolean, sHeader As String +Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer +Const cstMaxRows = 200 + On Local Error GoTo Error_Function + + bDataArray = IsNull(pvTable) + Print #piFile, " <table class=""dbdatatable"">" + Print #piFile, " <caption>" & pvName & "</caption>" + + vFieldsBin() = Array() + If bDataArray Then + Set oTableRS = Nothing + iNumFields = UBound(pvHeaders) + 1 + ReDim vFieldsBin(0 To iNumFields - 1) + For i = 0 To iNumFields - 1 + vFieldsBin(i) = False + Next i + Else + Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly) + iNumFields = oTableRS.Fields.Count + ReDim vFieldsBin(0 To iNumFields - 1) + With com.sun.star.sdbc.DataType + For i = 0 To iNumFields - 1 + iDataType = oTableRS.Fields(i).DataType + vFieldsBin(i) = Utils._IsBinaryType(iDataType) + Next i + End With + End If + + With oTableRS + Print #piFile, " <thead>" + Print #piFile, " <tr>" + For i = 0 To iNumFields - 1 + If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name + Print #piFile, " <th scope=""col"">" & sHeader & "</th>" + Next i + Print #piFile, " </tr>" + Print #piFile, " </thead>" + Print #piFile, " <tfoot>" + Print #piFile, " </tfoot>" + + Print #piFile, " <tbody>" + If bDataArray Then + iLastRow = UBound(pvData, 2) + 1 + Else + .MoveLast + iLastRow = .RecordCount + .MoveFirst + End If + iCountRows = 0 + Do While iCountRows < iLastRow + If bDataArray Then + iNumRows = iLastRow + Else + vData() = .GetRows(cstMaxRows) + iNumRows = UBound(vData, 2) + 1 + End If + For j = 0 To iNumRows - 1 + iCountRows = iCountRows + 1 + vTrClass() = Array() + If iCountRows = 1 Then vTrClass() = _AddArray(vTrClass, "firstrow") + If iCountRows = iLastRow Then vTrClass() = _AddArray(vTrClass, "lastrow") + If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, "even") Else vTrClass() = _AddArray(vTrClass, "odd") + Print #piFile, " <tr" & _OutputClassToHTML(vTrClass) & ">" + For i = 0 To iNumFields - 1 + vTdClass() = Array() + If i = 0 Then vTdClass() = _AddArray(vTdClass, "firstcol") + 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 VarType(vDataCell) = vbString Then ' Null string gives IsDate = True ! + If Len(vDataCell) > 0 And IsDate(vDataCell) Then vDataCell = CDate(vDataCell) + End If + Select Case VarType(vDataCell) + Case vbEmpty, vbNull + vTdClass() = _AddArray(vTdClass, "null") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNullToHTML() & "</td>" + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt + vTdClass() = _AddArray(vTdClass, "numeric") + If vDataCell < 0 Then vTdClass() = _AddArray(vTdClass, "negative") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNumberToHTML(vDataCell) & "</td>" + Case vbBoolean + vTdClass() = _AddArray(vTdClass, "bool") + If vDataCell = False Then vTdClass() = _AddArray(vTdClass, "false") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBooleanToHTML(vDataCell) & "</td>" + Case vbDate + vTdClass() = _AddArray(vTdClass, "date") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputDateToHTML(vDataCell) & "</td>" + Case vbString + vTdClass() = _AddArray(vTdClass, "char") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputStringToHTML(vDataCell) & "</td>" + Case Else + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _CStr(vDataCell) & "</td>" + End Select + Else ' Binary fields + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBinaryToHTML() & "</td>" + End If + Next i + Print #piFile, " </tr>" + Next j + Loop + + If Not bDataArray Then .mClose() + End With + Set oTableRS = Nothing + + Print #piFile, " </tbody>" + Print #piFile, " </table>" + _OutputDataToHTML = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEWARNING, Err, "_OutputDataToHTML", Erl) + _OutputDataToHTML = False + Resume Exit_Function +End Function ' _OutputDataToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputDateToHTML(ByVal psDate As Date) As String +' Converts input date to HTML compatible string + + _OutputDateToHTML = Format(psDate) ' With regional settings - Ignores time if = to 0 + +End Function ' _OutputDateToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputNullToHTML() As String +' Converts Null value to HTML compatible string + + _OutputNullToHTML = "&nbsp;" + +End Function ' _OutputNullToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String +' Converts input number to HTML compatible string + +Dim vNumber As Variant + If IsMissing(piPrecision) Then piPrecision = -1 + If pvNumber = Int(pvNumber) Then + vNumber = Int(pvNumber) + Else + If piPrecision >= 0 Then vNumber = (Int(pvNumber * 10 ^ piPrecision + 0.5)) / 10 ^ piPrecision Else vNumber = pvNumber + End If + _OutputNumberToHTML = Format(vNumber) + +End Function ' _OutputNumberToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputStringToHTML(ByVal psString As String) As String +' Converts input string to HTML compatible string +' - UTF-8 encoding +' - recognition of next patterns +' - &quot; - &amp; - &apos; - &lt; - &gt; +' - <pre> +' - <a href="... +' - <br> +' - <img src="... +' - <b>, <u>, <i> + +Dim vPatterns As Variant +Dim lCurrentChar as Long, lPattern As Long, lNextPattern As Long, sPattern As String +Dim sOutput As String, sChar As String +Dim sUrl As String, lNextQuote As Long, lUrl As Long, bQuote As Boolean, bTagEnd As Boolean +Dim i As Integer, l As Long + + vPatterns = Array( _ + "&quot;", "&amp;", "&apos;", "&lt;", "&gt;", "&nbsp;" _ + , "<pre>", "</pre>", "<br>" _ + , "<a href=""", "<a id=""", "</a>", "<img src=""" _ + , "<span class=""", "</span>" _ + , "<b>", "</b>", "<u>", "</u>", "<i>", "</i>" _ + ) + + lCurrentChar = 1 + sOutput = "" + + Do While lCurrentChar <= Len(psString) + ' Where is next closest pattern ? + lPattern = Len(psString) + 1 + sPattern = "" + For i = 0 To UBound(vPatterns) + lNextPattern = InStr(lCurrentChar, psString, vPatterns(i), 1) ' Text (not case-sensitive) string comparison + If lNextPattern > 0 And lNextPattern < lPattern Then + lPattern = lNextPattern + sPattern = Mid(psString, lPattern, Len(vPatterns(i))) + End If + Next i + ' Up to the next pattern or to the end of the string, UTF8-encode each character + For l = lCurrentChar To lPattern - 1 + sChar = Mid(psString, l, 1) + sOutput = sOutput & Utils._UTF8Encode(sChar) + Next l + ' Process hyperlink patterns and keep others + If Len(sPattern) > 0 Then + Select Case LCase(sPattern) + Case "<a href=""", "<a id=""", "<img src=""", "<span class=""" + ' Up to next quote, url-encode + lNextQuote = 0 + lUrl = lPattern + Len(sPattern) + lNextQuote = InStr(lUrl, psString, """", 1) + If lNextQuote = 0 Then lNextQuote = Len(psString) ' Should not happen but, if quoted string not closed ... + sUrl = Mid(psString, lUrl, lNextQuote - lUrl) + sOutput = sOutput & sPattern & sUrl & """" + lCurrentChar = lNextQuote + 1 + bQuote = False + bTagEnd = False + Do + sChar = Mid(psString, lCurrentChar, 1) + Select Case sChar + Case """" + bQuote = Not bQuote + sOutput = sOutput & sChar + Case ">" ' Tag end if not somewhere between quotes + If Not bQuote Then + bTagEnd = True + sOutput = sOutput & sChar + Else + sOutput = sOutput & _UTF8Encode(sChar) + End If + Case Else + sOutput = sOutput & _UTF8Encode(sChar) + End Select + lCurrentChar = lCurrentChar + 1 + If lCurrentChar > Len(psString) Then bTagEnd = True ' Should not happen but, if tag not closed ... + Loop Until bTagEnd + Case Else + sOutput = sOutput & sPattern + lCurrentChar = lPattern + Len(sPattern) + End Select + Else + lCurrentChar = Len(psString) + 1 + End If + Loop + + _OutputStringToHTML = sOutput + +End Function ' _OutputStringToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputToCalc(poData As Object _ + , ByVal psOutputFile As String _ + , ByVal psFilter As String _ + , Optional ByVal plEncoding As Long _ + ) As Boolean +' https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Database_Import +' https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options + +Dim oCalcDoc As Object, oSheet As Object, vWin As Variant +Dim vImportDesc() As Variant, iSource As Integer +Dim oRange As Object, i As Integer, iCol As Integer, oColumns As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + _OutputToCalc = False + If IsMissing(plEncoding) Then plEncoding = acUTF8Encoding + ' Create a new OO-Calc-Document + Set oCalcDoc = StarDesktop.LoadComponentFromURL( _ + "private:factory/scalc" _ + , "_default" ,0, Array() _ + ) + + ' Get the unique spreadsheet + Set oSheet = oCalcDoc.Sheets(0) + + ' Describe import + With poData + If ._Type = "TABLEDEF" Then + iSource = com.sun.star.sheet.DataImportMode.TABLE + Else + iSource = com.sun.star.sheet.DataImportMode.QUERY + End If + vImportDesc = Array( _ + _MakePropertyValue("DatabaseName", URL) _ + , _MakePropertyValue("SourceType", iSource) _ + , _MakePropertyValue("SourceObject", ._Name) _ + ) + oSheet.Name = ._Name + End With + + ' Import + oSheet.getCellByPosition(0, 0).doImport(vImportDesc()) + + Select Case psFilter + Case acFormatODS, acFormatXLS, acFormatXLSX ' Formatting + iCol = poData.Fields().Count + Set oRange = oSheet.getCellRangeByPosition(0, 0, iCol - 1, 0) + oRange.CharWeight = com.sun.star.awt.FontWeight.BOLD + oRange.CellBackColor = RGB(200, 200, 200) + oRange.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER + Set oColumns = oRange.getColumns() + For i = 0 To iCol - 1 + oColumns.getByIndex(i).OptimalWidth = True + Next i + oCalcDoc.storeAsUrl(psOutputFile, Array( _ + _MakePropertyValue("FilterName", psFilter) _ + , _MakePropertyValue("Overwrite", True) _ + )) + Case Else + oCalcDoc.storeAsUrl(psOutputFile, Array( _ + _MakePropertyValue("FilterName", psFilter) _ + , _MakePropertyValue("FilterOptions", _FilterOptionsDefault(plEncoding)) _ + , _MakePropertyValue("Overwrite", True) _ + )) + End Select + + oCalcDoc.close(False) + _OutputToCalc = True + +Exit_Function: + Set oColumns = Nothing + Set oRange = Nothing + Set oSheet = Nothing + Set oCalcDoc = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) + Goto Exit_Function +End Function ' OutputToCalc V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _OutputToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal psOutputFile As String, ByVal psTemplateFile As String _ + , ByRef Optional pvHeaders As Variant _ + , ByRef Optional pvData As Variant _ + ) As Boolean +' http://www.ehow.com/how_5652706_create-html-template-ms-access.html + +Dim bDataArray As Boolean +Dim vMinimalTemplate As Variant, vTemplate As Variant +Dim iFile As Integer, i As Integer, sLine As String, lBody As Long +Const cstTitle = "<!--Template_Title-->", cstBody = "<!--Template_Body-->" +Const cstTitleAlt = "<!--AccessTemplate_Title-->", cstBodyAlt = "<!--AccessTemplate_Body-->" + + On Local Error GoTo Error_Function + vMinimalTemplate = Array( _ + "<!DOCTYPE html>" _ + , "<html>" _ + , " <head>" _ + , " <title>" & cstTitle & "</title>" _ + , " </head>" _ + , " <body>" _ + , " " & cstBody _ + , " </body>" _ + , "</html>" _ + ) + + vTemplate = _ReadFileIntoArray(psTemplateFile) + If LBound(vTemplate) > UBound(vTemplate) Then vTemplate() = vMinimalTemplate() + + bDataArray = IsNull(pvTable) + +' Write output file + iFile = FreeFile() + Open psOutputFile For Output Access Write Lock Read Write As #iFile + For i = 0 To UBound(vTemplate) + sLine = vTemplate(i) + sLine = Join(Split(sLine, cstTitleAlt), cstTitle) + sLine = Join(Split(sLine, cstBodyAlt), cstBody) + Select Case True + Case InStr(sLine, cstTitle) > 0 + sLine = Join(Split(sLine, cstTitle), pvName) + Print #iFile, sLine + Case InStr(sLine, cstBody) > 0 + lBody = InStr(sLine, cstBody) + If lBody > 1 Then Print #iFile, Left(sLine, lBody - 1) + If bDataArray Then + _OutputDataToHTML(pvTable, pvName, iFile, pvHeaders, pvData) + Else + _OutputDataToHTML(pvTable, pvName, iFile) + End If + If Len(sLine) > lBody + Len(cstBody) - 1 Then Print #iFile, Right(sLine, Len(sLine) - lBody + Len(cstBody) + 1) + Case Else + Print #iFile, sLine + End Select + Next i + Close #iFile + + _OutputToHTML = True + +Exit_Function: + Exit Function +Error_Function: + _OutputToHTML = False + GoTo Exit_Function +End Function ' _OutputToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("Connect", "Name", "ObjectType" _ + , "OnCreate", "OnFocus", "OnLoad", "OnLoadFinished", "OnModifyChanged" _ + , "OnNew", "OnPrepareUnload", "OnPrepareViewClosing", "OnSave", "OnSaveAs" _ + , "OnSaveAsDone", "OnSaveAsFailed", "OnSaveDone", "OnSaveFailed", "OnSaveTo" _ + , "OnSaveToDone", "OnSaveToFailed", "OnSubComponentClosed", "OnSubComponentOpened" _ + , "OnTitleChanged", "OnUnfocus", "OnUnload", "OnViewClosed", "OnViewCreated" _ + , "Version" _ + ) + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + +Dim i As Integer, vEvents As Variant, sEvent As String, vEvent As Variant + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Database.get" & psProperty) + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("Connect") + If IsNull(Document) Then _PropertyGet = "" Else _PropertyGet = Document.Datasource.URL + ' Location = ConvertFromUrl(URL) + Case UCase("Name") + _PropertyGet = Title + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnCreate"), UCase("OnFocus"), UCase("OnLoad"), UCase("OnLoadFinished"), UCase("OnModifyChanged") _ + , UCase("OnNew"), UCase("OnPrepareUnload"), UCase("OnPrepareViewClosing"), UCase("OnSave"), UCase("OnSaveAs") _ + , UCase("OnSaveAsDone"), UCase("OnSaveAsFailed"), UCase("OnSaveDone"), UCase("OnSaveFailed"), UCase("OnSaveTo") _ + , UCase("OnSaveToDone"), UCase("OnSaveToFailed"), UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") _ + , UCase("OnTitleChanged"), UCase("OnUnfocus"), UCase("OnUnload"), UCase("OnViewClosed"), UCase("OnViewCreated") + ' Find script event + sEvent = "" + If IsNull(Document) Then vEvents = Array() Else vEvents = Document.getEvents().ElementNames ' Returns an array + For i = 0 To UBound(vEvents) + If UCase(vEvents(i)) = UCase(psProperty) Then + sEvent = vEvents(i) + Exit For + End If + Next i + If sEvent = "" Then + _PropertyGet = "" + Else + vEvent = Document.getEvents().getByName(sEvent) + If IsEmpty(vEvent) Then + _PropertyGet = "" + ElseIf vEvent(0).Value <> "Script" Then + _PropertyGet = "" + Else + _PropertyGet = vEvent(1).Value + End If + End If + Case UCase("Version") + _PropertyGet = MetaData.getDatabaseProductName() & " " & MetaData.getDatabaseProductVersion + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Database.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Database._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String +' Returns psSql after substitution of [] by quote character +' [] square brackets in (single) quoted strings not affected + +Dim sQuote As String 'RDBMS specific quote character +Dim vSubStrings() As Variant, i As Integer +Const cstSingleQuote = "'" + + sQuote = MetaData.IdentifierQuoteString + If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported. + _ReplaceSquareBrackets = Trim(psSql) + Exit Function + End If + vSubStrings() = Split(psSql, cstSingleQuote) + For i = 0 To UBound(vSubStrings) + If (i Mod 2) = 0 Or (i = UBound(vSubStrings)) Then ' Only even substrings are parsed for square brackets. Last substring is parsed anyway + vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote) + vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote) + End If + Next i + + _ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote)) + +End Function ' ReplaceSquareBrackets V1.1.0 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Dialog.xba b/wizards/source/access2base/Dialog.xba new file mode 100644 index 000000000..69caed33c --- /dev/null +++ b/wizards/source/access2base/Dialog.xba @@ -0,0 +1,818 @@ +<?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="Dialog" 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 DIALOG +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Shortcut As String +Private _Dialog As Object ' com.sun.star.io.XInputStreamProvider +Private _Storage As String ' GLOBAL or DOCUMENT +Private _Library As String +Private UnoDialog As Object ' com.sun.star.awt.XControl + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJDIALOG + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + Set _Dialog = Nothing + _Storage = "" + _Library = "" + Set UnoDialog = Nothing +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 Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Height() As Variant + Height = _PropertyGet("Height") +End Property ' Height (get) + +Property Let Height(ByVal pvValue As Variant) + Call _PropertySet("Height", pvValue) +End Property ' Height (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get IsLoaded() As Boolean + IsLoaded = _PropertyGet("IsLoaded") +End Property + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' OnFocusGained (get) + +Property Let OnFocusGained(ByVal pvValue As Variant) + Call _PropertySet("OnFocusGained", pvValue) +End Property ' OnFocusGained (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' OnFocusLost (get) + +Property Let OnFocusLost(ByVal pvValue As Variant) + Call _PropertySet("OnFocusLost", pvValue) +End Property ' OnFocusLost (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' OnKeyPressed (get) + +Property Let OnKeyPressed(ByVal pvValue As Variant) + Call _PropertySet("OnKeyPressed", pvValue) +End Property ' OnKeyPressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' OnKeyReleased (get) + +Property Let OnKeyReleased(ByVal pvValue As Variant) + Call _PropertySet("OnKeyReleased", pvValue) +End Property ' OnKeyReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' OnMouseDragged (get) + +Property Let OnMouseDragged(ByVal pvValue As Variant) + Call _PropertySet("OnMouseDragged", pvValue) +End Property ' OnMouseDragged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' OnMouseEntered (get) + +Property Let OnMouseEntered(ByVal pvValue As Variant) + Call _PropertySet("OnMouseEntered", pvValue) +End Property ' OnMouseEntered (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' OnMouseExited (get) + +Property Let OnMouseExited(ByVal pvValue As Variant) + Call _PropertySet("OnMouseExited", pvValue) +End Property ' OnMouseExited (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' OnMouseMoved (get) + +Property Let OnMouseMoved(ByVal pvValue As Variant) + Call _PropertySet("OnMouseMoved", pvValue) +End Property ' OnMouseMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' OnMousePressed (get) + +Property Let OnMousePressed(ByVal pvValue As Variant) + Call _PropertySet("OnMousePressed", pvValue) +End Property ' OnMousePressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' OnMouseReleased (get) + +Property Let OnMouseReleased(ByVal pvValue As Variant) + Call _PropertySet("OnMouseReleased", pvValue) +End Property ' OnMouseReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name +' A group is determined by the successive TabIndexes of the radio button +' The name of the group = the name of its first element + + Utils._SetCalledSub("Dialog.OptionGroup") + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set OptionGroup = Nothing + If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function + +Dim iAllCount As Integer, iRadioLast As Integer, iGroupCount As Integer, iBegin As Integer, iEnd As Integer +Dim oRadios() As Object, sGroupName As String +Dim i As Integer, j As Integer, bFound As Boolean, ocControl As Object, oRadio As Object, iTabIndex As Integer +Dim ogGroup As Object, vGroup() As Variant, vIndex() As Variant + iAllCount = Controls.Count + If iAllCount > 0 Then + iRadioLast = -1 + ReDim oRadios(0 To iAllCount - 1) + For i = 0 To iAllCount - 1 ' Store all RadioButtons objects + Set ocControl = Controls(i) + If ocControl._SubType = CTLRADIOBUTTON Then + iRadioLast = iRadioLast + 1 + Set oRadios(iRadioLast) = ocControl + End If + Next i + Else + Goto Error_Arg ' No control in dialog + End If + + If iRadioLast < 0 then Goto Error_Arg ' No radio buttons in the dialog + + 'Resort oRadio array based on tab indexes + If iRadioLast > 0 Then + For i = 0 To iRadioLast - 1 ' Bubble sort + For j = i + 1 To iRadioLast + If oRadios(i).TabIndex > oRadios(j).TabIndex Then + Set oRadio = oRadios(i) + Set oRadios(i) = oRadios(j) + Set oRadios(j) = oRadio + End If + Next j + Next i + End If + + 'Scan Names to find match with argument + bFound = False + For i = 0 To iRadioLast + If UCase(oRadios(i)._Name) = UCase(pvGroupName) Then + Select Case i + Case 0 : bFound = True + Case Else + If oRadios(i).TabIndex > oRadios(i - 1).TabIndex + 1 Then + bFound = True + Else + Goto Error_Arg ' same group as preceding item although name correct + End If + End Select + If bFound Then + iBegin = i + iEnd = i + sGroupName = oRadios(i)._Name + End If + ElseIf bFound Then + If oRadios(i).TabIndex = oRadios(i - 1).TabIndex + 1 Then iEnd = i + End If + Next i + + If bFound Then ' Create OptionGroup + iGroupCount = iEnd - iBegin + 1 + Set ogGroup = New OptionGroup + ReDim vGroup(0 To iGroupCount - 1) + ReDim vIndex(0 To iGroupCount - 1) + With ogGroup + ._This = ogGroup + ._Name = sGroupName + ._Count = iGroupCount + ._ButtonsGroup = vGroup + ._ButtonsIndex = vIndex + For i = 0 To iGroupCount - 1 + Set ._ButtonsGroup(i) = oRadios(iBegin + i).ControlModel + ._ButtonsIndex(i) = i + Next i + ._ParentType = CTLPARENTISDIALOG + ._ParentComponent = UnoDialog + End With + Else Goto Error_Arg + End If + + Set OptionGroup = ogGroup + +Exit_Function: + Utils._ResetCalledSub("Dialog.OptionGroup") + Exit Function +Error_Arg: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.OptionGroup", Erl) + GoTo Exit_Function +End Function ' OptionGroup V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Page() As Variant + Page = _PropertyGet("Page") +End Property ' Page (get) + +Property Let Page(ByVal pvValue As Variant) + Call _PropertySet("Page", pvValue) +End Property ' Page (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _Parent +End Function ' Parent (get) V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' 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 + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, 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 Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Width() As Variant + Width = _PropertyGet("Width") +End Property ' Width (get) + +Property Let Width(ByVal pvValue As Variant) + Call _PropertySet("Width", pvValue) +End Property ' Width (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.Controls") + +Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer + + Set ocControl = Nothing + If Not IsLoaded Then Goto Trace_Error_NotOpen + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISDIALOG + sParentShortcut = _Shortcut + sControls() = UnoDialog.Model.getElementNames() + iControlCount = UBound(sControls) + 1 + + If IsMissing(pvIndex) Then ' No argument, return Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + oCounter._Count = iControlCount + Set oCounter._Parent = _This + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + ocControl._Name = sControls(pvIndex) + Case vbString ' Check control name validity (non case sensitive) + bFound = False + sIndex = UCase(Utils._Trim(pvIndex)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sIndex Then + bFound = True + Exit For + End If + Next i + If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + End Select + + ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name) + Set ocControl.ControlModel = UnoDialog.Model.getByName(ocControl._Name) + Set ocControl.ControlView = UnoDialog.getControl(ocControl._Name) + ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() + ocControl._FormComponent = UnoDialog + + ocControl._Initialize() + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("Dialog.Controls") + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex)) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_NotOpen: + TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, , _Name) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex)) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub EndExecute(ByVal Optional pvReturn As Variant) +' Stop executing the dialog + +If _ErrorHandler() Then On Local Error Goto Error_Sub + Utils._SetCalledSub("Dialog.endExecute") + + If IsMissing(pvReturn) Then pvReturn = 0 + If Not Utils._CheckArgument(pvReturn, 1, Utils._AddNumeric(), , False) Then Goto Trace_Error + +Dim lExecute As Long + lExecute = CLng(pvReturn) + If IsNull(_Dialog) Then Goto Error_Execute + If IsNull(UnoDialog) Then Goto Error_Not_Started + Call UnoDialog.endDialog(lExecute) + +Exit_Sub: + Utils._ResetCalledSub("Dialog.endExecute") + Exit Sub +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array("1", Utils._CStr(pvReturn))) + Goto Exit_Sub +Error_Execute: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Sub +Error_Not_Started: + TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + Goto Exit_Sub +Error_Sub: + TraceError(TRACEABORT, Err, "Dialog.endExecute", Erl) + GoTo Exit_Sub +End Sub ' EndExecute + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Execute() As Long +' Execute dialog + +'If _ErrorHandler() Then On Local Error Goto Error_Function +'Seems smart not to trap errors: debugging of dialog events otherwise made very difficult ! + Utils._SetCalledSub("Dialog.Execute") + +Dim lExecute As Long + If IsNull(_Dialog) Then Goto Error_Execute + If IsNull(UnoDialog) Then Goto Error_Not_Started + lExecute = UnoDialog.execute() + + Select Case lExecute + Case 1 : Execute = dlgOK + Case 0 : Execute = dlgCancel + Case Else : Execute = lExecute + End Select + +Exit_Function: + Utils._ResetCalledSub("Dialog.Execute") + Exit Function +Error_Execute: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Not_Started: + TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Execute", Erl) + GoTo Exit_Function +End Function ' Execute + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Dialog.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Dialog.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move( ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute Move method + Utils._SetCalledSub("Dialog.Move") + On Local Error Goto Error_Function + Move = False +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("Move") : iArgNr = 1 + Case UCase("Dialog.Move") : iArgNr = 0 + End Select + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function + +Dim iArg As Integer, iWrong As Integer ' Check arguments values + iArg = 0 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If + If iArg > 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) + Goto Exit_Function + End If + +Dim iPosSize As Integer + iPosSize = 0 + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + If iPosSize > 0 Then UnoDialog.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) + Move = True + +Exit_Function: + Utils._ResetCalledSub("Dialog.Move") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Move", Erl) + GoTo Exit_Function +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("Dialog.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("Dialog.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Start() As Boolean +' Create dialog + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.Start") + +Dim oStart As Object + Start = False + If IsNull(_Dialog) Then Goto Error_Start + If Not IsNull(UnoDialog) Then Goto Error_Yet_Started + Set oStart = CreateUnoDialog(_Dialog) + If IsNull(oStart) Then + Goto Error_Start + Else + Start = True + Set UnoDialog = oStart + With _A2B_ + If .hasItem(COLLALLDIALOGS, _Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate + .Dialogs.Add(UnoDialog, UCase(_Name)) + End With + End If + +Exit_Function: + Utils._ResetCalledSub("Dialog.Start") + Exit Function +Error_Start: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Yet_Started: + TraceError(TRACEWARNING, ERRDIALOGSTARTED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Start", Erl) + GoTo Exit_Function +End Function ' Start + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Terminate() As Boolean +' Close dialog + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.Terminate") + + Terminate = False + If IsNull(_Dialog) Then Goto Error_Terminate + If IsNull(UnoDialog) Then Goto Error_Not_Started + UnoDialog.Dispose() + Set UnoDialog = Nothing + _A2B_.Dialogs.Remove(_Name) + Terminate = True + +Exit_Function: + Utils._ResetCalledSub("Dialog.Terminate") + Exit Function +Error_Terminate: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Not_Started: + TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Terminate", Erl) + GoTo Exit_Function +End Function ' Terminate + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + If IsLoaded Then + _PropertiesList = Array("Caption", "Height", "IsLoaded", "Name" _ + , "OnFocusGained", "OnFocusLost", "OnKeyPressed", "OnKeyReleased", "OnMouseDragged" _ + , "OnMouseEntered", "OnMouseExited", "OnMouseMoved", "OnMousePressed", "OnMouseReleased" _ + , "ObjectType", "Page", "Visible", "Width" _ + ) + Else + _PropertiesList = Array("IsLoaded", "Name" _ + ) + End If + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.get" & psProperty) + +Dim oDialogEvents As Object, sEventName As String + +'Execute + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("Name"), UCase("IsLoaded") + Case Else + If IsNull(UnoDialog) Then Goto Trace_Error_Dialog + End Select + Select Case UCase(psProperty) + Case UCase("Caption") + _PropertyGet = UnoDialog.getTitle() + Case UCase("Height") + _PropertyGet = UnoDialog.getPosSize().Height + Case UCase("IsLoaded") + _PropertyGet = _A2B_.hasItem(COLLALLDIALOGS, _Name) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased") + Set oDialogEvents = unoDialog.Model.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty) + If oDialogEvents.hasByName(sEventName) Then + _PropertyGet = oDialogEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case UCase("Page") + _PropertyGet = UnoDialog.Model.Step + Case UCase("Visible") + _PropertyGet = UnoDialog.IsVisible() + Case UCase("Width") + _PropertyGet = UnoDialog.getPosSize().Width + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Dialog.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Dialog: + TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("Dialog.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +Dim oDialogEvents As Object, sEventName As String, oEvent As Object, sListener As String, sEvent As String + +'Execute +Dim iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "Dialog.") Then iArgNr = 1 Else iArgNr = 2 + If IsNull(UnoDialog) Then Goto Trace_Error_Dialog + Select Case UCase(psProperty) + Case UCase("Caption") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + UnoDialog.setTitle(pvValue) + Case UCase("Height") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + UnoDialog.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT) + Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Not Utils._RegisterDialogEventScript(UnoDialog.Model _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + ) Then GoTo Trace_Error_Dialog + Case UCase("Page") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + UnoDialog.Model.Step = pvValue + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + UnoDialog.setVisible(pvValue) + Case UCase("Width") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value + UnoDialog.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Dialog.set" & psProperty) + Exit Function +Trace_Error_Dialog: + TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + _PropertySet = False + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba new file mode 100644 index 000000000..27b0d74be --- /dev/null +++ b/wizards/source/access2base/DoCmd.xba @@ -0,0 +1,2662 @@ +<?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="DoCmd" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +Type _FindParams + FindRecord As Integer ' Set to 1 at first invocation of FindRecord + FindWhat As Variant + Match As Integer + MatchCase As Boolean + Search As Integer + SearchAsFormatted As Boolean ' Must be False + FindFirst As Boolean + OnlyCurrentField As Integer + Form As String ' Shortcut + GridControl As String ' Shortcut + Target As String ' Shortcut + LastRow As Long ' Last row explored - 0 = before first + LastColumn As Integer ' Last column explored - 0 ... N-1 index in next arrays; 0 if OnlyCurrentField = acCurrent + ColumnNames() As String ' Array of column names in grid with boundfield and of same type as FindWhat + ResultSetIndex() As Integer ' Array of column numbers in ResultSet +End Type + +Type _Window + Frame As Object ' com.sun.star.comp.framework.Frame + _Name As String ' Object Name + WindowType As Integer ' One of the object types + DocumentType As String ' Writer, Calc, ... - Only if WindowType = acDocument +End Type + +REM VBA allows call to actions with missing arguments e.g. OpenForm("aaa",,"[field]=2") +REM in StarBasic IsMissing requires Variant parameters + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ApplyFilter( _ + ByVal Optional pvFilter As Variant _ + , ByVal Optional pvSQL As Variant _ + , ByVal Optional pvControlName As Variant _ + ) As Boolean +' Set filter on open table, query, form or subform (if pvControlName present) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "ApplyFilter" + Utils._SetCalledSub(cstThisSub) + ApplyFilter = False + + If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments() + If IsMissing(pvFilter) Then pvFilter = "" + If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function + If IsMissing(pvSQL) Then pvSQL = "" + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function + If IsMissing(pvControlName) Then pvControlName = "" + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + +Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + If pvSQL <> "" _ + Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _ + Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter) + + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oTarget = _DatabaseForm(._Name, pvControlName) + Case acQuery, acTable + If pvControlName <> "" Then Goto Exit_Function + If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oTarget = .Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + + With oTarget + .Filter = sFilter + .ApplyFilter = True + .reload() + End With + ApplyFilter = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' ApplyFilter V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose(Optional ByVal pvObjectType As Variant _ + , Optional ByVal pvObjectName As Variant _ + , Optional ByVal pvSave As Variant _ + ) As Boolean + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Close" + Utils._SetCalledSub(cstThisSub) + mClose = False + If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments() + If IsMissing(pvSave) Then pvSave = acSavePrompt + If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acTable, acQuery, acForm, acReport)) _ + And Utils._CheckArgument(pvObjectName, 2, vbString) _ + And Utils._CheckArgument(pvSave, 3, Utils._AddNumeric(), Array(acSavePrompt)) _ + ) Then Goto Exit_Function + +Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object +Dim i As Integer, bFound As Boolean, lComponent As Long +Dim oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + ' Check existence of object and find its exact (case-sensitive) name + Select Case pvObjectType + Case acForm + sObjects = Application._GetAllHierarchicalNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.FORM + Case acTable + sObjects = oDatabase.Connection.getTables.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE + Case acQuery + sObjects = oDatabase.Connection.getQueries.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY + Case acReport + sObjects = oDatabase.Document.getReportDocuments.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT + End Select + bFound = False + For i = 0 To UBound(sObjects) + If UCase(pvObjectName) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + + Select Case pvObjectType + Case acForm + Set oController = oDatabase.Document.getFormDocuments.getByHierarchicalName(sObjectName) + mClose = oController.close() + Case acTable, acQuery ' Not optimal but it works !! + Set oController = oDatabase.Document.CurrentController + Set oObject = oController.loadComponent(lComponent, sObjectName, False) + oObject.frame.close(False) + mClose = True + Case acReport + Set oController = oDatabase.Document.getReportDocuments.getByName(sObjectName) + mClose = oController.close() + End Select + + +Exit_Function: + Set oObject = Nothing + Set oController = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Close", Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRCLOSEOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' (m)Close V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CopyObject(ByVal Optional pvSourceDatabase As Variant _ + , ByVal Optional pvNewName As Variant _ + , ByVal Optional pvSourceType As Variant _ + , ByVal Optional pvSourceName As Variant _ + ) As Boolean +' Copies tables and queries into identical (new) objects + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CopyObject" + Utils._SetCalledSub(cstThisSub) + CopyObject = False + + If IsMissing(pvSourceDatabase) Then pvSourceDatabase = "" + If VarType(pvSourceDatabase) <> vbString Then + If Not Utils._CheckArgument(pvSourceDatabase, 1, OBJDATABASE) Then Goto Exit_Function + End If + If IsMissing(pvNewName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvSourceType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _ + ) Then Goto Exit_Function + If IsMissing(pvSourceName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto Exit_Function + +Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase As Object, bSameDatabase As Boolean +Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object, oTargetCol As Object, iRDBMS As Integer +Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object +Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant +Dim vNameComponents() As Variant, iNames As Integer, sSurround As String +Dim vInputField As Variant, vFieldBinary() As Variant, vOutputField As Variant +Dim oInput as Object, oOutput As Object, iNbFields As Integer, vValue As Variant +Dim vBinary As Variant, lInputSize As Long, lOutputSize As Long +Dim lInputRecs As Long, lInputMax As Long, vField As Variant, bProgressMeter As Boolean, sFile As String + +Const cstMaxBinlength = 2 * 65535 +Const cstChunkSize = 2 * 65535 +Const cstProgressMeterLimit = 100 + + Set oDatabase = Application._CurrentDb() + bSameDatabase = False + If VarType(pvSourceDatabase) = vbString Then + If pvSourceDatabase = "" Then + Set oSourceDatabase = oDatabase + bSameDatabase = True + Else + Set oSourceDatabase = Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), , , True) + If IsNull(oSourceDatabase) Then Goto Exit_Function + End If + Else + Set oSourceDatabase = pvSourceDatabase + End If + + With oDatabase + iRDBMS = ._RDBMS + If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Select Case pvSourceType + + Case acQuery + Set oSource = oSourceDatabase.QueryDefs(pvSourceName, True) + If IsNull(oSource) Then Goto Error_NotFound + Set oTarget = .QueryDefs(pvNewName, True) + If Not IsNull(oTarget) Then .Connection.getQueries.dropByName(oTarget.Name) ' a query with same name exists already ... drop it + If oSource.Query.EscapeProcessing Then + Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL) + Else + Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough) + End If + ' Save .odb document + .Document.store() + + Case acTable + Set oSource = oSourceDatabase.TableDefs(pvSourceName, True) + If IsNull(oSource) Then Goto Error_NotFound + Set oTarget = .TableDefs(pvNewName, True) + ' A table with same name exists already ... drop it + If Not IsNull(oTarget) Then .Connection.getTables.dropByName(oTarget.Name) + ' Copy source table columns + Set oSourceTable = oSource.Table + Set oTarget = .Connection.getTables.createDataDescriptor + oTarget.Description = oSourceTable.Description + vNameComponents = Split(pvNewName, ".") + iNames = UBound(vNameComponents) + If iNames >= 2 Then oTarget.CatalogName = vNameComponents(iNames - 2) Else oTarget.CatalogName = "" + If iNames >= 1 Then oTarget.SchemaName = vNameComponents(iNames - 1) Else oTarget.SchemaName = "" + oTarget.Name = vNameComponents(iNames) + oTarget.Type = oSourceTable.Type + Set oSourceColumns = oSourceTable.Columns + Set oTargetCol = oTarget.Columns.createDataDescriptor + For i = 0 To oSourceColumns.getCount() - 1 + ' Append each individual column to the table descriptor + Set oSourceCol = oSourceColumns.getByIndex(i) + _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase + oTarget.Columns.appendByDescriptor(oTargetCol) + Next i + + ' Copy keys + Set oSourceKeys = oSourceTable.Keys + Set oTargetKey = oTarget.Keys.createDataDescriptor() + For i = 0 To oSourceKeys.getCount() - 1 + ' Append each key to table descriptor + Set oSourceKey = oSourceKeys.getByIndex(i) + oTargetKey.DeleteRule = oSourceKey.DeleteRule + oTargetKey.Name = oSourceKey.Name + oTargetKey.ReferencedTable = oSourceKey.ReferencedTable + oTargetKey.Type = oSourceKey.Type + oTargetKey.UpdateRule = oSourceKey.UpdateRule + Set oTargetCol = oTargetKey.Columns.createDataDescriptor() + For j = 0 To oSourceKey.Columns.getCount() - 1 + Set oSourceCol = oSourceKey.Columns.getByIndex(j) + _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase, True + oTargetKey.Columns.appendByDescriptor(oTargetCol) + Next j + oTarget.Keys.appendByDescriptor(oTargetKey) + Next i + ' Duplicate table whole design + .Connection.getTables.appendByDescriptor(oTarget) + + ' Copy data + Select Case bSameDatabase + Case True + ' Build SQL statement to copy data + sSurround = Utils._Surround(oSource.Name) + sSql = "INSERT INTO " & Utils._Surround(pvNewName) & " SELECT " & sSurround & ".* FROM " & sSurround + DoCmd.RunSQL(sSql) + Case False + ' Copy data row by row and field by field + ' As it is slow ... display a progress meter + Set oInput = oSourceDatabase.OpenRecordset(oSource.Name, , , dbReadOnly) + Set oOutput = .Openrecordset(pvNewName) + + With oInput + If Not ( ._BOF And ._EOF ) Then + .MoveLast + lInputMax = .RecordCount + lInputRecs = 0 + .MoveFirst + bProgressMeter = ( lInputMax > cstProgressMeterLimit ) + + iNbFields = .Fields().Count - 1 + vFieldBinary = Array() + ReDim vFieldBinary(0 To iNbFields) + For i = 0 To iNbFields + vFieldBinary(i) = Utils._IsBinaryType(.Fields(i).Column.Type) + Next i + Else + bProgressMeter = False + End If + If bProgressMeter Then Application.SysCmd acSysCmdInitMeter, pvNewName & " 0 %", lInputMax + Do While Not .EOF() + oOutput.RowSet.moveToInsertRow() + oOutput._EditMode = dbEditAdd + For i = 0 To iNbFields + Set vInputField = .Fields(i) + Set vOutputField = oOutput.Fields(i) + If vFieldBinary(i) Then + lInputSize = vInputField.FieldSize + If lInputSize <= cstMaxBinlength Then + vField = Utils._getResultSetColumnValue(.RowSet, i + 1, True) + Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField) + ElseIf oDatabase._BinaryStream Then + ' Typically for SQLite where binary fields are limited + If lInputSize > vOutputField._Precision Then + TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1)) + Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, Null) + Else + sFile = Utils._GetRandomFileName("BINARY") + vInputField._WriteAll(sFile, "WriteAllBytes") + vOutputField._ReadAll(sFile, "ReadAllBytes") + Kill ConvertToUrl(sFile) + End If + End If + Else + vField = Utils._getResultSetColumnValue(.RowSet, i + 1) + If VarType(vField) = vbString Then + If Len(vField) > vOutputField._Precision Then + TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1)) + End If + End If + ' Update is done anyway, if too long, with truncation + Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField) + End If + Next i + + If oOutput.RowSet.IsNew And oOutput.RowSet.IsModified Then oOutput.RowSet.insertRow() + oOutput._EditMode = dbEditNone + lInputRecs = lInputRecs + 1 + If bProgressMeter Then + If lInputRecs Mod (lInputMax / 100) = 0 Then + Application.SysCmd acSysCmdUpdateMeter, pvNewName & " " & CStr(CLng(lInputRecs * 100 / lInputMax)) & "%", lInputRecs + End If + End If + .MoveNext + Loop + End With + + oOutput.mClose() + Set oOutput = Nothing + oInput.mClose() + Set oInput = Nothing + if bProgressMeter Then Application.SysCmd acSysCmdClearStatus + End Select + + Case Else + End Select + End With + + CopyObject = True + +Exit_Function: + ' Avoid closing the current database or the database object given as source argument + If VarType(pvSourceDatabase) = vbString And Not bSameDatabase Then + If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose() + End If + Set oSourceDatabase = Nothing + If Not IsNull(oOutput) Then oOutput.mClose() + Set oOutput = Nothing + If Not IsNull(oInput) Then oInput.mClose() + Set oInput = Nothing + Set oSourceCol = Nothing + Set oSourceKey = Nothing + Set oSourceKeys = Nothing + Set oSource = Nothing + Set oSourceTable = Nothing + Set oSourceColumns = Nothing + Set oTargetCol = Nothing + Set oTargetKey = Nothing + Set oTarget = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CopyObject V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function FindNext() As Boolean +' Must be called after a FindRecord +' Execute instructions set in FindRecord object + + If _ErrorHandler() Then On Local Error Goto Error_Function + FindNext = False + Utils._SetCalledSub("FindNext") + +Dim ofForm As Object, ocGrid As Object +Dim i As Integer, lInitialRow As Long, lFindRow As Long +Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean +Dim vFindValue As Variant, oFindrecord As Object + + Set oFindRecord = _A2B_.FindRecord + If IsNull(oFindRecord) Then GoTo Error_FindRecord + With oFindRecord + + If .FindRecord = 0 Then Goto Error_FindRecord + .FindRecord = 0 + Set ofForm = getObject(.Form) + If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola + Set ocGrid = getObject(.GridControl) + + ' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween + If ofForm.DatabaseForm.RowCount <= 0 then Goto Exit_Function ' Dataset is empty + + lInitialRow = .LastRow ' Used if Search = acSearchAll + + bFound = False + lFindRow = .LastRow + b2ndRound = False + Do + ' Last column ? Go to next row + If .LastColumn >= UBound(.ColumnNames) Then + bStop = False + If ofForm.DatabaseForm.isAfterLast() And .Search = acUp Then + ofForm.DatabaseForm.last() + ElseIf ofForm.DatabaseForm.isLast() And .Search = acSearchAll Then + ofForm.DatabaseForm.first() + b2ndRound = True + ElseIf ofForm.DatabaseForm.isBeforeFirst() And (.Search = acDown Or .Search = acSearchAll) Then + ofForm.DatabaseForm.first() + ElseIf ofForm.DatabaseForm.isFirst() And .search = acUp Then + ofForm.DatabaseForm.beforeFirst() + bStop = True + ElseIf ofForm.DatabaseForm.isLast() And .search = acDown Then + ofForm.DatabaseForm.afterLast() + bStop = True + ElseIf .Search = acUp Then + ofForm.DatabaseForm.previous() + Else + ofForm.DatabaseForm.next() + End If + lFindRow = ofForm.DatabaseForm.getRow() + If bStop Or (.Search = acSearchAll And lFindRow >= lInitialRow And b2ndRound) Then + ofForm.DatabaseForm.absolute(lInitialRow) + Exit Do + End If + .LastColumn = 0 + Else + .LastColumn = .LastColumn + 1 + End If + + ' Examine column contents + If .LastColumn <= UBound(.ColumnNames) Then + For i = .LastColumn To UBound(.ColumnNames) + vFindValue = Utils._getResultSetColumnValue(ofForm.DatabaseForm.createResultSet(), .ResultSetIndex(i)) + Select Case VarType(.FindWhat) + Case vbDate, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + bFound = ( .FindWhat = vFindValue ) + Case vbString + If VarType(vFindValue) = vbString Then + Select Case .Match + Case acStart + If .MatchCase Then + bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue ) + Else + bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) ) + End If + Case acAnyWhere + If .MatchCase Then + bFound = ( InStr(1, vFindValue, .FindWhat, 0) > 0 ) + Else + bFound = ( InStr(vFindValue, .FindWhat) > 0 ) + End If + Case acEntire + If .MatchCase Then + bFound = ( .FindWhat = vFindValue ) + Else + bFound = ( UCase(.FindWhat) = UCase(vFindValue) ) + End If + End Select + Else + bFound = False + End If + End Select + If bFound Then + .LastColumn = i + Exit For + End If + Next i + End If + Loop While Not bFound + + .LastRow = lFindRow + If bFound Then + ocGrid.Controls(.ColumnNames(.LastColumn)).setFocus() + .FindRecord = 1 + FindNext = True + End If + + End With + +Exit_Function: + Utils._ResetCalledSub("FindNext") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "FindNext", Erl) + GoTo Exit_Function +Error_FindRecord: + TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' FindNext V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function FindRecord(Optional ByVal pvFindWhat As Variant _ + , Optional ByVal pvMatch As Variant _ + , Optional ByVal pvMatchCase As Variant _ + , Optional ByVal pvSearch As Variant _ + , Optional ByVal pvSearchAsFormatted As Variant _ + , Optional ByVal pvTargetedField As Variant _ + , Optional ByVal pvFindFirst As Variant _ + ) As Boolean + +'Find a value (string or other) in the underlying data of a gridcontrol +'Search in all columns or only in one single control +' see pvTargetedField = acAll or acCurrent +' pvTargetedField may also be a shortcut to a GridControl or one of its subcontrols +'Initialize _Findrecord structure in Database root and call FindNext() to set cursor on found value + + If _ErrorHandler() Then On Local Error Goto Error_Function + FindRecord = False + + Utils._SetCalledSub("FindRecord") + If IsMissing(pvFindWhat) Or pvFindWhat = "" Then Call _TraceArguments() + If IsMissing(pvMatch) Then pvMatch = acEntire + If IsMissing(pvMatchCase) Then pvMatchCase = False + If IsMissing(pvSearch) Then pvSearch = acSearchAll + If IsMissing(pvSearchAsFormatted) Then pvSearchAsFormatted = False ' Anyway only False supported + If IsMissing(pvTargetedField) Then pvTargetedField = acCurrent + If IsMissing(pvFindFirst) Then pvFindFirst = True + If Not (Utils._CheckArgument(pvFindWhat, 1, Utils._AddNumeric(Array(vbString, vbDate))) _ + And Utils._CheckArgument(pvMatch, 2, Utils._AddNumeric(), Array(acAnywhere, acEntire, acStart)) _ + And Utils._CheckArgument(pvMatchCase, 3, vbBoolean) _ + And Utils._CheckArgument(pvSearch, 4, Utils._AddNumeric(), Array(acDown, acSearchAll, acUp)) _ + And Utils._CheckArgument(pvSearchAsFormatted, 5, vbBoolean, Array(False)) _ + And Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(vbString)) _ + And Utils._CheckArgument(pvFindFirst, 7, vbBoolean) _ + ) Then Exit Function + If VarType(pvTargetedField) <> vbString Then + If Not Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(), Array(acAll, acCurrent)) Then Exit Function + End If + +Dim ocTarget As Object, i As Integer, j As Integer, vNames() As Variant, iCount As Integer, vIndexes() As Variant +Dim vColumn As Variant, vDataField As Variant, ofParentForm As Variant, oColumns As Object, vParentGrid As Object +Dim bFound As Boolean, ocGridControl As Object, iFocus As Integer +Dim oFindRecord As _FindParams + With oFindRecord + .FindRecord = 0 + .FindWhat = pvFindWhat + .Match = pvMatch + .MatchCase = pvMatchCase + .Search = pvSearch + .SearchAsFormatted = pvSearchAsFormatted + .FindFirst = pvFindFirst + + ' Determine target + ' Either: pvTargetedField = Grid => search all fields + ' pvTargetedField = Control in Grid => search only in that column + ' pvTargetedField = acAll or acCurrent => determine focus + Select Case True + + Case VarType(pvTargetedField) = vbString + Set ocTarget = getObject(pvTargetedField) + + If ocTarget.SubType = CTLGRIDCONTROL Then + .OnlyCurrentField = acAll + .GridControl = ocTarget._Shortcut + .Target = .GridControl + ofParentForm = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name)) + If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + iCount = -1 + For i = 0 To ocTarget.ControlModel.Count - 1 + Set vColumn = ocTarget.ControlModel.getByIndex(i) + Set vDataField = vColumn.BoundField ' examine field type + If Not IsNull(vDataField) Then + If _CheckColumnType(pvFindWhat, vDataField) Then + iCount = iCount + 1 + ReDim Preserve vNames(0 To iCount) + vNames(iCount) = vColumn.Name + ReDim Preserve vIndexes(0 To iCount) + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(iCount) = j + 1 + Exit For + End If + Next j + End If + End If + Next i + + ElseIf ocTarget._Type = OBJCONTROL Then ' Control within a grid tbc + If IsNull(ocTarget.ControlModel.BoundField) Then Goto Error_Target ' Control MUST be bound to a database record or query + ' BoundField is in ControlModel, thanks PASTIM ! + .OnlyCurrentField = acCurrent + vParentGrid = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name)) + If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target + .GridControl = vParentGrid._Shortcut + ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name)) + If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola + If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm + .Target = ocTarget._Shortcut + Set vDataField = ocTarget.ControlModel.BoundField + If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target + ReDim vNames(0), vIndexes(0) + vNames(0) = ocTarget._Name + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(0) = j + 1 + Exit For + End If + Next j + End If + + Case Else ' Determine focus + iCount = Application.Forms()._Count + If iCount = 0 Then Goto Error_ActiveForm + bFound = False + For i = 0 To iCount - 1 ' Determine form having the focus + Set ofParentForm = Application.Forms(i) + If ofParentForm.Component.CurrentController.Frame.IsActive() Then + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Error_ActiveForm + If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm + iCount = ofParentForm.Controls().Count + bFound = False + For i = 0 To iCount - 1 + Set ocGridControl = ofParentForm.Controls(i) + If ocGridControl.SubType = CTLGRIDCONTROL Then + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Error_NoGrid + .GridControl= ocGridControl._Shortcut + iFocus = -1 + iFocus = ocGridControl.ControlView.getCurrentColumnPosition() ' Deprecated but no alternative found !! + + If pvTargetedField = acAll Or iFocus < 0 Or iFocus >= ocGridControl.ControlModel.Count Then ' Has a control within the grid the focus ? NO + .OnlyCurrentField = acAll + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + iCount = -1 + For i = 0 To ocGridControl.ControlModel.Count - 1 + Set vColumn = ocGridControl.ControlModel.getByIndex(i) + Set vDataField = vColumn.BoundField ' examine field type + If Not IsNull(vDataField) Then + If _CheckColumnType(pvFindWhat, vDataField) Then + iCount = iCount + 1 + ReDim Preserve vNames(0 To iCount) + vNames(iCount) = vColumn.Name + ReDim Preserve vIndexes(0 To iCount) + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(iCount) = j + 1 + Exit For + End If + Next j + End If + End If + Next i + + Else ' Has a control within the grid the focus ? YES + .OnlyCurrentField = acCurrent + Set vColumn = ocGridControl.ControlModel.getByIndex(iFocus) + Set ocTarget = ocGridControl.Controls(vColumn.Name) + .Target = ocTarget._Shortcut + Set vDataField = ocTarget.ControlModel.BoundField + If IsNull(vDataField) Then Goto Error_Target ' Control MUST be bound to a database record or query + If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target + ReDim vNames(0), vIndexes(0) + vNames(0) = ocTarget._Name + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(0) = j + 1 + Exit For + End If + Next j + End If + + End Select + + .Form = ofParentForm._Shortcut + .LastColumn = UBound(vNames) + .ColumnNames = vNames + .ResultSetIndex = vIndexes + If pvFindFirst Then + Select Case pvSearch + Case acDown, acSearchAll + ofParentForm.DatabaseForm.beforeFirst() + .LastRow = 0 + Case acUp + ofParentForm.DatabaseForm.afterLast() + .LastRow = ofParentForm.DatabaseForm.RowCount + 1 + End Select + Else + Select Case True + Case ofParentForm.DatabaseForm.isBeforeFirst And (pvSearch = acSearchAll Or pvSearch = acDown) + .LastRow = 0 + Case ofParentForm.DatabaseForm.isAfterLast And pvSearch = acUp + ofParentForm.DatabaseForm.last() ' RowCount produces a wrong value as long as last record has not been reached + .LastRow = ofParentForm.DatabaseForm.RowCount + 1 + Case Else + .LastRow = ofParentForm.DatabaseForm.getRow() + End Select + End If + + .FindRecord = 1 + + End With + Set _A2B_.FindRecord = oFindRecord + FindRecord = DoCmd.Findnext() + +Exit_Function: + Utils._ResetCalledSub("FindRecord") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "FindRecord", Erl) + GoTo Exit_Function +Error_ActiveForm: + TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0) + Goto Exit_Function +Error_DatabaseForm: + TraceError(TRACEFATAL, ERRDATABASEFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) + Goto Exit_Function +Error_Target: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(6, pvTargetedField)) + Goto Exit_Function +Error_NoGrid: + TraceError(TRACEFATAL, ERRNOGRIDINFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) + Goto Exit_Function +End Function ' FindRecord V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "GetHiddenAttribute" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible() + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' GetHiddenAttribute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GoToControl(Optional ByVal pvControlName As variant) As Boolean +' Set the focus on the named control on the active form. +' Return False if the control does not exist or is disabled, + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("GoToControl") + If IsMissing(pvControlName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + + GoToControl = False +Dim oWindow As Object, ofForm As Object, ocControl As Object +Dim i As Integer, iCount As Integer + Set oWindow = _SelectWindow() + If oWindow.WindowType = acForm Then + Set ofForm = Application.Forms(oWindow._Name) + iCount = ofForm.Controls().Count + For i = 0 To iCount - 1 + ocControl = ofForm.Controls(i) + If UCase(ocControl._Name) = UCase(pvControlName) Then + If Methods.hasProperty(ocControl, "Enabled") Then + If ocControl.Enabled Then + ocControl.setFocus() + GoToControl = True + Exit For + End If + End If + End If + Next i + End If + +Exit_Function: + Utils._ResetCalledSub("GoToControl") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "GoToControl", Erl) + GoTo Exit_Function +End Function ' GoToControl V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GoToRecord(Optional ByVal pvObjectType As Variant _ + , Optional ByVal pvObjectName As Variant _ + , Optional ByVal pvRecord As Variant _ + , Optional ByVal pvOffset As Variant _ + ) As Boolean + +'Move to record indicated by pvRecord/pvOffset in the window designated by pvObjectType and pvObjectName + + If _ErrorHandler() Then On Local Error Goto Error_Function + GoToRecord = False + +Const cstThisSub = "GoTorecord" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvObjectName) Then pvObjectName = "" + If IsMissing(pvObjectType) Then pvObjectType = acActiveDataObject + If IsMissing(pvRecord) Then pvRecord = acNext + If IsMissing(pvOffset) Then pvOffset = 1 + If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _ + , Array(acActiveDataObject, acDataForm, acDataQuery, acDataTable)) _ + And Utils._CheckArgument(pvObjectName, 2, vbString) _ + And Utils._CheckArgument(pvRecord, 3, Utils._AddNumeric() _ + , Array(acFirst, acGoTo, acLast, acNewRec, acNext, acPrevious)) _ + And Utils._CheckArgument(pvOffset, 4, Utils._AddNumeric()) _ + ) Then Goto Exit_Function + If pvObjectType = acActiveDataObject And pvObjectName <> "" Then Goto Error_Target + If pvOffset < 0 And pvRecord <> acGoTo Then Goto Error_Offset + +Dim ofForm As Object, oGeneric As Object, oResultSet As Object, oWindow As Object +Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long +Dim sObjectName, iLengthName As Integer + Select Case pvObjectType + Case acActiveDataObject + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oResultSet = _DatabaseForm(._Name, "") + Case acQuery, acTable + If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oResultSet = .Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + Case acDataForm + ' pvObjectName can be "myForm", "Forms!myForm", "Forms!myForm!mySubform" or "Forms!myForm!mySubform.Form" + sObjectName = UCase(pvObjectName) + iLengthName = Len(sObjectName) + Select Case True + Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" And Right(sObjectName, 5) = ".FORM" + Set ofForm = getObject(pvObjectName) + If ofForm._Type <> OBJSUBFORM Then Goto Error_Target + Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" + Set oGeneric = getObject(pvObjectName) + If oGeneric._Type = OBJFORM Or oGeneric._Type = OBJSUBFORM Then + Set ofForm = oGeneric + ElseIf oGeneric.SubType = CTLSUBFORM Then + Set ofForm = oGeneric.Form + Else Goto Error_Target + End If + Case sObjectName = "" + Call _TraceArguments() + Case Else + Set ofForm = Application.Forms(pvObjectName) + End Select + Set oResultSet = ofForm.DatabaseForm + Case acDataQuery + Set oWindow = _SelectWindow(acQuery, pvObjectName) + If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor + Case acDataTable + Set oWindow = _SelectWindow(acTable, pvObjectName) + If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor + Case Else + End Select + + ' Check if current row updated => Save it + If oResultSet.IsNew Then + oResultSet.insertRow() + ElseIf oResultSet.IsModified Then + oResultSet.updateRow() + End If + + lOffset = pvOffset + Select Case pvRecord + Case acFirst : GoToRecord = oResultSet.first() + Case acGoTo : GoToRecord = oResultSet.absolute(lOffset) + Case acLast : GoToRecord = oResultSet.last() + Case acNewRec + oResultSet.last() ' To simulate the behaviour in the UI + oResultSet.moveToInsertRow() + GoToRecord = True + Case acNext + If lOffset = 1 Then + GoToRecord = oResultSet.next() + Else + GoToRecord = oResultSet.relative(lOffset) + End If + Case acPrevious + If lOffset = 1 Then + GoToRecord = oResultSet.previous() + Else + GoToRecord = oResultSet.relative(- lOffset) + End If + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_Target: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(2, pvObjectName)) + Goto Exit_Function +Error_Offset: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(4, pvOffset)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' GoToRecord + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Maximize() As Boolean +' Maximize the window having the focus + Utils._SetCalledSub("Maximize") + +Dim oWindow As Object + Maximize = False + Set oWindow = _SelectWindow() + If Not IsNull(oWindow.Frame) Then + If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMaximized") Then oWindow.Frame.ContainerWindow.IsMaximized = True ' Ignored when <= OO3.2 + Maximize = True + End If + + Utils._ResetCalledSub("Maximize") + Exit Function +End Function ' Maximize V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Minimize() As Boolean +' Maximize the form having the focus + Utils._SetCalledSub("Minimize") + +Dim oWindow As Object + Minimize = False + Set oWindow = _SelectWindow() + If Not IsNull(oWindow.Frame) Then + If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMinimized") Then oWindow.Frame.ContainerWindow.IsMinimized = True + Minimize = True + End If + + Utils._ResetCalledSub("Minimize") + Exit Function +End Function ' Minimize V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveSize(ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute MoveSize action + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("MoveSize") + MoveSize = False + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function + +Dim iArg As Integer, iWrong As Integer ' Check arguments values + iArg = 0 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If + If iArg > 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArg, iWrong)) + Goto Exit_Function + End If + +Dim iPosSize As Integer + iPosSize = 0 + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + +Dim oWindow As Object + Set oWindow = _SelectWindow() + With oWindow + If Not IsNull(.Frame) Then + If Utils._hasUNOProperty(.Frame.ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + .Frame.ContainerWindow.IsMaximized = False + .Frame.ContainerWindow.IsMinimized = False + End If + .Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) + MoveSize = True + End If + End With + +Exit_Function: + Utils._ResetCalledSub("MoveSize") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "MoveSize", Erl) + GoTo Exit_Function +End Function ' MoveSize V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenForm(Optional ByVal pvFormName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvFilterName As Variant _ + , Optional ByVal pvWhereCondition As Variant _ + , Optional ByVal pvDataMode As Variant _ + , Optional ByVal pvWindowMode As Variant _ + , Optional ByVal pvOpenArgs As Variant _ + ) As Variant + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenForm") + If IsMissing(pvFormName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acNormal + If IsMissing(pvFilterName) Then pvFilterName = "" + If IsMissing(pvWhereCondition) Then pvWhereCondition = "" + If IsMissing(pvDataMode) Then pvDataMode = acFormPropertySettings + If IsMissing(pvWindowMode) Then pvWindowMode = acWindowNormal + If IsMissing(pvOpenArgs) Then pvOpenArgs = "" + Set OpenForm = Nothing + If Not (Utils._CheckArgument(pvFormName, 1, vbString) _ + And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acNormal, acPreview, acDesign)) _ + And Utils._CheckArgument(pvFilterName, 3, vbString) _ + And Utils._CheckArgument(pvWhereCondition, 4, vbString) _ + And Utils._CheckArgument(pvDataMode, 5, Utils._AddNumeric(), Array(acFormAdd, acFormEdit, acFormPropertySettings, acFormReadOnly)) _ + And Utils._CheckArgument(pvWindowMode, 6, Utils._AddNumeric(), Array(acDialog, acHidden, acIcon, acWindowNormal)) _ + ) Then Goto Exit_Function + +Dim ofForm As Object, sWarning As String +Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object + + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + Set ofForm = Application.AllForms(pvFormName) + If ofForm.IsLoaded Then + sWarning = _GetLabel("ERR" & ERRFORMYETOPEN) + sWarning = Join(Split(sWarning, "%0"), ofForm._Name) + TraceLog(TRACEANY, "OpenForm: " & sWarning) + Set OpenForm = ofForm + Goto Exit_Function + End If +' Open the form + Select Case pvView + Case acNormal, acPreview: bOpenMode = False + Case acDesign : bOpenMode = True + End Select + Set oController = oDatabase.Document.CurrentController + Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode) + +' Apply the filters (FilterName) AND (WhereCondition) +Dim sFilter As String, oForm As Object, oFormsCollection As Object + If pvFilterName = "" And pvWhereCondition = "" Then + sFilter = "" + ElseIf pvFilterName = "" Or pvWhereCondition = "" Then + sFilter = pvFilterName & pvWhereCondition + Else + sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")" + End If + Set oFormsCollection = oOpenForm.DrawPage.Forms + If oFormsCollection.getCount() > 0 Then Set oForm = oFormsCollection.getByIndex(0) Else Set oForm = Nothing + If Not IsNull(oForm) Then + If sFilter <> "" Then + oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter) + oForm.ApplyFilter = True + oForm.reload() + ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed + oForm.Filter = "" + oForm.ApplyFilter = False + oForm.reload() + End If + End If + +'Housekeeping + Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open + With ofForm + If Not IsNull(.DatabaseForm) Then + Select Case pvDataMode + Case acFormAdd + .AllowAdditions = True + .AllowDeletions = False + .AllowEdits = False + Case acFormEdit + .AllowAdditions = True + .AllowDeletions = True + .AllowEdits = True + Case acFormReadOnly + .AllowAdditions = False + .AllowDeletions = False + .AllowEdits = False + Case acFormPropertySettings + End Select + End If + .Visible = ( pvWindowMode <> acHidden ) + ._OpenArgs = pvOpenArgs + 'To avoid AOO 3.4 bug See http://user.services.openoffice.org/en/forum/viewtopic.php?f=13&t=53751 + .Component.CurrentController.ViewSettings.ShowOnlineLayout = True + End With + + Set OpenForm = ofForm + +Exit_Function: + Utils._ResetCalledSub("OpenForm") + Set ofForm = Nothing + Set oOpenForm = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenForm", Erl) + Set OpenForm = Nothing + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1) + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName) + Set OpenForm = Nothing + Goto Exit_Function +End Function ' OpenForm V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenQuery(Optional ByVal pvQueryName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenQuery") + If IsMissing(pvQueryName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acViewNormal + If IsMissing(pvDataMode) Then pvDataMode = acEdit + OpenQuery = DoCmd._OpenObject("Query", pvQueryName, pvView, pvDataMode) + +Exit_Function: + Utils._ResetCalledSub("OpenQuery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenQuery", Erl) + GoTo Exit_Function +End Function ' OpenQuery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenReport(Optional ByVal pvReportName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenReport") + If IsMissing(pvReportName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acViewNormal + If IsMissing(pvDataMode) Then pvDataMode = acEdit + OpenReport = DoCmd._OpenObject("Report", pvReportName, pvView, pvDataMode) + +Exit_Function: + Utils._ResetCalledSub("OpenReport") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenReport", Erl) + GoTo Exit_Function +End Function ' OpenReport + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain a SELECT query +' pvOption can force pass through mode + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenSQL") + + OpenSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function + End If + + OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption) + +Exit_Function: + Utils._ResetCalledSub("OpenSQL") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenSQL", Erl) + GoTo Exit_Function +End Function ' OpenSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenTable(Optional ByVal pvTableName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenTable") + If IsMissing(pvTableName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acViewNormal + If IsMissing(pvDataMode) Then pvDataMode = acEdit + OpenTable = DoCmd._OpenObject("Table", pvTableName, pvView, pvDataMode) + +Exit_Function: + Utils._ResetCalledSub("OpenTable") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenTable", Erl) + GoTo Exit_Function +End Function ' OpenTable + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OutputTo(ByVal pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvOutputFormat As Variant _ + , ByVal Optional pvOutputFile As Variant _ + , ByVal Optional pvAutoStart As Variant _ + , ByVal Optional pvTemplateFile As Variant _ + , ByVal Optional pvEncoding As Variant _ + , ByVal Optional pvQuality As Variant _ + ) As Boolean +REM https://wiki.openoffice.org/wiki/Framework/Article/Filter/FilterList_OOo_3_0 +REM https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options +REM https://msdn.microsoft.com/en-us/library/ms709353%28v=vs.85%29.aspx +'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms +' acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OutputTo" + Utils._SetCalledSub(cstThisSub) + + OutputTo = False + + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputForm)) Then Goto Exit_Function + If IsMissing(pvObjectName) Then pvObjectName = "" + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvOutputFormat) Then pvOutputFormat = "" + If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function + If pvOutputFormat <> "" Then + If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ + UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _ + , UCase(acFormatODS), UCase(acFormatXLS), UCase(acFormatXLSX), UCase(acFormatTXT) _ + , "PDF", "ODT", "DOC", "HTML", "ODS", "XLS", "XLSX", "TXT", "CSV", "" _ + )) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity + End If + If IsMissing(pvOutputFile) Then pvOutputFile = "" + If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function + If IsMissing(pvAutoStart) Then pvAutoStart = False + If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function + If IsMissing(pvTemplateFile) Then pvTemplateFile = "" + If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function + If IsMissing(pvEncoding) Then pvEncoding = 0 + If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function + If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint + If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function + + If pvObjectType = acOutputTable Or pvObjectType = acOutputQuery Then + OutputTo = Application._CurrentDb().OutputTo( _ + pvObjectType _ + , pvObjectName _ + , pvOutputFormat _ + , pvOutputFile _ + , pvAutoStart _ + , pvTemplateFile _ + , pvEncoding _ + , pvQuality _ + ) + GoTo Exit_Function + End If + +Dim vWindow As Variant, sOutputFile As String, ofForm As Object, i As Integer, bFound As Boolean + 'Find applicable form + If pvObjectName = "" Then + vWindow = _SelectWindow() + If vWindow.WindowType <> acOutoutForm Then Goto Error_Action + Set ofForm = Application.Forms(vWindow._Name) + Else + bFound = False + For i = 0 To Application.Forms()._Count - 1 + Set ofForm = Application.Forms(i) + If UCase(ofForm._Name) = UCase(pvObjectName) Then + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Error_NotFound + End If + + 'Determine format and parameters +Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport As Object, sSuffix As String + If pvOutputFormat = "" Then + sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format + If sOutputFormat = "" Then Goto Exit_Function + Else + sOutputFormat = UCase(pvOutputFormat) + End If + Select Case sOutputFormat + Case UCase(acFormatPDF), "PDF" + sFilter = acFormatPDF + oFilterData = Array( _ + _MakePropertyValue ("ExportFormFields", False), _ + ) + sSuffix = "pdf" + Case UCase(acFormatDOC), "DOC" + sFilter = acFormatDOC + oFilterData = Array() + sSuffix = "doc" + Case UCase(acFormatODT), "ODT" + sFilter = acFormatODT + oFilterData = Array() + sSuffix = "odt" + Case UCase(acFormatHTML), "HTML" + sFilter = acFormatHTML + oFilterData = Array() + sSuffix = "html" + End Select + oExport = Array( _ + _MakePropertyValue("Overwrite", True), _ + _MakePropertyValue("FilterName", sFilter), _ + _MakePropertyValue("FilterData", oFilterData), _ + ) + + 'Determine output file + If pvOutputFile = "" Then ' Prompt file picker to user + sOutputFile = _PromptFilePicker(sSuffix) + If sOutputFile = "" Then Goto Exit_Function + Else + sOutputFile = pvOutputFile + End If + sOutputFile = ConvertToURL(sOutputFile) + + 'Create file + On Local Error Goto Error_File + ofForm.Component.storeToURL(sOutputFile, oExport) + On Local Error Goto Error_Function + + 'Launch application, if requested + If pvAutoStart Then Call _ShellExecute(sOutputFile) + + OutputTo = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Action: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_File: + TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile) + GoTo Exit_Function +End Function ' OutputTo V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Quit(Optional ByVal pvSave As Variant) As Variant +' Quit the application +' Modified from Andrew Pitonyak's Base Macro Programming §5.8.1 + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Quit" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvSave) Then pvSave = acQuitSaveAll + If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _ + Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _ + ) Then Goto Exit_Function + +Dim oDatabase As Object, oDoc As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If Not IsNull(oDatabase) Then + Set oDoc = oDatabase.Document + Select Case pvSave + Case acQuitPrompt + If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function + Case acQuitSaveNone + oDoc.setModified(False) + Case Else + End Select + If HasUnoInterfaces(oDoc, "com.sun.star.util.XCloseable") Then + If (oDoc.isModified) Then + If (oDoc.hasLocation AND (Not oDoc.isReadOnly)) Then + oDoc.store() + End If + End If + oDoc.close(true) + Else + oDoc.dispose() + End If + End If + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Set oDatabase = Nothing + Set oDoc = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + Set OpenForm = Nothing + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' Quit V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub RunApp(Optional ByVal pvCommandLine As Variant) +' Convert to URL and execute the Command Line + + If _ErrorHandler() Then On Local Error Goto Error_Sub + + Utils._SetCalledSub("RunApp") + + If IsMissing(pvCommandLine) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub + + _ShellExecute(ConvertToURL(pvCommandLine)) + +Exit_Sub: + Utils._ResetCalledSub("RunApp") + Exit Sub +Error_Sub: + TraceError(TRACEABORT, Err, "RunApp", Erl) + GoTo Exit_Sub +End Sub ' RunApp V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RunCommand(Optional pvCommand As Variant, Optional pbReturnCommand As Boolean) As Variant +' Execute command via DispatchHelper +' pbReturnCommand = internal parameter to only return the exact command string (always absent if uno prefix present in pvCommand) + + If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort +Const cstThisSub = "RunCommand" + Utils._SetCalledSub(cstThisSub) + +Dim iVBACommand As Integer, sOOCommand As String, sDispatch As String + If IsMissing(pvCommand) Then Call _TraceArguments() + If Not ( Utils._CheckArgument(pvCommand, 1, Utils._AddNumeric(vbString)) ) Then Goto Exit_Function + If IsMissing(pbReturnCommand) Then pbReturnCommand = False + + RunCommand = True + +Const cstUnoPrefix = ".uno:" + If VarType(pvCommand) = vbString Then + sOOCommand = pvCommand + iVBACommand = -1 + If _IsLeft(sOOCommand, cstUnoPrefix) Then + Call _DispatchCommand(sOOCommand) + Goto Exit_Function + End If + Else + sOOCommand = "" + iVBACommand = pvCommand + End If + + Select Case True + Case iVBACommand = acCmdAboutMicrosoftAccess Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" + Case iVBACommand = acCmdAboutOpenOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" + Case iVBACommand = acCmdAboutLibreOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" + Case UCase(sOOCommand) = "ACTIVEHELP" : sDispatch = "ActiveHelp" + Case UCase(sOOCommand) = "ADDDIRECT" : sDispatch = "AddDirect" + Case UCase(sOOCommand) = "ADDFIELD" : sDispatch = "AddField" + Case UCase(sOOCommand) = "AUTOCONTROLFOCUS" : sDispatch = "AutoControlFocus" + Case UCase(sOOCommand) = "AUTOFILTER" : sDispatch = "AutoFilter" + Case UCase(sOOCommand) = "AUTOPILOTADDRESSDATASOURCE" : sDispatch = "AutoPilotAddressDataSource" + Case UCase(sOOCommand) = "BASICBREAK" : sDispatch = "BasicBreak" + Case iVBACommand = acCmdVisualBasicEditor Or UCase(sOOCommand) = "BASICIDEAPPEAR" : sDispatch = "BasicIDEAppear" + Case UCase(sOOCommand) = "BASICSTOP" : sDispatch = "BasicStop" + Case iVBACommand = acCmdBringToFront Or UCase(sOOCommand) = "BRINGTOFRONT" : sDispatch = "BringToFront" + Case UCase(sOOCommand) = "CHECKBOX" : sDispatch = "CheckBox" + Case UCase(sOOCommand) = "CHOOSEMACRO" : sDispatch = "ChooseMacro" + Case iVBACommand = acCmdClose Or UCase(sOOCommand) = "CLOSEDOC" : sDispatch = "CloseDoc" + Case UCase(sOOCommand) = "CLOSEWIN" : sDispatch = "CloseWin" + Case iVBACommand = acCmdToolbarsCustomize Or UCase(sOOCommand) = "CONFIGUREDIALOG" : sDispatch = "ConfigureDialog" + Case UCase(sOOCommand) = "CONTROLPROPERTIES" : sDispatch = "ControlProperties" + Case iVBACommand = acCmdChangeToCommandButton Or UCase(sOOCommand) = "CONVERTTOBUTTON" : sDispatch = "ConvertToButton" + Case iVBACommand = acCmdChangeToCheckBox Or UCase(sOOCommand) = "CONVERTTOCHECKBOX" : sDispatch = "ConvertToCheckBox" + Case iVBACommand = acCmdChangeToComboBox Or UCase(sOOCommand) = "CONVERTTOCOMBO" : sDispatch = "ConvertToCombo" + Case UCase(sOOCommand) = "CONVERTTOCURRENCY" : sDispatch = "ConvertToCurrency" + Case UCase(sOOCommand) = "CONVERTTODATE" : sDispatch = "ConvertToDate" + Case iVBACommand = acCmdChangeToTextBox Or UCase(sOOCommand) = "CONVERTTOEDIT" : sDispatch = "ConvertToEdit" + Case UCase(sOOCommand) = "CONVERTTOFILECONTROL" : sDispatch = "ConvertToFileControl" + Case iVBACommand = acCmdChangeToLabel Or UCase(sOOCommand) = "CONVERTTOFIXED" : sDispatch = "ConvertToFixed" + Case UCase(sOOCommand) = "CONVERTTOFORMATTED" : sDispatch = "ConvertToFormatted" + Case UCase(sOOCommand) = "CONVERTTOGROUP" : sDispatch = "ConvertToGroup" + Case UCase(sOOCommand) = "CONVERTTOIMAGEBTN" : sDispatch = "ConvertToImageBtn" + Case iVBACommand = acCmdChangeToImage Or UCase(sOOCommand) = "CONVERTTOIMAGECONTROL" : sDispatch = "ConvertToImageControl" + Case iVBACommand = acCmdChangeToListBox Or UCase(sOOCommand) = "CONVERTTOLIST" : sDispatch = "ConvertToList" + Case UCase(sOOCommand) = "CONVERTTONAVIGATIONBAR" : sDispatch = "ConvertToNavigationBar" + Case UCase(sOOCommand) = "CONVERTTONUMERIC" : sDispatch = "ConvertToNumeric" + Case UCase(sOOCommand) = "CONVERTTOPATTERN" : sDispatch = "ConvertToPattern" + Case iVBACommand = acCmdChangeToOptionButton Or UCase(sOOCommand) = "CONVERTTORADIO" : sDispatch = "ConvertToRadio" + Case UCase(sOOCommand) = "CONVERTTOSCROLLBAR" : sDispatch = "ConvertToScrollBar" + Case UCase(sOOCommand) = "CONVERTTOSPINBUTTON" : sDispatch = "ConvertToSpinButton" + Case UCase(sOOCommand) = "CONVERTTOTIME" : sDispatch = "ConvertToTime" + Case iVBACommand = acCmdCopy Or UCase(sOOCommand) = "COPY" : sDispatch = "Copy" + Case UCase(sOOCommand) = "CURRENCYFIELD" : sDispatch = "CurrencyField" + Case iVBACommand = acCmdCut Or UCase(sOOCommand) = "CUT" : sDispatch = "Cut" + Case UCase(sOOCommand) = "DATEFIELD" : sDispatch = "DateField" + Case iVBACommand = acCmdCreateRelationship Or UCase(sOOCommand) = "DBADDRELATION " : sDispatch = "DBAddRelation " + Case UCase(sOOCommand) = "DBCONVERTTOVIEW " : sDispatch = "DBConvertToView " + Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DBDELETE " : sDispatch = "DBDelete " + Case UCase(sOOCommand) = "DBDIRECTSQL " : sDispatch = "DBDirectSQL " + Case UCase(sOOCommand) = "DBDSADVANCEDSETTINGS " : sDispatch = "DBDSAdvancedSettings " + Case UCase(sOOCommand) = "DBDSCONNECTIONTYPE " : sDispatch = "DBDSConnectionType " + Case iVBACommand = acCmdDatabaseProperties Or UCase(sOOCommand) = "DBDSPROPERTIES " : sDispatch = "DBDSProperties " + Case UCase(sOOCommand) = "DBEDIT " : sDispatch = "DBEdit " + Case iVBACommand = acCmdSQLView Or UCase(sOOCommand) = "DBEDITSQLVIEW " : sDispatch = "DBEditSqlView " + Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBFORMDELETE " : sDispatch = "DBFormDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBFORMEDIT " : sDispatch = "DBFormEdit " + Case iVBACommand = acCmdFormView Or UCase(sOOCommand) = "DBFORMOPEN " : sDispatch = "DBFormOpen " + Case UCase(sOOCommand) = "DBFORMRENAME " : sDispatch = "DBFormRename " + Case iVBACommand = acCmdNewObjectForm Or UCase(sOOCommand) = "DBNEWFORM " : sDispatch = "DBNewForm " + Case UCase(sOOCommand) = "DBNEWFORMAUTOPILOT " : sDispatch = "DBNewFormAutoPilot " + Case UCase(sOOCommand) = "DBNEWQUERY " : sDispatch = "DBNewQuery " + Case UCase(sOOCommand) = "DBNEWQUERYAUTOPILOT " : sDispatch = "DBNewQueryAutoPilot " + Case UCase(sOOCommand) = "DBNEWQUERYSQL " : sDispatch = "DBNewQuerySql " + Case UCase(sOOCommand) = "DBNEWREPORT " : sDispatch = "DBNewReport " + Case UCase(sOOCommand) = "DBNEWREPORTAUTOPILOT " : sDispatch = "DBNewReportAutoPilot " + Case iVBACommand = acCmdNewObjectTable Or UCase(sOOCommand) = "DBNEWTABLE " : sDispatch = "DBNewTable " + Case UCase(sOOCommand) = "DBNEWTABLEAUTOPILOT " : sDispatch = "DBNewTableAutoPilot " + Case iVBACommand = acCmdNewObjectView Or UCase(sOOCommand) = "DBNEWVIEW " : sDispatch = "DBNewView " + Case UCase(sOOCommand) = "DBNEWVIEWSQL " : sDispatch = "DBNewViewSQL " + Case iVBACommand = acCmdOpenDatabase Or UCase(sOOCommand) = "DBOPEN " : sDispatch = "DBOpen " + Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBQUERYDELETE " : sDispatch = "DBQueryDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBQUERYEDIT " : sDispatch = "DBQueryEdit " + Case iVBACommand = acCmdNewObjectQuery Or UCase(sOOCommand) = "DBQUERYOPEN " : sDispatch = "DBQueryOpen " + Case UCase(sOOCommand) = "DBQUERYRENAME " : sDispatch = "DBQueryRename " + Case UCase(sOOCommand) = "DBREFRESHTABLES " : sDispatch = "DBRefreshTables " + Case iVBACommand = acCmdShowAllRelationships Or UCase(sOOCommand) = "DBRELATIONDESIGN " : sDispatch = "DBRelationDesign " + Case UCase(sOOCommand) = "DBRENAME " : sDispatch = "DBRename " + Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBREPORTDELETE " : sDispatch = "DBReportDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBREPORTEDIT " : sDispatch = "DBReportEdit " + Case iVBACommand = acCmdNewObjectReport Or UCase(sOOCommand) = "DBREPORTOPEN " : sDispatch = "DBReportOpen " + Case UCase(sOOCommand) = "DBREPORTRENAME " : sDispatch = "DBReportRename " + Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "DBSELECTALL " : sDispatch = "DBSelectAll " + Case UCase(sOOCommand) = "DBSHOWDOCINFOPREVIEW " : sDispatch = "DBShowDocInfoPreview " + Case UCase(sOOCommand) = "DBSHOWDOCPREVIEW " : sDispatch = "DBShowDocPreview " + Case iVBACommand = acCmdRemoveTable Or UCase(sOOCommand) = "DBTABLEDELETE " : sDispatch = "DBTableDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBTABLEEDIT " : sDispatch = "DBTableEdit " + Case UCase(sOOCommand) = "DBTABLEFILTER " : sDispatch = "DBTableFilter " + Case iVBACommand = acCmdOpenTable Or UCase(sOOCommand) = "DBTABLEOPEN " : sDispatch = "DBTableOpen " + Case iVBACommand = acCmdRename Or UCase(sOOCommand) = "DBTABLERENAME " : sDispatch = "DBTableRename " + Case UCase(sOOCommand) = "DBUSERADMIN " : sDispatch = "DBUserAdmin " + Case UCase(sOOCommand) = "DBVIEWFORMS " : sDispatch = "DBViewForms " + Case UCase(sOOCommand) = "DBVIEWQUERIES " : sDispatch = "DBViewQueries " + Case UCase(sOOCommand) = "DBVIEWREPORTS " : sDispatch = "DBViewReports " + Case UCase(sOOCommand) = "DBVIEWTABLES " : sDispatch = "DBViewTables " + Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DELETE" : sDispatch = "Delete" + Case iVBACommand = acCmdDeleteRecord Or UCase(sOOCommand) = "DELETERECORD" : sDispatch = "DeleteRecord" + Case UCase(sOOCommand) = "DESIGNERDIALOG" : sDispatch = "DesignerDialog" + Case UCase(sOOCommand) = "EDIT" : sDispatch = "Edit" + Case UCase(sOOCommand) = "FIRSTRECORD" : sDispatch = "FirstRecord" + Case UCase(sOOCommand) = "FONTDIALOG" : sDispatch = "FontDialog" + Case UCase(sOOCommand) = "FONTHEIGHT" : sDispatch = "FontHeight" + Case UCase(sOOCommand) = "FORMATTEDFIELD" : sDispatch = "FormattedField" + Case UCase(sOOCommand) = "FORMFILTER" : sDispatch = "FormFilter" + Case iVBACommand = acCmdApplyFilterSort Or UCase(sOOCommand) = "FORMFILTERED" : sDispatch = "FormFiltered" + Case UCase(sOOCommand) = "FORMFILTEREXECUTE" : sDispatch = "FormFilterExecute" + Case UCase(sOOCommand) = "FORMFILTEREXIT" : sDispatch = "FormFilterExit" + Case UCase(sOOCommand) = "FORMFILTERNAVIGATOR" : sDispatch = "FormFilterNavigator" + Case UCase(sOOCommand) = "FORMPROPERTIES" : sDispatch = "FormProperties" + Case UCase(sOOCommand) = "FULLSCREEN" : sDispatch = "FullScreen" + Case UCase(sOOCommand) = "GALLERY" : sDispatch = "Gallery" + Case UCase(sOOCommand) = "GRID" : sDispatch = "Grid" + Case iVBACommand = acCmdSnapToGrid Or UCase(sOOCommand) = "GRIDUSE" : sDispatch = "GridUse" + Case iVBACommand = acCmdViewGrid Or UCase(sOOCommand) = "GRIDVISIBLE" : sDispatch = "GridVisible" + Case UCase(sOOCommand) = "GROUPBOX" : sDispatch = "GroupBox" + Case UCase(sOOCommand) = "HELPINDEX" : sDispatch = "HelpIndex" + Case UCase(sOOCommand) = "HELPSUPPORT" : sDispatch = "HelpSupport" + Case iVBACommand = acCmdInsertHyperlink Or UCase(sOOCommand) = "HYPERLINKDIALOG" : sDispatch = "HyperlinkDialog" + Case UCase(sOOCommand) = "IMAGEBUTTON" : sDispatch = "Imagebutton" + Case UCase(sOOCommand) = "IMAGECONTROL" : sDispatch = "ImageControl" + Case UCase(sOOCommand) = "LABEL" : sDispatch = "Label" + Case iVBACommand = acCmdMaximumRecords Or UCase(sOOCommand) = "LASTRECORD" : sDispatch = "LastRecord" + Case UCase(sOOCommand) = "LISTBOX" : sDispatch = "ListBox" + Case UCase(sOOCommand) = "MACRODIALOG" : sDispatch = "MacroDialog" + Case UCase(sOOCommand) = "MACROORGANIZER" : sDispatch = "MacroOrganizer" + Case UCase(sOOCommand) = "NAVIGATIONBAR" : sDispatch = "NavigationBar" + Case iVBACommand = acCmdObjectBrowser Or UCase(sOOCommand) = "NAVIGATOR" : sDispatch = "Navigator" + Case UCase(sOOCommand) = "NEWDOC" : sDispatch = "NewDoc" + Case UCase(sOOCommand) = "NEWRECORD" : sDispatch = "NewRecord" + Case UCase(sOOCommand) = "NEXTRECORD" : sDispatch = "NextRecord" + Case UCase(sOOCommand) = "NUMERICFIELD" : sDispatch = "NumericField" + Case UCase(sOOCommand) = "OPEN" : sDispatch = "Open" + Case UCase(sOOCommand) = "OPTIONSTREEDIALOG" : sDispatch = "OptionsTreeDialog" + Case UCase(sOOCommand) = "ORGANIZER" : sDispatch = "Organizer" + Case UCase(sOOCommand) = "PARAGRAPHDIALOG" : sDispatch = "ParagraphDialog" + Case iVBACommand = acCmdPaste Or UCase(sOOCommand) = "PASTE" : sDispatch = "Paste" + Case iVBACommand = acCmdPasteSpecial Or UCase(sOOCommand) = "PASTESPECIAL " : sDispatch = "PasteSpecial " + Case UCase(sOOCommand) = "PATTERNFIELD" : sDispatch = "PatternField" + Case UCase(sOOCommand) = "PREVRECORD" : sDispatch = "PrevRecord" + Case iVBACommand = acCmdPrint Or UCase(sOOCommand) = "PRINT" : sDispatch = "Print" + Case UCase(sOOCommand) = "PRINTDEFAULT" : sDispatch = "PrintDefault" + Case UCase(sOOCommand) = "PRINTERSETUP" : sDispatch = "PrinterSetup" + Case iVBACommand = acCmdPrintPreview Or UCase(sOOCommand) = "PRINTPREVIEW" : sDispatch = "PrintPreview" + Case UCase(sOOCommand) = "PUSHBUTTON" : sDispatch = "Pushbutton" + Case UCase(sOOCommand) = "QUIT" : sDispatch = "Quit" + Case UCase(sOOCommand) = "RADIOBUTTON" : sDispatch = "RadioButton" + Case iVBACommand = acCmdSaveRecord Or UCase(sOOCommand) = "RECSAVE" : sDispatch = "RecSave" + Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "RECSEARCH" : sDispatch = "RecSearch" + Case iVBACommand = acCmdUndo Or UCase(sOOCommand) = "RECUNDO" : sDispatch = "RecUndo" + Case iVBACommand = acCmdRefresh Or UCase(sOOCommand) = "REFRESH" : sDispatch = "Refresh" + Case UCase(sOOCommand) = "RELOAD" : sDispatch = "Reload" + Case iVBACommand = acCmdRemoveFilterSort Or UCase(sOOCommand) = "REMOVEFILTERSORT" : sDispatch = "RemoveFilterSort" + Case iVBACommand = acCmdRunMacro Or UCase(sOOCommand) = "RUNMACRO" : sDispatch = "RunMacro" + Case iVBACommand = acCmdSave Or UCase(sOOCommand) = "SAVE" : sDispatch = "Save" + Case UCase(sOOCommand) = "SAVEALL" : sDispatch = "SaveAll" + Case iVBACommand = acCmdSaveAs Or UCase(sOOCommand) = "SAVEAS" : sDispatch = "SaveAs" + Case UCase(sOOCommand) = "SAVEBASICAS" : sDispatch = "SaveBasicAs" + Case UCase(sOOCommand) = "SCRIPTORGANIZER" : sDispatch = "ScriptOrganizer" + Case UCase(sOOCommand) = "SCROLLBAR" : sDispatch = "ScrollBar" + Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "SEARCHDIALOG" : sDispatch = "SearchDialog" + Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll" + Case iVBACommand = acCmdSelectAllRecords Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll" + Case iVBACommand = acCmdSendToBack Or UCase(sOOCommand) = "SENDTOBACK" : sDispatch = "SendToBack" + Case UCase(sOOCommand) = "SHOWFMEXPLORER" : sDispatch = "ShowFmExplorer" + Case UCase(sOOCommand) = "SIDEBAR" : sDispatch = "Sidebar" + Case iVBACommand = acCmdSortDescending Or UCase(sOOCommand) = "SORTDOWN" : sDispatch = "SortDown" + Case iVBACommand = acCmdSortAscending Or UCase(sOOCommand) = "SORTUP" : sDispatch = "Sortup" + Case UCase(sOOCommand) = "SPINBUTTON" : sDispatch = "SpinButton" + Case UCase(sOOCommand) = "STATUSBARVISIBLE" : sDispatch = "StatusBarVisible" + Case UCase(sOOCommand) = "SWITCHCONTROLDESIGNMODE" : sDispatch = "SwitchControlDesignMode" + Case iVBACommand = acCmdTabOrder Or UCase(sOOCommand) = "TABDIALOG" : sDispatch = "TabDialog" + Case UCase(sOOCommand) = "USEWIZARDS" : sDispatch = "UseWizards" + Case UCase(sOOCommand) = "VERSIONDIALOG" : sDispatch = "VersionDialog" + Case UCase(sOOCommand) = "VIEWDATASOURCEBROWSER" : sDispatch = "ViewDataSourceBrowser" + Case iVBACommand = acCmdDatasheetView Or UCase(sOOCommand) = "VIEWFORMASGRID" : sDispatch = "ViewFormAsGrid" + Case iVBACommand = acCmdZoomSelection Or UCase(sOOCommand) = "ZOOM" : sDispatch = "Zoom" + Case Else + If iVBACommand >= 0 Then Goto Exit_Function + sDispatch = pvCommand + End Select + + If pbReturnCommand Then RunCommand = cstUnoPrefix & sDispatch Else Call _DispatchCommand(cstUnoPrefix & sDispatch) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' RunCommand V0.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RunSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain an ACTION query + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("RunSQL") + + RunSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + + RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption) + +Exit_Function: + Utils._ResetCalledSub("RunSQL") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "RunSQL", Erl) + GoTo Exit_Function +End Function ' RunSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SelectObject( ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvInDatabaseWindow As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SelectObject" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + If Not IsMissing(pvInDatabaseWindow) Then + If Not Utils._CheckArgument(pvInDatabaseWindow, 3, vbBoolean, False) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + With oWindow.Frame.ContainerWindow + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .setEnable(True) ' Added to try to bypass desynchro issue in Linux + .toFront() ' Added to force window change in Linux + End With + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SelectObject V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SendObject(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvOutputFormat As Variant _ + , ByVal Optional pvTo As Variant _ + , ByVal Optional pvCc As Variant _ + , ByVal Optional pvBcc As Variant _ + , ByVal Optional pvSubject As Variant _ + , ByVal Optional pvMessageText As Variant _ + , ByVal Optional pvEditMessage As Variant _ + , ByVal Optional pvTemplateFile As Variant _ + ) As Boolean +'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms +'To be prepared: acFormatCSV and acFormatODS for tables/queries ? + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("SendObject") + SendObject = False + + If IsMissing(pvObjectType) Then pvObjectType = acSendNoObject + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acSendNoObject, acSendForm)) Then Goto Exit_Function + If IsMissing(pvObjectName) Then pvObjectName = "" + If Not Utils._CheckArgument(pvObjectName, 2,vbString) Then Goto Exit_Function + If IsMissing(pvOutputFormat) Then pvOutputFormat = "" + If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function + If pvOutputFormat <> "" Then + If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ + UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _ + , "PDF", "ODT", "DOC", "HTML", "" _ + )) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity + End If + If IsMissing(pvTo) Then pvTo = "" + If Not Utils._CheckArgument(pvTo, 4, vbString) Then Goto Exit_Function + If IsMissing(pvCc) Then pvCc = "" + If Not Utils._CheckArgument(pvCc, 5, vbString) Then Goto Exit_Function + If IsMissing(pvBcc) Then pvBcc = "" + If Not Utils._CheckArgument(pvBcc, 6, vbString) Then Goto Exit_Function + If IsMissing(pvSubject) Then pvSubject = "" + If Not Utils._CheckArgument(pvSubject, 7, vbString) Then Goto Exit_Function + If IsMissing(pvMessageText) Then pvMessageText = "" + If Not Utils._CheckArgument(pvMessageText, 8, vbString) Then Goto Exit_Function + If IsMissing(pvEditMessage) Then pvEditMessage = True + If Not Utils._CheckArgument(pvEditMessage, 9, vbBoolean) Then Goto Exit_Function + If IsMissing(pvTemplateFile) Then pvTemplateFile = "" + If Not Utils._CheckArgument(pvTemplateFile,10, vbString, "") Then Goto Exit_Function + +Dim vTo() As Variant, vCc() As Variant, vBcc() As Variant, oWindow As Object +Dim sDirectory As String, sOutputFile As String, sSuffix As String, sOutputFormat As String +Const cstSemiColon = ";" + If pvTo <> "" Then vTo() = Split(pvTo, cstSemiColon) Else vTo() = Array() + If pvCc <> "" Then vCc() = Split(pvCc, cstSemiColon) Else vCc() = Array() + If pvBcc <> "" Then vBcc() = Split(pvBcc, cstSemiColon) Else vBcc() = Array() + Select Case True + Case pvObjectType = acSendNoObject And pvObjectName = "" + SendObject = _SendWithoutAttachment(vTo, vCc, vBcc, pvSubject, pvMessageText) + Case Else + If pvObjectType = acSendNoObject And pvObjectName <> "" Then + If Not FileExists(pvObjectName) Then Goto Error_File + sOutputFile = pvObjectName + Else ' OutputFile has to be created + If pvObjectType <> acSendNoObject And pvObjectName = "" Then + oWindow = _SelectWindow() + If oWindow.WindowType <> acSendForm Then Goto Error_Action + pvObjectType = acSendForm + pvObjectName = oWindow._Name + End If + sDirectory = Utils._getTempDirectoryURL() + If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/" + If pvOutputFormat = "" Then + sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format + If sOutputFormat = "" Then Goto Exit_Function + Else + sOutputFormat = UCase(pvOutputFormat) + End If + Select Case sOutputFormat + Case UCase(acFormatPDF), "PDF" : sSuffix = "pdf" + Case UCase(acFormatDOC), "DOC" : sSuffix = "doc" + Case UCase(acFormatODT), "ODT" : sSuffix = "odt" + Case UCase(acFormatHTML), "HTML" : sSuffix = "html" + End Select + sOutputFile = sDirectory & pvObjectName & "." & sSuffix + If Not OutputTo(pvObjectType, pvObjectName, sOutputFormat, sOutputFile, False) Then Goto Exit_Function + End If + SendObject = _SendWithAttachment(vTo, vCc, vBcc, pvSubject, Array(sOutputFile), pvMessageText, pvEditMessage) + End Select + +Exit_Function: + Utils._ResetCalledSub("SendObject") + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SendObject", Erl) + GoTo Exit_Function +Error_Action: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) + Goto Exit_Function +Error_File: + TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , pvObjectName) + Goto Exit_Function +End Function ' SendObject V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvHidden As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + SetHiddenAttribute = False +Const cstThisSub = "SetHiddenAttribute" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + If IsMissing(pvHidden) Then + pvHidden = True + Else + If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + oWindow.Frame.ContainerWindow.setVisible(Not pvHidden) + SetHiddenAttribute = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SetHiddenAttribute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetOrderBy( _ + ByVal Optional pvOrder As Variant _ + , ByVal Optional pvControlName As Variant _ + ) As Boolean +' Sort ann open table, query, form or subform (if pvControlName present) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SetOrderBy" + Utils._SetCalledSub(cstThisSub) + SetOrderBy = False + + If IsMissing(pvOrder) Then pvOrder = "" + If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function + If IsMissing(pvControlName) Then pvControlName = "" + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + +Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + sOrder = oDatabase._ReplaceSquareBrackets(pvOrder) + + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oTarget = _DatabaseForm(._Name, pvControlName) + Case acQuery, acTable + If pvControlName <> "" Then Goto Exit_Function + If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oTarget = .Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + + With oTarget + .Order = sOrder + .reload() + End With + SetOrderBy = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SetOrderBy V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ShowAllrecords() As Boolean +' Removes any existing filter that exists on the current table, query or form + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "ShowAllRecords" + Utils._SetCalledSub(cstThisSub) + ShowAllRecords = False + +Dim oWindow As Object, oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + Set oWindow = _SelectWindow() + Select Case oWindow.WindowType + Case acForm, acQuery, acTable + RunCommand(acCmdRemoveFilterSort) + ShowAllrecords = True + Case Else ' Ignore action + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' ShowAllrecords V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _CheckColumnType(pvFindWhat As Variant, vDataField As Variant) As Boolean +' Return true if both arguments of the same type +' vDataField is a ResultSet column + +Dim bFound As Boolean + bFound = False + With com.sun.star.sdbc.DataType + Select Case vDataField.Type + Case .DATE, .TIME, .TIMESTAMP + If VarType(pvFindWhat) = vbDate Then bFound = True + Case .TINYINT, .SMALLINT, .INTEGER, .BIGINT, .FLOAT, .REAL, .DOUBLE, .NUMERIC, .DECIMAL + If Utils._InList(VarType(pvFindWhat), Utils._AddNumeric()) Then bFound = True + Case .CHAR, .VARCHAR, .LONGVARCHAR + If VarType(pvFindWhat) = vbString Then bFound = True + Case Else + End Select + End With + + _CheckColumnType = bFound + +End Function ' _CheckColumnType V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Sub _ConvertDataDescriptor( ByRef poSource As Object _ + , ByVal piSourceRDBMS As Integer _ + , ByRef poTarget As Object _ + , ByRef poDatabase As Object _ + , ByVal Optional pbKey As Boolean _ + ) +' Convert source column descriptor to target descriptor +' If RDMSs identical, simply move property by property +' Otherwise +' - Use Type conversion tables (cfr. DataTypes By RDBMS.ods case study) +' - Select among synonyms the entry with the lowest Precision at least >= source Precision +' - Derive TypeName and Precision values + +Dim vTypesReference() As Variant, vTypes() As Variant, vTypeNames() As Variant +Dim i As Integer, iType As Integer, iTypeAlias As Integer +Dim iNbTypes As Integer, iBestFit As Integer, lFitPrecision As Long, lPrecision As Long + + On Local Error Goto Error_Sub + If IsMissing(pbKey) Then pbKey = False + + poTarget.Name = poSource.Name + poTarget.Description = poSource.Description + If Not pbKey Then + poTarget.ControlDefault = poSource.ControlDefault + poTarget.FormatKey = poSource.FormatKey + poTarget.HelpText = poSource.HelpText + poTarget.Hidden = poSource.Hidden + End If + poTarget.IsCurrency = poSource.IsCurrency + poTarget.IsNullable = poSource.IsNullable + poTarget.Scale = poSource.Scale + + If piSourceRDBMS = poDatabase._RDBMS Or poDatabase._RDBMS = DBMS_UNKNOWN Then + poTarget.Type = poSource.Type + poTarget.Precision = poSource.Precision + poTarget.TypeName = poSource.TypeName + Goto Exit_Sub + End If + + ' Search DataType compatibility + With poDatabase + ' Find source datatype entry in Reference array + iType = -1 + For i = 0 To UBound(._ColumnTypesReference) + If ._ColumnTypesReference(i) = poSource.Type Then + iType = i + Exit For + End If + Next i + If iType = -1 Then Goto Error_Compatibility + iTypeAlias = ._ColumnTypesAlias(iType) + ' Find best choice for the datatype of the target column + iNbTypes = UBound(._ColumnTypes) + iBestFit = -1 + lFitPrecision = -2 ' Some POSTGRES datatypes have a precision of -1 + For i = 0 To iNbTypes + If ._ColumnTypes(i) = iTypeAlias Then ' Minimal fit = correct datatype + lPrecision = ._ColumnPrecisions(i) + If iBestFit = -1 _ + Or (iBestFit > -1 And poSource.Precision > 0 And lPrecision >= poSource.Precision And lPrecision < lFitPrecision) _ + Or (iBestFit > -1 And poSource.Precision = 0 And lPrecision > lFitPrecision) Then ' First fit or better fit + iBestFit = i + lFitPrecision = lPrecision + End If + End If + Next i + If iBestFit = -1 Then Goto Error_Compatibility + poTarget.Type = iTypeAlias + poTarget.Precision = lFitPrecision + poTarget.TypeName = ._ColumnTypeNames(iBestFit) + End With + +Exit_Sub: + Exit Sub +Error_Compatibility: + TraceError(TRACEFATAL, ERRCOMPATIBILITY, Utils._CalledSub(), 0, 1, poSource.Name) + Goto Exit_Sub +Error_Sub: + TraceError(TRACEABORT, Err, "_ConvertDataDescriptor", Erl) + Goto Exit_Sub +End Sub ' ConvertDataDescriptor V1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DatabaseForm(psForm As String, psControl As String) +'Return DatabaseForm element of Form object (based on psForm which is known as a real form name) +'or of SubForm object (based on psControl which is checked for being a subform) + +Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer +Dim bFound As Boolean, i As Integer, sName As String + + Set oForm = Application.Forms(psForm) + If psControl <> "" Then ' Search subform + With oForm.DatabaseForm + iControlCount = .getCount() + bFound = False + If iControlCount > 0 Then + sControls() = .getElementNames() + sName = UCase(Utils._Trim(psControl)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sName Then + bFound = True + Exit For + End If + Next i + End If + End With + If bFound Then sName = sControls(i) Else Goto Trace_NotFound + Set oControl = oForm.Controls(sName) + If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound + Set _DatabaseForm = oControl.Form.DatabaseForm + Else + Set _DatabaseForm = oForm.DatabaseForm + End If + +Exit_Function: + Exit Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) + Goto Exit_Function +Trace_SubFormNotFound: + TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) + Goto Exit_Function +End Function ' _DatabaseForm V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _DispatchCommand(ByVal psCommand As String) +' Execute command given as argument - ".uno:" is presumed already present +Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String +Dim oResult As Variant +Dim sCommand As String + + Set oDocument = _SelectWindow().Frame + Set oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper") + sTargetFrameName = "" + oResult = oDispatcher.executeDispatch(oDocument, psCommand, sTargetFrameName, 0, oArgs()) + +End Sub ' _DispatchCommand V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal psLastComponent As String) As String +' Return "Forms!myForm" from "Forms!myForm!datField" and "datField" + + If Len(psShortcut) > Len(psLastComponent) Then + _getUpperShortcut = Split(psShortcut, "!" & Utils._Surround(psLastComponent))(0) + Else + _getUpperShortcut = psShortcut + End If + +End Function ' _getUpperShortcut + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OpenObject(ByVal psObjectType As String _ + , ByVal pvObjectName As Variant _ + , ByVal pvView As Variant _ + , ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + _OpenObject = False + If Not (Utils._CheckArgument(pvObjectName, 1, vbString) _ + And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _ + And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _ + ) Then Goto Exit_Function +Dim oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + +Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object +Dim i As Integer, bFound As Boolean, lComponent As Long, oQuery As Object + + ' Check existence of object and find its exact (case-sensitive) name + Select Case psObjectType + Case "Table" + sObjects = oDatabase.Connection.getTables.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE + Case "Query" + sObjects = oDatabase.Connection.getQueries.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY + Case "Report" + sObjects = oDatabase.Document.getReportDocuments.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT + End Select + bFound = False + For i = 0 To UBound(sObjects) + If UCase(pvObjectName) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + + If psObjectType = "Query" Then ' Processing for action query + Set oQuery = Application._CurrentDb().QueryDefs(pvObjectName) + If oQuery.pType <> dbQSelect Then + _OpenObject = oQuery.Execute() + GoTo Exit_Function + End If + End If + Set oController = oDatabase.Document.CurrentController + Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign )) + _OpenObject = True + +Exit_Function: + Set oObject = Nothing + Set oQuery = Nothing + Set oController = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenObject", Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) + Goto Exit_Function +End Function ' _OpenObject V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PromptFormat(ByVal pvList As Variant) As String +' Return user selection in Format dialog + +Dim oDialog As Object, iOKCancel As Integer, oControl As Object + + Set oDialog = CreateUnoDialog(Utils._GetDialogLib().dlgFormat) + oDialog.Title = _GetLabel("DLGFORMAT_TITLE") + + Set oControl = oDialog.Model.getByName("lblFormat") + oControl.Label = _GetLabel("DLGFORMAT_LBLFORMAT_LABEL") + oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP") + + Set oControl = oDialog.Model.getByName("cboFormat") + oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP") + + Set oControl = oDialog.Model.getByName("cmdOK") + oControl.Label = _GetLabel("DLGFORMAT_CMDOK_LABEL") + oControl.HelpText = _GetLabel("DLGFORMAT_CMDOK_HELP") + + Set oControl = oDialog.Model.getByName("cmdCancel") + oControl.Label = _GetLabel("DLGFORMAT_CMDCANCEL_LABEL") + oControl.HelpText = _GetLabel("DLGFORMAT_CMDCANCEL_HELP") + + Set oControl = oDialog.Model.getByName("cboFormat") + If UBound(pvList) >= 0 Then + oControl.Text = pvList(0) + oControl.StringItemList = pvList + Else + oControl.Text = "" + oControl.StringItemList = Array() + End If + + iOKCancel = oDialog.Execute() + Select Case iOKCancel + Case 1 ' OK + _PromptFormat = oControl.Text + Case 0 ' Cancel + _PromptFormat = "" + Case Else + End Select + oDialog.Dispose() + +End Function ' _PromptFormat V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional ByVal psWindow As String) As Object +' No argument: find active window +' 2 arguments: find corresponding window +' Return a _Window object type describing the found window + +Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer +Dim bFound As Boolean, bActive As Boolean, sName As String, iType As Integer, sDocumentType As String +Dim sImplementation As String, vLocation() As Variant +Dim oWindow As _Window +Dim vPersistent As Variant, oForm As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + + bActive = IsMissing(piWindowType) + If IsMissing(psWindow) Then psWindow = "" + Set oWindow.Frame = Nothing + oWindow.DocumentType = "" + If bActive Then + oWindow.WindowType = acDefault + oWindow._Name = "" + Else + oWindow.WindowType = piWindowType + Select Case piWindowType + Case acBasicIDE, acDatabaseWindow : oWindow._Name = "" + Case Else : oWindow._Name = psWindow + End Select + End If + iType = acDefault + sDocumentType = "" + + Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") + Set oEnum = oDesk.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = "" + Select Case sImplementation + Case "com.sun.star.comp.basic.BasicIDE" + Set oFrame = oComp.CurrentController.Frame + iType = acBasicIDE + sName = "" + Case "com.sun.star.comp.dba.ODatabaseDocument" + Set oFrame = oComp.CurrentController.Frame + iType = acDatabaseWindow + sName = "" + Case "SwXTextDocument" + If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then + Select Case oComp.Identifier + Case "com.sun.star.sdb.FormDesign" ' Form + iType = acForm + Case "com.sun.star.sdb.TextReportDesign" ' Report + iType = acReport + Case "com.sun.star.text.TextDocument" ' Writer + vLocation = Split(oComp.getLocation(), "/") + If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = "" + iType = acDocument + sDocumentType = docWriter + End Select + If iType = acForm Then ' Identify persistent Form name + vPersistent = Split(oComp.StringValue, "/") + sName = _GetHierarchicalName(vPersistent(UBound(vPersistent) - 1)) + ElseIf iType = acReport Then ' Identify Report name + For i = 0 To UBound(oComp.Args()) + If oComp.Args(i).Name = "DocumentTitle" Then + sName = oComp.Args(i).Value + Exit For + End If + Next i + End If + Set oFrame = oComp.CurrentController.Frame + End If + Case "org.openoffice.comp.dbu.ODatasourceBrowser" + Set oFrame = oComp.Frame + If Not IsEmpty(oComp.Selection) Then ' Empty for (F4) DatasourceBrowser !! + For i = 0 To UBound(oComp.Selection()) + If oComp.Selection(i).Name = "Command" Then + sName = oComp.Selection(i).Value + ElseIf oComp.Selection(i).Name = "CommandType" Then + Select Case oComp.selection(i).Value + Case com.sun.star.sdb.CommandType.TABLE + iType = acTable + Case com.sun.star.sdb.CommandType.QUERY + iType = acQuery + Case com.sun.star.sdb.CommandType.COMMAND + iType = acQuery ' SQL for future use ? + End Select + End If + Next i + ' Else ignore + End If + Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode + If Not bActive Then + If UCase(Right(oComp.Title, Len(psWindow))) = UCase(psWindow) Then ' No rigorous mean found to identify Name + Set oFrame = oComp.Frame + Select Case sImplementation + Case "org.openoffice.comp.dbu.OTableDesign" : iType = acTable + Case "org.openoffice.comp.dbu.OQueryDesign" : iType = acQuery + End Select + sName = Right(oComp.Title, Len(psWindow)) + End If + Else + Set oFrame = Nothing + End If + Case "org.openoffice.comp.dbu.ORelationDesign" + Set oFrame = oComp.Frame + iType = acDiagram + sName = "" + Case "com.sun.star.comp.sfx2.BackingComp" ' Welcome screen + Set oFrame = oComp.Frame + iType = acWelcome + sName = "" + Case Else ' Other Calc, ..., whatever documents + If Utils._hasUNOProperty(oComp, "Location") Then + vLocation = Split(oComp.getLocation(), "/") + If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = "" + iType = acDocument + If Utils._hasUNOProperty(oComp, "Identifier") Then + Select Case oComp.Identifier + Case "com.sun.star.sheet.SpreadsheetDocument" : sDocumentType = docCalc + Case "com.sun.star.presentation.PresentationDocument" : sDocumentType = docImpress + Case "com.sun.star.drawing.DrawingDocument" : sDocumentType = docDraw + Case "com.sun.star.formula.FormulaProperties" : sDocumentType = docMath + Case Else : sDocumentType = "" + End Select + End If + Set oFrame = oComp.CurrentController.Frame + End If + End Select + If bActive And Not IsNull(oFrame) Then + If oFrame.ContainerWindow.IsActive() Then + bFound = True + Exit Do + End If + ElseIf iType = piWindowType And UCase(sName) = UCase(psWindow) Then + bFound = True + Exit Do + End If + Loop + + If bFound Then + Set oWindow.Frame = oFrame + oWindow._Name = sName + oWindow.WindowType = iType + oWindow.DocumentType = sDocumentType + Else + Set oWindow.Frame = Nothing + End If + +Exit_Function: + Set _SelectWindow = oWindow + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SelectWindow", Erl) + GoTo Exit_Function +End Function ' _SelectWindow V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _SendWithAttachment( _ + ByVal pvRecipients() As Variant _ + , ByVal pvCcRecipients() As Variant _ + , ByVal pvBccRecipients() As Variant _ + , ByVal psSubject As String _ + , ByVal pvAttachments() As Variant _ + , ByVal pvBody As String _ + , ByVal pbEditMessage As Boolean _ + ) As Boolean + +' Send message with attachments + If _ErrorHandler() Then On Local Error Goto Error_Function + _SendWithAttachment = False + +Const cstWindows = 1 +Const cstLinux = 4 +Const cstSemiColon = ";" +Dim oServiceMail as Object, oMail As Object, oMessage As Object, vFlag As Variant +Dim vCc() As Variant, i As Integer, iOS As Integer, sProduct As String, bMailProvider As Boolean + + 'OPENOFFICE <= 3.6 and LIBREOFFICE have XSimple...Mail interface while OPENOFFICE >= 4.0 has XSystemMailProvider interface + sProduct = UCase(Utils._GetProductName()) + bMailProvider = ( Left(sProduct, 4) = "OPEN" And Left(_GetProductName("VERSION"), 3) >= "4.0" ) + + iOS = GetGuiType() + Select Case iOS + Case cstLinux + oServiceMail = createUnoService("com.sun.star.system.SimpleCommandMail") + Case cstWindows + If bMailProvider Then oServiceMail = createUnoService("com.sun.star.system.SystemMailProvider") _ + Else oServiceMail = createUnoService("com.sun.star.system.SimpleSystemMail") + Case Else + Goto Error_Mail + End Select + + If bMailProvider Then Set oMail = oServiceMail.queryMailClient() _ + Else Set oMail = oServiceMail.querySimpleMailClient() + If IsNull(oMail) Then Goto Error_Mail + + 'Reattribute Recipients >= 2nd to ccRecipients + If UBound(pvRecipients) <= 0 Then + If UBound(pvCcRecipients) >= 0 Then vCc = pvCcRecipients + Else + ReDim vCc(0 To UBound(pvRecipients) - 1 + UBound(pvCcRecipients) + 1) + For i = 0 To UBound(pvRecipients) - 1 + vCc(i) = pvRecipients(i + 1) + Next i + For i = UBound(pvRecipients) To UBound(vCc) + vCc(i) = pvCcRecipients(i - UBound(pvRecipients)) + Next i + End If + + If bMailProvider Then + Set oMessage = oMail.createMailMessage() + If UBound(pvRecipients) >= 0 Then oMessage.Recipient = pvRecipients(0) + If psSubject <> "" Then oMessage.Subject = psSubject + Select Case iOS ' Not published differences between com.sun.star.system.SimpleCommandMail and SimpleSystemMail + Case cstLinux + If UBound(vCc) >= 0 Then oMessage.CcRecipient = Array(Join(vCc, cstSemiColon)) + If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = Array(Join(pvBccRecipients, cstSemiColon)) + Case cstWindows + If UBound(vCc) >= 0 Then oMessage.CcRecipient = vCc + If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = pvBccRecipients + End Select + If UBound(pvAttachments) >= 0 Then oMessage.Attachement = pvAttachments + If pvBody <> "" Then oMessage.Body = pvBody + If pbEditMessage Then + vFlag = com.sun.star.system.MailClientFlags.DEFAULTS + Else + vFlag = com.sun.star.system.MailClientFlags.NO_USER_INTERFACE + End If + oMail.sendMailMessage(oMessage, vFlag) + Else + Set oMessage = oMail.createSimpleMailMessage() ' Body NOT SUPPORTED ! + If UBound(pvRecipients) >= 0 Then oMessage.setRecipient(pvRecipients(0)) + If psSubject <> "" Then oMessage.setSubject(psSubject) + Select Case iOS + Case cstLinux + If UBound(vCc) >= 0 Then oMessage.setCcRecipient(Array(Join(vCc, cstSemiColon))) + If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(Array(Join(pvBccRecipients, cstSemiColon))) + Case cstWindows + If UBound(vCc) >= 0 Then oMessage.setCcRecipient(vCc) + If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(pvBccRecipients) + End Select + If UBound(pvAttachments) >= 0 Then oMessage.setAttachement(pvAttachments) + If pbEditMessage Then + vFlag = com.sun.star.system.SimpleMailClientFlags.DEFAULTS + Else + vFlag = com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE + End If + oMail.sendSimpleMailMessage(oMessage, vFlag) + End If + + _SendWithAttachment = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "_SendWithAttachment", Erl) + Goto Exit_Function +Error_Mail: + TraceError(TRACEFATAL, ERRSENDMAIL, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' _SendWithAttachment V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _SendWithoutAttachment(ByVal pvTo As Variant _ + , ByVal pvCc As Variant _ + , ByVal pvBcc As Variant _ + , ByVal psSubject As String _ + , ByVal psBody As String _ + ) As Boolean +'Send simple message with mailto: syntax +Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object +Const cstComma = "," + + If _ErrorHandler() Then On Local Error Goto Error_Function + + If UBound(pvTo) >= 0 Then sTo = Trim(Join(pvTo, cstComma)) Else sTo = "" + If UBound(pvCc) >= 0 Then sCc = Trim(Join(pvCc, cstComma)) Else sCc = "" + If UBound(pvBcc) >= 0 Then sBcc = Trim(Join(pvBcc, cstComma)) Else sBcc = "" + + sMailTo = "mailto:" _ + & sTo & "?" _ + & Iif(sCc = "", "", "cc=" & sCc & "&") _ + & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _ + & Iif(psSubject = "", "", "subject=" & psSubject & "&") _ + & Iif(psBody = "", "", "body=" & psBody & "&") + If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1) + sMailTo = ConvertToUrl(sMailTo) + + oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper") + oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array()) + + _SendWithoutAttachment = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "_SendWithoutAttachments", Erl) + _SendWithoutAttachment = False + Goto Exit_Function +End Function ' _SendWithoutAttachment V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _ShellExecute(sCommand As String) +' Execute shell command + +Dim oShell As Object + Set oShell = createUnoService("com.sun.star.system.SystemShellExecute") + oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.DEFAULTS) + +End Sub ' _ShellExecute V0.8.5 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Event.xba b/wizards/source/access2base/Event.xba new file mode 100644 index 000000000..eb5f23019 --- /dev/null +++ b/wizards/source/access2base/Event.xba @@ -0,0 +1,493 @@ +<?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="Event" 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 EVENT +Private _EventSource As Object +Private _EventType As String +Private _EventName As String +Private _SubComponentName As String +Private _SubComponentType As Long +Private _ContextShortcut As String +Private _ButtonLeft As Boolean ' com.sun.star.awt.MouseButton.XXX +Private _ButtonRight As Boolean +Private _ButtonMiddle As Boolean +Private _XPos As Variant ' Null or Long +Private _YPos As Variant ' Null or Long +Private _ClickCount As Long +Private _KeyCode As Integer ' com.sun.star.awt.Key.XXX +Private _KeyChar As String +Private _KeyFunction As Integer ' com.sun.star.awt.KeyFunction.XXX +Private _KeyAlt As Boolean +Private _KeyCtrl As Boolean +Private _KeyShift As Boolean +Private _FocusChangeTemporary As Boolean ' False if user action in same window +Private _RowChangeAction As Long ' com.sun.star.sdb.RowChangeAction.XXX +Private _Recommendation As String ' "IGNORE" or "" + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJEVENT + _EventSource = Nothing + _EventType = "" + _EventName = "" + _SubComponentName = "" + _SubComponentType = -1 + _ContextShortcut = "" + _ButtonLeft = False ' See com.sun.star.awt.MouseButton.XXX + _ButtonRight = False + _ButtonMiddle = False + _XPos = Null + _YPos = Null + _ClickCount = 0 + _KeyCode = 0 + _KeyChar = "" + _KeyFunction = com.sun.star.awt.KeyFunction.DONTKNOW + _KeyAlt = False + _KeyCtrl = False + _KeyShift = False + _FocusChangeTemporary = False + _RowChangeAction = 0 + _Recommendation = "" +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 ----------------------------------------------------------------------------------------------------------------------- +Property Get ButtonLeft() As Variant + ButtonLeft = _PropertyGet("ButtonLeft") +End Property ' ButtonLeft (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ButtonMiddle() As Variant + ButtonMiddle = _PropertyGet("ButtonMiddle") +End Property ' ButtonMiddle (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ButtonRight() As Variant + ButtonRight = _PropertyGet("ButtonRight") +End Property ' ButtonRight (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ClickCount() As Variant + ClickCount = _PropertyGet("ClickCount") +End Property ' ClickCount (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ContextShortcut() As Variant + ContextShortcut = _PropertyGet("ContextShortcut") +End Property ' ContextShortcut (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EventName() As Variant + EventName = _PropertyGet("EventName") +End Property ' EventName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EventSource() As Variant + EventSource = _PropertyGet("EventSource") +End Property ' EventSource (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EventType() As Variant + EventType = _PropertyGet("EventType") +End Property ' EventType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FocusChangeTemporary() As Variant + FocusChangeTemporary = _PropertyGet("FocusChangeTemporary") +End Property ' FocusChangeTemporary (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyAlt() As Variant + KeyAlt = _PropertyGet("KeyAlt") +End Property ' KeyAlt (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyChar() As Variant + KeyChar = _PropertyGet("KeyChar") +End Property ' KeyChar (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyCode() As Variant + KeyCode = _PropertyGet("KeyCode") +End Property ' KeyCode (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyCtrl() As Variant + KeyCtrl = _PropertyGet("KeyCtrl") +End Property ' KeyCtrl (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyFunction() As Variant + KeyFunction = _PropertyGet("KeyFunction") +End Property ' KeyFunction (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyShift() As Variant + KeyShift = _PropertyGet("KeyShift") +End Property ' KeyShift (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Recommendation() As Variant + Recommendation = _PropertyGet("Recommendation") +End Property ' Recommendation (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RowChangeAction() As Variant + RowChangeAction = _PropertyGet("RowChangeAction") +End Property ' RowChangeAction (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Source() As Variant +' Return the object having fired the event: Form, Control or SubForm +' Else return the root Database object + Source = _PropertyGet("Source") +End Function ' Source (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SubComponentName() As String + SubComponentName = _PropertyGet("SubComponentName") +End Property ' SubComponentName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SubComponentType() As Long + SubComponentType = _PropertyGet("SubComponentType") +End Property ' SubComponentType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get XPos() As Variant + XPos = _PropertyGet("XPos") +End Property ' XPos (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get YPos() As Variant + YPos = _PropertyGet("YPos") +End Property ' YPos (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Form.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Form.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize(poEvent As Object) + +Dim oObject As Object, i As Integer +Dim sShortcut As String, sAddShortcut As String, sArray() As String +Dim sImplementation As String, oSelection As Object +Dim iCurrentDoc As Integer, oDoc As Object +Dim vPersistent As Variant +Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set oObject = poEvent.Source + _EventSource = oObject + sArray = Split(Utils._getUNOTypeName(poEvent), ".") + _EventType = UCase(sArray(UBound(sArray))) + If Utils._hasUNOProperty(poEvent, "EventName") Then _EventName = poEvent.EventName + + Select Case _EventType + Case "DOCUMENTEVENT" + 'SubComponent processing + Select Case UCase(_EventName) + Case UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") + Set oSelection = poEvent.ViewController.getSelection()(0) + _SubComponentName = oSelection.Name + With com.sun.star.sdb.application.DatabaseObject + Select Case oSelection.Type + Case .TABLE : _SubComponentType = acTable + Case .QUERY : _SubComponentType = acQuery + Case .FORM : _SubComponentType = acForm + Case .REPORT : _SubComponentType = acReport + Case Else + End Select + End With + Case Else + End Select + Case "EVENTOBJECT" + Case "ACTIONEVENT" + Case "FOCUSEVENT" + _FocusChangeTemporary = poEvent.Temporary + Case "ITEMEVENT" + Case "INPUTEVENT", "KEYEVENT" + _KeyCode = poEvent.KeyCode + _KeyChar = poEvent.KeyChar + _KeyFunction = poEvent.KeyFunc + _KeyAlt = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD2) + _KeyCtrl = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD1) + _KeyShift = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.SHIFT) + Case "MOUSEEVENT" + _ButtonLeft = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.LEFT) + _ButtonRight = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.RIGHT) + _ButtonMiddle = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.MIDDLE) + _XPos = poEvent.X + _YPos = poEvent.Y + _ClickCount = poEvent.ClickCount + Case "ROWCHANGEEVENT" + _RowChangeAction = poEvent.Action + Case "TEXTEVENT" + Case "ADJUSTMENTEVENT", "DOCKINGEVENT", "ENDDOCKINGEVENT", "ENDPOPUPMODEEVENT", "ENHANCEDMOUSEEVENT" _ + , "MENUEVENT", "PAINTEVENT", "SPINEVENT", "VCLCONTAINEREVENT", "WINDOWEVENT" + Goto Exit_Function + Case Else + Goto Exit_Function + End Select + + ' Evaluate ContextShortcut + sShortcut = "" + sImplementation = Utils._ImplementationName(oObject) + + Select Case True + Case sImplementation = "stardiv.Toolkit.UnoDialogControl" ' Dialog + _ContextShortcut = "Dialogs!" & _EventSource.Model.Name + Goto Exit_Function + Case Left(sImplementation, 16) = "stardiv.Toolkit." ' Control in Dialog + _ContextShortcut = "Dialogs!" & _EventSource.Context.Model.Name _ + & "!" & _EventSource.Model.Name + Goto Exit_Function + Case Else + End Select + + iCurrentDoc = _A2B_.CurrentDocIndex(, False) + If iCurrentDoc < 0 Then Goto Exit_Function + Set oDoc = _A2B_.CurrentDocument(iCurrentDoc) + + ' To manage 2x triggers of "Before record action" form event + If _EventType = "ROWCHANGEEVENT" And sImplementation <> "com.sun.star.comp.forms.ODatabaseForm" Then _Recommendation = "IGNORE" + + Do While sImplementation <> "SwXTextDocument" + sAddShortcut = "" + Select Case sImplementation + Case "com.sun.star.comp.forms.OFormsCollection" ' Do nothing + Case Else + If Utils._hasUNOProperty(oObject, "Model") Then + If oObject.Model.Name <> "MainForm" And oObject.Model.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Model.Name) + ElseIf Utils._hasUNOProperty(oObject, "Name") Then + If oObject.Name <> "MainForm" And oObject.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Name) + End If + If sAddShortcut <> "" Then + If sImplementation = cstDatabaseForm And oDoc.DbConnect = DBCONNECTBASE Then sAddShortcut = sAddShortcut & ".Form" + sShortcut = sAddShortcut & Iif(Len(sShortcut) > 0, "!" & sShortcut, "") + End If + End Select + Select Case True + Case Utils._hasUNOProperty(oObject, "Model") + Set oObject = oObject.Model.Parent + Case Utils._hasUNOProperty(oObject, "Parent") + Set oObject = oObject.Parent + Case Else + Goto Exit_Function + End Select + sImplementation = Utils._ImplementationName(oObject) + Loop + ' Add Forms! prefix + Select Case oDoc.DbConnect + Case DBCONNECTBASE + vPersistent = Split(oObject.StringValue, "/") + sAddShortcut = Utils._Surround(_GetHierarchicalName(vPersistent(UBound(vPersistent) - 1))) + sShortcut = "Forms!" & sAddShortcut & "!" & sShortcut + Case DBCONNECTFORM + sShortcut = "Forms!0!" & sShortcut + End Select + + sArray = Split(sShortcut, "!") + ' If presence of "Forms!myform!myform.Form", eliminate 2nd element + ' Eliminate anyway blanco subcomponents (e.g. Forms!!myForm) + If UBound(sArray) >= 2 Then + If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then sArray(1) = "" + sArray = Utils._TrimArray(sArray) + End If + ' If first element ends with .Form, remove suffix + If UBound(sArray) >= 1 Then + If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then sArray(1) = left(sArray(1), Len(sArray(1)) - 5) + sShortcut = Join(sArray, "!") + End If + If Len(sShortcut) >= 2 Then + If Right(sShortcut, 1) = "!" Then + _ContextShortcut = Left(sShortcut, Len(sShortcut) - 1) + Else + _ContextShortcut = sShortcut + End If + End If + +Exit_Function: + Exit Sub +Error_Function: + TraceError(TRACEWARNING, Err, "Event.Initialize", Erl) + GoTo Exit_Function +End Sub ' _Initialize V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + +Dim sSubComponentName As String, sSubComponentType As String + sSubComponentName = Iif(_SubComponentType > -1, "SubComponentName", "") + sSubComponentType = Iif(_SubComponentType > -1, "SubComponentType", "") +Dim sXPos As String, sYPos As String + sXPos = Iif(IsNull(_XPos), "", "XPos") + sYPos = Iif(IsNull(_YPos), "", "YPos") + + _PropertiesList = Utils._TrimArray(Array( _ + "ButtonLeft", "ButtonRight", "ButtonMiddle", "ClickCount" _ + , "ContextShortcut", "EventName", "EventType", "FocusChangeTemporary", _ + , "KeyAlt", "KeyChar", "KeyCode", "KeyCtrl", "KeyFunction", "KeyShift" _ + , "ObjectType", "Recommendation", "RowChangeAction", "Source" _ + , sSubComponentName, sSubComponentType, sXPos, sYPos _ + )) + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Event.get" & psProperty) + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("ButtonLeft") + _PropertyGet = _ButtonLeft + Case UCase("ButtonMiddle") + _PropertyGet = _ButtonMiddle + Case UCase("ButtonRight") + _PropertyGet = _ButtonRight + Case UCase("ClickCount") + _PropertyGet = _ClickCount + Case UCase("ContextShortcut") + _PropertyGet = _ContextShortcut + Case UCase("FocusChangeTemporary") + _PropertyGet = _FocusChangeTemporary + Case UCase("EventName") + _PropertyGet = _EventName + Case UCase("EventSource") + _PropertyGet = _EventSource + Case UCase("EventType") + _PropertyGet = _EventType + Case UCase("KeyAlt") + _PropertyGet = _KeyAlt + Case UCase("KeyChar") + _PropertyGet = _KeyChar + Case UCase("KeyCode") + _PropertyGet = _KeyCode + Case UCase("KeyCtrl") + _PropertyGet = _KeyCtrl + Case UCase("KeyFunction") + _PropertyGet = _KeyFunction + Case UCase("KeyShift") + _PropertyGet = _KeyShift + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Recommendation") + _PropertyGet = _Recommendation + Case UCase("RowChangeAction") + _PropertyGet = _RowChangeAction + Case UCase("Source") + If _ContextShortcut = "" Then + _PropertyGet = _EventSource + Else + _PropertyGet = getObject(_ContextShortcut) + End If + Case UCase("SubComponentName") + _PropertyGet = _SubComponentName + Case UCase("SubComponentType") + _PropertyGet = _SubComponentType + Case UCase("XPos") + If IsNull(_XPos) Then Goto Trace_Error + _PropertyGet = _XPos + Case UCase("YPos") + If IsNull(_YPos) Then Goto Trace_Error + _PropertyGet = _YPos + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Event.get" & psProperty) + Exit Function +Trace_Error: + ' Errors are not displayed to avoid display infinite cycling + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, False, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl) + _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 new file mode 100644 index 000000000..1fe2f185e --- /dev/null +++ b/wizards/source/access2base/Field.xba @@ -0,0 +1,923 @@ +<?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="Field" 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 FIELD +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Precision As Long +Private _ParentName As String +Private _ParentType As String +Private _ParentDatabase As Object +Private _ParentRecordset As Object +Private _DefaultValue As String +Private _DefaultValueSet As Boolean +Private Column As Object ' com.sun.star.sdb.OTableColumnWrapper + ' or org.openoffice.comp.dbaccess.OQueryColumn + ' or com.sun.star.sdb.ODataColumn + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJFIELD + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _ParentName = "" + _ParentType = "" + _DefaultValue = "" + _DefaultValueSet = False + Set Column = Nothing +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 ----------------------------------------------------------------------------------------------------------------------- + +Property Get DataType() As Long ' AOO/LibO type + DataType = _PropertyGet("DataType") +End Property ' DataType (get) + +Property Get DataUpdatable() As Boolean + DataUpdatable = _PropertyGet("DataUpdatable") +End Property ' DataUpdatable (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get DbType() As Long ' MSAccess type + DbType = _PropertyGet("DbType") +End Property ' DbType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get DefaultValue() As Variant + DefaultValue = _PropertyGet("DefaultValue") +End Property ' DefaultValue (get) + +Property Let DefaultValue(ByVal pvDefaultValue As Variant) + Call _PropertySet("DefaultValue", pvDefaultValue) +End Property ' DefaultValue (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Description() As Variant + Description = _PropertyGet("Description") +End Property ' Description (get) + +Property Let Description(ByVal pvDescription As Variant) + Call _PropertySet("Description", pvDescription) +End Property ' Description (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FieldSize() As Long + FieldSize = _PropertyGet("FieldSize") +End Property ' FieldSize (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 ----------------------------------------------------------------------------------------------------------------------- +Property Get Size() As Long + Size = _PropertyGet("Size") +End Property ' Size (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SourceField() As String + SourceField = _PropertyGet("SourceField") +End Property ' SourceField (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SourceTable() As String + SourceTable = _PropertyGet("SourceTable") +End Property ' SourceTable (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TypeName() As String + TypeName = _PropertyGet("TypeName") +End Property ' TypeName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AppendChunk(ByRef Optional pvValue As Variant) As Boolean +' Store a chunk of string or binary characters into the current field, presumably a large object (CLOB or BLOB) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Field.AppendChunk" + Utils._SetCalledSub(cstThisSub) + AppendChunk = False + + If IsMissing(pvValue) Then Call _TraceArguments() + + If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... ! + If Not Column.IsWritable Then Goto Trace_Error_Updatable + If Column.IsReadOnly Then Goto Trace_Error_Updatable + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + +Dim iChunkType As Integer + + With com.sun.star.sdbc.DataType + Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES +' Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB +' iChunkType = vbString + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB, .CHAR ' .CHAR added for Sqlite3 + iChunkType = vbByte + Case Else + Goto Trace_Error + End Select + End With + + AppendChunk = _ParentRecordset._AppendChunk(_Name, pvValue, iChunkType) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error_Updatable: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' AppendChunk V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetChunk(ByVal Optional pvOffset As Variant, ByVal Optional pvBytes As Variant) As Variant +' Get a chunk of string or binary characters from the current field, presumably a large object (CLOB or BLOB) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Field.GetChunk" + Utils._SetCalledSub(cstThisSub) + +Dim oValue As Object, bNullable As Boolean, bNull As Boolean, vValue() As Variant +Dim lLength As Long, lOffset As Long, lValue As Long + + If IsMissing(pvOffset) Or IsMissing(pvBytes) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvOffset, 1, _AddNumeric()) Then Goto Exit_Function + If pvOffset < 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvOffset)) + Goto Exit_Function + End If + If Not Utils._CheckArgument(pvBytes, 2, _AddNumeric()) Then Goto Exit_Function + If pvBytes < 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(2, pvBytes)) + Goto Exit_Function + End If + + bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE ) + bNull = False + GetChunk = Null + vValue = Array() + With com.sun.star.sdbc.DataType + Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES +' Case .CHAR, .VARCHAR, .LONGVARCHAR +' Set oValue = Column.getCharacterStream() +' Case .CLOB +' Set oValue = Column.getClob.getCharacterStream() + Case .BINARY, .VARBINARY, .LONGVARBINARY + Set oValue = Column.getBinaryStream() + Case .BLOB + Set oValue = Column.getBlob.getBinaryStream() + Case Else + Goto Trace_Error + End Select + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lOffset = CLng(pvOffset) + If lOffset > 0 Then oValue.skipBytes(lOffset) + lValue = oValue.readBytes(vValue, pvBytes) + End If + oValue.closeInput() + End With + GetChunk = vValue + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub) + Goto Exit_Function +Trace_Argument: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex)) + Set vForms = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' GetChunk V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Const cstThisSub = "Field.getProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +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 = "Field.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 ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String, sName As String +Const cstThisSub = "Field.Properties" + Utils._SetCalledSub(cstThisSub) + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + sName = _ParentType & "/" & _ParentName & "/" & _Name + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + Set vProperty._ParentDatabase = _ParentDatabase + End If + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ReadAllBytes(ByVal Optional pvFile As Variant) As Boolean +' Read the whole content of a file into Long Binary Field object + +Const cstThisSub = "Field.ReadAllBytes" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + ReadAllBytes = _ReadAll(pvFile, "ReadAllBytes") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ReadAllBytes + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ReadAllText(ByVal Optional pvFile As Variant) As Boolean +' Read the whole content of a file into a Long Char Field object + +Const cstThisSub = "Field.ReadAllText" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + ReadAllText = _ReadAll(pvFile, "ReadAllText") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ReadAllText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Const cstThisSub = "Field.setProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function WriteAllBytes(ByVal Optional pvFile As Variant) As Boolean +' Write the whole content of a Long Binary Field object to a file + +Const cstThisSub = "Field.WriteAllBytes" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + WriteAllBytes = _WriteAll(pvFile, "WriteAllBytes") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' WriteAllBytes + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function WriteAllText(ByVal Optional pvFile As Variant) As Boolean +' Write the whole content of a Long Char Field object to a file + +Const cstThisSub = "Field.WriteAllText" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + WriteAllText = _WriteAll(pvFile, "WriteAllText") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' WriteAllText + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + Select Case _ParentType + Case OBJTABLEDEF + _PropertiesList =Array("DataType", "dbType", "DefaultValue" _ + , "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _ + , "TypeName" _ + ) + Case OBJQUERYDEF + _PropertiesList = Array("DataType", "dbType", "DefaultValue" _ + , "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _ + , "TypeName" _ + ) + Case OBJRECORDSET + _PropertiesList = Array("DataType", "DataUpdatable", "dbType", "DefaultValue" _ + , "Description" , "FieldSize", "Name", "ObjectType" _ + , "Size", "SourceTable", "TypeName", "Value" _ + ) + End Select + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "Field.get" & psProperty + Utils._SetCalledSub(cstThisSub) + + If Not hasProperty(psProperty) Then Goto Trace_Error + +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 cstMaxBinlength = 2 * 65535 + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("DataType") + _PropertyGet = Column.Type + Case UCase("DbType") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BIT : _PropertyGet = dbBoolean + Case .TINYINT : _PropertyGet = dbInteger + Case .SMALLINT : _PropertyGet = dbLong + Case .INTEGER : _PropertyGet = dbLong + Case .BIGINT : _PropertyGet = dbBigInt + Case .FLOAT : _PropertyGet = dbFloat + Case .REAL : _PropertyGet = dbSingle + Case .DOUBLE : _PropertyGet = dbDouble + Case .NUMERIC : _PropertyGet = dbNumeric + Case .DECIMAL : _PropertyGet = dbDecimal + Case .CHAR : _PropertyGet = dbChar + Case .VARCHAR : _PropertyGet = dbText + Case .LONGVARCHAR : _PropertyGet = dbMemo + Case .CLOB : _PropertyGet = dbMemo + Case .DATE : _PropertyGet = dbDate + Case .TIME : _PropertyGet = dbTime + Case .TIMESTAMP : _PropertyGet = dbTimeStamp + Case .BINARY : _PropertyGet = dbBinary + Case .VARBINARY : _PropertyGet = dbVarBinary + Case .LONGVARBINARY : _PropertyGet = dbLongBinary + Case .BLOB : _PropertyGet = dbLongBinary + Case .BOOLEAN : _PropertyGet = dbBoolean + Case Else : _PropertyGet = dbUndefined + End Select + End With + Case UCase("DataUpdatable") + If Utils._hasUNOProperty(Column, "IsWritable") Then + _PropertyGet = Column.IsWritable + ElseIf Utils._hasUNOProperty(Column, "IsReadOnly") Then + _PropertyGet = Not Column.IsReadOnly + ElseIf Utils._hasUNOProperty(Column, "IsDefinitelyWritable") Then + _PropertyGet = Column.IsDefinitelyWritable + Else + _PropertyGet = False + End If + If Utils._hasUNOProperty(Column, "IsAutoIncrement") Then + If Column.IsAutoIncrement Then _PropertyGet = False ' Forces False if auto-increment (MSAccess) + End If + Case UCase("DefaultValue") + ' default value buffered to avoid multiple calls + If Not _DefaultValueSet Then + If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement + _DefaultValue = Column.DefaultValue + ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + If IsEmpty(Column.ControlDefault) Then _DefaultValue = "" Else _DefaultValue = Column.ControlDefault + Else + _DefaultValue = "" + End If + _DefaultValueSet = True + End If + _PropertyGet = _DefaultValue + Case UCase("Description") + bCond1 = Utils._hasUNOProperty(Column, "Description") + bCond2 = Utils._hasUNOProperty(Column, "HelpText") + Select Case True + Case ( bCond1 And bCond2 ) + If IsEmpty(Column.HelpText) Then _PropertyGet = Column.Description Else _PropertyGet = Column.HelpText + Case ( bCond1 And ( Not bCond2 ) ) + _PropertyGet = Column.Description + Case ( ( Not bCond1 ) And bCond2 ) + _PropertyGet = Column.HelpText + Case Else + _PropertyGet = "" + End Select + Case UCase("FieldSize") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .VARCHAR, .LONGVARCHAR, .CLOB + Set oSize = Column.getCharacterStream + Case .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB + Set oSize = Column.getBinaryStream + Case Else + Set oSize = Nothing + End Select + End With + If Not IsNull(oSize) Then + bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE ) + If bNullable Then + If Column.wasNull() Then _PropertyGet = 0 Else _PropertyGet = CLng(oSize.getLength()) + Else + _PropertyGet = CLng(oSize.getLength()) + End If + oSize.closeInput() + Else + _PropertyGet = EMPTY + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Size") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .LONGVARCHAR, .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB, .CLOB + _PropertyGet = 0 ' Always 0 (MSAccess) + Case Else + If Utils._hasUNOProperty(Column, "Precision") Then _PropertyGet = Column.Precision Else _PropertyGet = 0 + End Select + End With + Case UCase("SourceField") + Select Case _ParentType + Case OBJTABLEDEF + _PropertyGet = _Name + Case OBJQUERYDEF ' RealName = not documented ?!? + If Utils._hasUNOProperty(Column, "RealName") Then _PropertyGet = Column.RealName Else _PropertyGet = _Name + End Select + Case UCase("SourceTable") + Select Case _ParentType + Case OBJTABLEDEF + _PropertyGet = _ParentName + Case OBJQUERYDEF, OBJRECORDSET + _PropertyGet = Column.TableName + End Select + Case UCase("TypeName") + _PropertyGet = Column.TypeName + Case UCase("Value") + bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE ) + bNull = False + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BIT, .BOOLEAN : vValue = Column.getBoolean() ' vbBoolean + Case .TINYINT : vValue = Column.getShort() ' vbInteger + Case .SMALLINT, .INTEGER: vValue = Column.getInt() ' vbLong + Case .BIGINT : vValue = Column.getLong() ' vbBigint + Case .FLOAT : vValue = Column.getFloat() ' vbSingle + Case .REAL, .DOUBLE : vValue = Column.getDouble() ' vbDouble + Case .NUMERIC, .DECIMAL + If Utils._hasUNOProperty(Column, "Scale") Then + If Column.Scale > 0 Then + vValue = Column.getDouble() + Else ' Try Long otherwise Double (CDec not implemented anymore in LO ?!?) + On Local Error Resume Next ' Avoid overflow error + ' CLng checks local decimal point, getString does not ! + sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint()) + vValue = CLng(sValue) + If Err <> 0 Then + vValue = CDbl(sValue) + Err.Clear + On Local Error Goto Error_Function + End If + End If + Else + vValue = CDbl(Column.getString()) + End If + Case .CHAR : vValue = Column.getString() + Case .VARCHAR : vValue = Column.getString() ' vbString + Case .LONGVARCHAR, .CLOB + Set oValue = Column.getCharacterStream() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lSize = CLng(oValue.getLength()) + oValue.closeInput() + vValue = Column.getString() ' vbString + Else + oValue.closeInput() + End If + Case .DATE : Set oValue = Column.getDate() ' vbObject with members VarType Unsigned Short = 18 + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) + Case .TIME : Set oValue = Column.getTime() ' vbObject with members VarType Unsigned Short = 18 + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds) + Case .TIMESTAMP : Set oValue = Column.getTimeStamp() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) _ + + TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oValue = Column.getBinaryStream() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lSize = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize + If lSize > cstMaxBinlength Then Goto Trace_Length + vValue = Array() + oValue.readBytes(vValue, lSize) + End If + oValue.closeInput() + Case Else + vValue = Column.getString() 'GIVE STRING A TRY + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + If bNullable Then + If Column.wasNull() Then vValue = Null 'getXXX must precede wasNull() + End If + End With + _PropertyGet = vValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Length: + TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk")) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "Field.set" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertySet = True +Dim iArgNr As Integer, vTemp As Variant +Dim oParent As Object + + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("Field.setProperty") : iArgNr = 2 + Case UCase(cstThisSub) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("DefaultValue") + If _ParentType <> OBJTABLEDEF Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + Column.ControlDefault = pvValue + _DefaultValue = pvValue + _DefaultValueSet = True + End If + Case UCase("Description") + If _ParentType <> OBJTABLEDEF Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Column.HelpText = pvValue + Case UCase("Value") + If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... ! + If Not Column.IsWritable Then Goto Trace_Error_Updatable + If Column.IsReadOnly Then Goto Trace_Error_Updatable + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + With com.sun.star.sdbc.DataType + If IsNull(pvValue) Then + If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then Column.updateNull() Else Goto Trace_Null + Else + Select Case Column.Type + Case .BIT, .BOOLEAN + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + Column.updateBoolean(pvValue) + Case .TINYINT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -128 Or pvValue > +127 Then Goto Trace_Error_Value + Column.updateShort(CInt(pvValue)) + Case .SMALLINT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -32768 Or pvValue > 32767 Then Goto trace_Error_Value + Column.updateInt(CLng(pvValue)) + Case .INTEGER + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto trace_Error_Value + Column.updateInt(CLng(pvValue)) + Case .BIGINT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + Column.updateLong(pvValue) ' No proper type conversion for HYPER data type + Case .FLOAT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then Column.updateFloat(CSng(pvValue)) Else Goto trace_Error_Value + Case .REAL, .DOUBLE + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value + Column.updateDouble(CDbl(pvValue)) + Case .NUMERIC, .DECIMAL + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(Column, "Scale") Then + If Column.Scale > 0 Then + 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value + Column.updateDouble(CDbl(pvValue)) + Else + Column.updateString(CStr(pvValue)) + End If + Else + Column.updateString(CStr(pvValue)) + End If + Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If _Precision > 0 And Len(pvValue) > _Precision Then Goto Trace_Error_Length + Column.updateString(pvValue) ' vbString + Case .DATE + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + vTemp = New com.sun.star.util.Date + With vTemp + .Day = Day(pvValue) + .Month = Month(pvValue) + .Year = Year(pvValue) + End With + Column.updateDate(vTemp) + Case .TIME + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + vTemp = New com.sun.star.util.Time + With vTemp + .Hours = Hour(pvValue) + .Minutes = Minute(pvValue) + .Seconds = Second(pvValue) + '.HundredthSeconds = 0 ' replaced with Long nanoSeconds in LO 4.1 ?? + End With + Column.updateTime(vTemp) + Case .TIMESTAMP + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + vTemp = New com.sun.star.util.DateTime + With vTemp + .Day = Day(pvValue) + .Month = Month(pvValue) + .Year = Year(pvValue) + .Hours = Hour(pvValue) + .Minutes = Minute(pvValue) + .Seconds = Second(pvValue) + '.HundredthSeconds = 0 + End With + Column.updateTimestamp(vTemp) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If Not IsArray(pvValue) Then Goto Trace_Error_Value + If UBound(pvValue) < LBound(pvValue) Then Goto Trace_Error_Value + If Not Utils._CheckArgument(pvValue(LBound(pvValue)), iArgNr, vbInteger, , False) Then Goto Trace_Error_Value + Column.updateBytes(pvValue) + Case Else + Goto trace_Error + End Select + End If + End With + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Trace_Null: + TraceError(TRACEFATAL, ERRNOTNULLABLE, Utils._CalledSub(), 0, 1, _Name) + _PropertySet = False + Goto Exit_Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error_Updatable: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error_Length: + TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(Len(pvValue), "AppendChunk")) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReadAll(ByVal psFile As String, ByVal psMethod As String) As Boolean +' Write the whole content of a file into a stream object + + If _ErrorHandler() Then On Local Error Goto Error_Function + _ReadAll = False + + If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... ! + If Not Column.IsWritable Then Goto Trace_Error_Updatable + If Column.IsReadOnly Then Goto Trace_Error_Updatable + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + +Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object +Dim lFileLength As Long, sBuffer As String, sMemo As String, iFile As Integer +Const cstMaxLength = 64000 + sFile = ConvertToURL(psFile) + + oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + If Not oSimpleFileAccess.exists(sFile) Then Goto Trace_File + + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If psMethod <> "ReadAllBytes" Then Goto Trace_Error + Set oStream = oSimpleFileAccess.openFileRead(sFile) + lFileLength = oStream.getLength() + If lFileLength = 0 Then Goto Trace_File + Column.updateBinaryStream(oStream, lFileLength) + oStream.closeInput() + Case .VARCHAR, .LONGVARCHAR, .CLOB + If psMethod <> "ReadAllText" Then Goto Trace_Error + sMemo = "" + lFileLength = 0 + iFile = FreeFile() + Open sFile For Input Access Read Shared As iFile + Do While Not Eof(iFile) + Line Input #iFile, sBuffer + lFileLength = lFileLength + Len(sBuffer) + 1 + If lFileLength > cstMaxLength Then Exit Do + sMemo = sMemo & sBuffer & vbNewLine + Loop + If lFileLength = 0 Or lFileLength > cstMaxLength Then + Close #iFile + Goto Trace_File + End If + sMemo = Left(sMemo, lFileLength - 1) + Column.updateString(sMemo) + 'Column.updateCharacterStream(oStream, lFileLength) ' DOES NOT WORK ?!? + Case Else + Goto Trace_Error + End Select + End With + + _ReadAll = True + +Exit_Function: + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod) + Goto Exit_Function +Trace_File: + TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Trace_Error_Updatable: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, _CalledSub, Erl) + GoTo Exit_Function +End Function ' ReadAll + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _WriteAll(ByVal psFile As String, ByVal psMethod As String) As Boolean +' Write the whole content of a stream object to a file + + If _ErrorHandler() Then On Local Error Goto Error_Function + _WriteAll = False + +Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object + sFile = ConvertToURL(psFile) + + oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If psMethod <> "WriteAllBytes" Then Goto Trace_Error + Set oStream = Column.getBinaryStream() + Case .VARCHAR, .LONGVARCHAR, .CLOB + If psMethod <> "WriteAllText" Then Goto Trace_Error + Set oStream = Column.getCharacterStream() + Case Else + Goto Trace_Error + End Select + End With + + If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then + If Column.wasNull() Then Goto Trace_Null + End If + If oStream.getLength() = 0 Then Goto Trace_Null + On Local Error Goto Trace_File + If oSimpleFileAccess.exists(sFile) Then oSimpleFileAccess.kill(sFile) + oSimpleFileAccess.writeFile(sFile, oStream) + On Local Error Goto Error_Function + oStream.closeInput() + + _WriteAll = True + +Exit_Function: + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod) + Goto Exit_Function +Trace_File: + TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Trace_Null: + TraceError(TRACEFATAL, ERRFIELDNULL, _CalledSub, 0) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, _CalledSub, Erl) + GoTo Exit_Function +End Function ' WriteAll + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Form.xba b/wizards/source/access2base/Form.xba new file mode 100644 index 000000000..df18feb34 --- /dev/null +++ b/wizards/source/access2base/Form.xba @@ -0,0 +1,1129 @@ +<?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="Form" 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 FORM +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Shortcut As String +Private _Name As String +Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure +Private _DbEntry As Integer +Private _MainForms As Variant +Private _PersistentName As String +Private _IsLoaded As Boolean +Private _OpenArgs As Variant +Private _OrderBy As String +Public Component As Object ' com.sun.star.text.TextDocument +Public ContainerWindow As Object ' (No name) +Public FormsCollection As Object ' com.sun.star.form.OFormsCollection +Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJFORM + Set _This = Nothing + Set _Parent = Nothing + _Shortcut = "" + _Name = "" + _DocEntry = -1 + _DbEntry = -1 + _MainForms = Array() + _PersistentName = "" + _IsLoaded = False + _OpenArgs = "" + _OrderBy = "" + Set Component = Nothing + Set ContainerWindow = Nothing + Set FormsCollection = Nothing + Set DatabaseForm = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() +Dim ofForm As Object + If Not IsLoaded(True) Then + If Not IsNull(DatabaseForm) Then DatabaseForm.Dispose() + End If + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowAdditions() As Variant + AllowAdditions = _PropertyGet("AllowAdditions") +End Property ' AllowAdditions (get) + +Property Let AllowAdditions(ByVal pvValue As Variant) + Call _PropertySet("AllowAdditions", pvValue) +End Property ' AllowAdditions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowDeletions() As Variant + AllowDeletions = _PropertyGet("AllowDeletions") +End Property ' AllowDeletions (get) + +Property Let AllowDeletions(ByVal pvValue As Variant) + Call _PropertySet("AllowDeletions", pvValue) +End Property ' AllowDeletions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowEdits() As Variant + AllowEdits = _PropertyGet("AllowEdits") +End Property ' AllowEdits (get) + +Property Let AllowEdits(ByVal pvValue As Variant) + Call _PropertySet("AllowEdits", pvValue) +End Property ' AllowEdits (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Bookmark() As Variant + Bookmark = _PropertyGet("Bookmark") +End Property ' Bookmark (get) + +Property Let Bookmark(ByVal pvValue As Variant) + Call _PropertySet("Bookmark", pvValue) +End Property ' Bookmark (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get CurrentRecord() As Variant + CurrentRecord = _PropertyGet("CurrentRecord") +End Property ' CurrentRecord (get) + +Property Let CurrentRecord(ByVal pvValue As Variant) + Call _PropertySet("CurrentRecord", pvValue) +End Property ' CurrentRecord (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Filter() As Variant + Filter = _PropertyGet("Filter") +End Property ' Filter (get) + +Property Let Filter(ByVal pvValue As Variant) + Call _PropertySet("Filter", pvValue) +End Property ' Filter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FilterOn() As Variant + FilterOn = _PropertyGet("FilterOn") +End Property ' FilterOn (get) + +Property Let FilterOn(ByVal pvValue As Variant) + Call _PropertySet("FilterOn", pvValue) +End Property ' FilterOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Height() As Variant + Height = _PropertyGet("Height") +End Property ' Height (get) + +Property Let Height(ByVal pvValue As Variant) + Call _PropertySet("Height", pvValue) +End Property ' Height (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Function IsLoaded(ByVal Optional pbForce As Boolean) As Boolean +'Return True if form open +'pbForce = True forbids bypass on value of _IsLoaded + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.getIsLoaded") + If IsMissing(pbForce) Then pbForce = False + If ( Not pbForce ) And _IsLoaded Then ' For performance reasons, a form object, once detected as loaded, is presumed remaining loaded. Except if pbForce = True + IsLoaded = True + Goto Exit_Function + End If + IsLoaded = False + +Dim oDoc As Object, oDatabase As Object, oEnum As Object, oDesk As Object, oComp As Object, vPersistent As Variant +Dim i As Integer + Set oDoc = _A2B_.CurrentDocument() + Select Case oDoc.DbConnect + Case DBCONNECTBASE + Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") + Set oEnum = oDesk.Components().createEnumeration + Do While oEnum.hasMoreElements ' Search in all open components if one corresponds with current form + oComp = oEnum.nextElement + If _hasUNOProperty(oComp, "Identifier") Then + If oComp.Identifier = "com.sun.star.sdb.FormDesign" Then + vPersistent = Split(oComp.StringValue, "/") + If vPersistent(UBound(vPersistent) - 1) = _PersistentName Then + _IsLoaded = True + Set Component = oComp + Exit Do + End If + End If + End If + Loop + Case DBCONNECTFORM + Set Component = oDoc.Document ' Form + _IsLoaded = True ' Interactive form always loaded by design + End Select + Set oComp = Nothing + IsLoaded = _IsLoaded + +Exit_Function: + Utils._ResetCalledSub("Form.getIsLoaded") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.getIsLoaded", Erl) + GoTo Exit_Function +End Function ' IsLoaded V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveCursorMove() As Variant + OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") +End Property ' OnApproveCursorMove (get) + +Property Let OnApproveCursorMove(ByVal pvValue As Variant) + Call _PropertySet("OnApproveCursorMove", pvValue) +End Property ' OnApproveCursorMove (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveParameter() As Variant + OnApproveParameter = _PropertyGet("OnApproveParameter") +End Property ' OnApproveParameter (get) + +Property Let OnApproveParameter(ByVal pvValue As Variant) + Call _PropertySet("OnApproveParameter", pvValue) + +End Property ' OnApproveParameter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' OnApproveReset (get) + +Property Let OnApproveReset(ByVal pvValue As Variant) + Call _PropertySet("OnApproveReset", pvValue) +End Property ' OnApproveReset (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveRowChange() As Variant + OnApproveRowChange = _PropertyGet("OnApproveRowChange") +End Property ' OnApproveRowChange (get) + +Property Let OnApproveRowChange(ByVal pvValue As Variant) + Call _PropertySet("OnApproveRowChange", pvValue) +End Property ' OnApproveRowChange (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveSubmit() As Variant + OnApproveSubmit = _PropertyGet("OnApproveSubmit") +End Property ' OnApproveSubmit (get) + +Property Let OnApproveSubmit(ByVal pvValue As Variant) + Call _PropertySet("OnApproveSubmit", pvValue) +End Property ' OnApproveSubmit (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnConfirmDelete() As Variant + OnConfirmDelete = _PropertyGet("OnConfirmDelete") +End Property ' OnConfirmDelete (get) + +Property Let OnConfirmDelete(ByVal pvValue As Variant) + Call _PropertySet("OnConfirmDelete", pvValue) +End Property ' OnConfirmDelete (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnCursorMoved() As Variant + OnCursorMoved = _PropertyGet("OnCursorMoved") +End Property ' OnCursorMoved (get) + +Property Let OnCursorMoved(ByVal pvValue As Variant) + Call _PropertySet("OnCursorMoved", pvValue) +End Property ' OnCursorMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' OnErrorOccurred (get) + +Property Let OnErrorOccurred(ByVal pvValue As Variant) + Call _PropertySet("OnErrorOccurred", pvValue) +End Property ' OnErrorOccurred (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoaded() As Variant + OnLoaded = _PropertyGet("OnLoaded") +End Property ' OnLoaded (get) + +Property Let OnLoaded(ByVal pvValue As Variant) + Call _PropertySet("OnLoaded", pvValue) +End Property ' OnLoaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloaded() As Variant + OnReloaded = _PropertyGet("OnReloaded") +End Property ' OnReloaded (get) + +Property Let OnReloaded(ByVal pvValue As Variant) + Call _PropertySet("OnReloaded", pvValue) +End Property ' OnReloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloading() As Variant + OnReloading = _PropertyGet("OnReloading") +End Property ' OnReloading (get) + +Property Let OnReloading(ByVal pvValue As Variant) + Call _PropertySet("OnReloading", pvValue) +End Property ' OnReloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnResetted() As Variant + OnResetted = _PropertyGet("OnResetted") +End Property ' OnResetted (get) + +Property Let OnResetted(ByVal pvValue As Variant) + Call _PropertySet("OnResetted", pvValue) +End Property ' OnResetted (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnRowChanged() As Variant + OnRowChanged = _PropertyGet("OnRowChanged") +End Property ' OnRowChanged (get) + +Property Let OnRowChanged(ByVal pvValue As Variant) + Call _PropertySet("OnRowChanged", pvValue) +End Property ' OnRowChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloaded() As Variant + OnUnloaded = _PropertyGet("OnUnloaded") +End Property ' OnUnloaded (get) + +Property Let OnUnloaded(ByVal pvValue As Variant) + Call _PropertySet("OnUnloaded", pvValue) +End Property ' OnUnloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloading() As Variant + OnUnloading = _PropertyGet("OnUnloading") +End Property ' OnUnloading (get) + +Property Let OnUnloading(ByVal pvValue As Variant) + Call _PropertySet("OnUnloading", pvValue) +End Property ' OnUnloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OpenArgs() As Variant + OpenArgs = _PropertyGet("OpenArgs") +End Property ' OpenArgs (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderBy() As Variant + OrderBy = _PropertyGet("OrderBy") +End Property ' OrderBy (get) V1.2.0 + +Property Let OrderBy(ByVal pvValue As Variant) + Call _PropertySet("OrderBy", pvValue) +End Property ' OrderBy (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderByOn() As Variant + OrderByOn = _PropertyGet("OrderByOn") +End Property ' OrderByOn (get) V1.2.0 + +Property Let OrderByOn(ByVal pvValue As Variant) + Call _PropertySet("OrderByOn", pvValue) +End Property ' OrderByOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name + +Const cstThisSub = "Form.OptionGroup" +Dim ogGroup As Object + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, Component, FormsCollection) + If Not IsNull(ogGroup) Then + ogGroup._DocEntry = _DocEntry + ogGroup._DbEntry = _DbEntry + End If + Set OptionGroup = ogGroup + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Form.OptionGroup, Erl) + GoTo Exit_Function +End Function ' OptionGroup V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _Parent +End Function ' Parent (get) V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Recordset() As Object + Recordset = _PropertyGet("Recordset") +End Property ' Recordset (get) V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RecordSource() As Variant + RecordSource = _PropertyGet("RecordSource") +End Property ' RecordSource (get) + +Property Let RecordSource(ByVal pvValue As Variant) + Call _PropertySet("RecordSource", pvValue) +End Property ' RecordSource (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Width() As Variant + Width = _PropertyGet("Width") +End Property ' Width (get) + +Property Let Width(ByVal pvValue As Variant) + Call _PropertySet("Width", pvValue) +End Property ' Width (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function mClose() As Variant +' Close the form + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.Close") + mClose = False +Dim oDatabase As Object, oController As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + Set oController = oDatabase.Document.getFormDocuments.getByHierarchicalName(_Name) + oController.close() + Dispose() + mClose = True + +Exit_Function: + Utils._ResetCalledSub("Form.Close") + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Close", Erl) + GoTo Exit_Function +End Function ' Close + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.Controls") + +Dim ocControl As Variant, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer, iCount As Integer, sName As String, iAddCount As Integer +Dim oDatabaseForm As Object, iCtlCount As Integer + + Set ocControl = Nothing + If Not IsLoaded Then Goto Trace_Error_NotOpen + 'Count number of controls thru the forms collection + iControlCount = 0 + + iCount = FormsCollection.Count + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then iControlCount = iControlCount + oDatabaseForm.getCount() + Next i + + If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + oCounter._Count = iControlCount + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + + sName = "" + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + iAddCount = 0 + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + iCtlCount = oDatabaseForm.getCount() + If pvIndex >= iAddCount And pvIndex <= iAddcount + iCtlCount - 1 Then + sName = oDatabaseForm.ElementNames(pvIndex - iAddCount) + Exit For + End If + iAddCount = iAddcount +iCtlCount + End If + Next i + Case vbString ' Check control name validity (non case sensitive) + sIndex = UCase(Utils._Trim(pvIndex)) + bFound = False + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + sControls() = oDatabaseForm.getElementNames() + For j = 0 To UBound(sControls) + If UCase(sControls(j)) = sIndex Then + sName = sControls(j) + bFound = True + Exit For + End If + Next j + If bFound Then Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + End Select + + 'Initialize a new Control object + Set ocControl = New Control + With ocControl + Set ._This = ocControl + Set ._Parent = _This + ._ParentType = CTLPARENTISFORM + ._Name = sName + ._Shortcut = _Shortcut & "!" & Utils._Surround(sName) + If IsNull(oDatabaseForm) Then ._MainForm = "" Else ._MainForm = oDatabaseForm.Name + Set .ControlModel = oDatabaseForm.getByName(sName) + ._ImplementationName = .ControlModel.getImplementationName() + ._FormComponent = Component + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + If ._ClassId > 0 And ._ClassId <> acHiddenControl Then + Set .ControlView = Component.CurrentController.getControl(.ControlModel) + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("Form.Controls") + Exit Function +Trace_Error_NotOpen: + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , _Name) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex)) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns Database object related to current form + +Const cstThisSub = "Form.CurrentDb" + Utils._SetCalledSub(cstThisSub) + + Set CurrentDb = Application._CurrentDb(_DocEntry, _DbEntry) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Form.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Form.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move( ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute Move method + Utils._SetCalledSub("Form.Move") + If _ErrorHandler() Then On Local Error Goto Error_Function + Move = False +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("Move") : iArgNr = 1 + Case UCase("Form.Move") : iArgNr = 0 + End Select + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function + +Dim iArg As Integer, iWrong As Integer ' Check arguments values + iArg = 0 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If + If iArg > 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) + Goto Exit_Function + End If + +Dim iPosSize As Integer + iPosSize = 0 + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + If iPosSize > 0 Then + If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + ContainerWindow.IsMaximized = False + ContainerWindow.IsMinimized = False + End If + ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) + End If + Move = True + +Exit_Function: + Utils._ResetCalledSub("Form.Move") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Move", Erl) + GoTo Exit_Function +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Refresh() As Boolean +' Refresh data with its most recent value in the database in a form or subform + Utils._SetCalledSub("Form.Refresh") + If _ErrorHandler() Then On Local Error Goto Error_Function + Refresh = False + +Dim oSet As Object + Set oSet = DatabaseForm.createResultSet() + If Not IsNull(oSet) Then + oSet.refreshRow() + Refresh = True + End If + +Exit_Function: + Set oSet = Nothing + Utils._ResetCalledSub("Form.Refresh") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl) + GoTo Exit_Function +End Function ' Refresh + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery() As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("Form.Requery") + If _ErrorHandler() Then On Local Error Goto Error_Function + Requery = False + + DatabaseForm.reload() + Requery = True + +Exit_Function: + Utils._ResetCalledSub("Form.Requery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Requery", Erl) + GoTo Exit_Function +End Function ' Requery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFocus() As Boolean +' Execute setFocus method +Const cstThisSub = "Form.setFocus" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + setFocus = False + + With ContainerWindow + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .setEnable(True) ' Added to try to bypass desynchro issue in Linux + .toFront() ' Added to force window change in Linux + End With + setFocus = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Goto Exit_Function +End Function ' setFocus V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("Form.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("Form.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnApproveCursorMove") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveParameter") + _GetListener = "XDatabaseParameterListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveRowChange") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveSubmit") + _GetListener = "XSubmitListener" + Case UCase("OnConfirmDelete") + _GetListener = "XConfirmDeleteListener" + Case UCase("OnCursorMoved"), UCase("OnRowChanged") + _GetListener = "XRowSetListener" + Case UCase("OnErrorOccurred") + _GetListener = "XSQLErrorListener" + Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") + _GetListener = "XLoadListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize(psName As String) +' Set pointers to UNO objects + +Dim oDoc As Object, oDatabase As Object + If _ErrorHandler() Then On Local Error Goto Trace_Error + _Name = psName + _Shortcut = "Forms!" & Utils._Surround(psName) + Set oDoc = _A2B_.CurrentDocument() + If oDoc.DbConnect = DBCONNECTBASE Then _PersistentName = oDoc.Document.getFormDocuments().getByHierarchicalName(psName).PersistentName + If IsLoaded Then + Select Case oDoc.DbConnect + Case DBCONNECTBASE + If Not IsNull(Component.CurrentController) Then ' A form opened then closed afterwards keeps a Component attribute + Set ContainerWindow = Component.CurrentController.Frame.ContainerWindow + Set FormsCollection = Component.getDrawPage.Forms + If FormsCollection.Count = 0 Then + Set DatabaseForm = Nothing + Else + 'Only first member of the collection can be reached with A2B + 'Compliant with MSAccess which has 1 datasource by form, while LO might have many + _MainForms = FormsCollection.ElementNames() + Set DatabaseForm = FormsCollection.getByIndex(0) + End If + End If + Case DBCONNECTFORM + Set ContainerWindow = oDoc.Document.CurrentController.Frame.ContainerWindow + Set FormsCollection = oDoc.Document.getDrawPage.Forms + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + With oDatabase + Set DatabaseForm = .Form + If IsNull(.Connection) Then + Set .Connection = DatabaseForm.ActiveConnection + If Not IsNull(.Connection) Then + Set .MetaData = .Connection.MetaData + oDatabase._ReadOnly = .Connection.isReadOnly() + End If + End If + End With + End Select + If IsNull(DatabaseForm) Then _OrderBy = "" Else _OrderBy = DatabaseForm.Order + Else + Set Component = Nothing + Set ContainerWindow = Nothing + Set DatabaseForm = Nothing + End If + +Exit_Sub: + Exit Sub +Trace_Error: + TraceError(TRACEABORT, Err, "Form.Initialize", Erl) + Goto Exit_Sub +Trace_Internal_Error: + TraceError(TRACEABORT, ERRFORMNOTIDENTIFIED, Utils._CalledSub(), 0, , _Name) + Goto Exit_Sub +End Sub ' _Initialize V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + If _IsLoaded Then + _PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "Bookmark" _ + , "Caption", "CurrentRecord", "Filter", "FilterOn", "Height", "IsLoaded" _ + , "Name", "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _ + , "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _ + , "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _ + , "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OpenArgs" _ + , "OrderBy", "OrderByOn", "RecordSource", "Visible", "Width" _ + ) ' Recordset removed + Else + _PropertiesList = Array("IsLoaded", "Name" _ + ) + End If + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.get" & psProperty) + +'Execute +Dim oDatabase As Object, vBookmark As Variant +Dim i As Integer, oObject As Object + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("Name"), UCase("IsLoaded") + Case Else : If Not IsLoaded Then Goto Trace_Error_Form + End Select + + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowInserts + Case UCase("AllowDeletions") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowDeletes + Case UCase("AllowEdits") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowUpdates + Case UCase("Bookmark") + If IsNull(DatabaseForm) Then + _PropertyGet = 0 + Else + On Local Error Resume Next ' Disable error handler because bookmarking does not always react well in events ... + If DatabaseForm.IsBookmarkable Then vBookmark = DatabaseForm.getBookmark() Else vBookmark = Nothing + If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0 + If IsNull(vBookmark) Then Goto Trace_Error + _PropertyGet = vBookmark + End If + Case UCase("Caption") + Set odatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Select Case oDatabase._DbConnect + Case DBCONNECTFORM : _PropertyGet = oDatabase.Document.CurrentController.Frame.Title + Case DBCONNECTBASE : _PropertyGet = Component.CurrentController.Frame.Title + End Select + Case UCase("CurrentRecord") + If IsNull(DatabaseForm) Then _PropertyGet = 0 Else _PropertyGet = DatabaseForm.Row + Case UCase("Filter") + If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Filter + Case UCase("FilterOn") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.ApplyFilter + Case UCase("Height") + _PropertyGet = ContainerWindow.getPosSize().Height + Case UCase("IsLoaded") ' Only for indirect access from property object + _PropertyGet = IsLoaded + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name, True) + Case UCase("OpenArgs") + _PropertyGet = _OpenArgs + Case UCase("OrderBy") + _PropertyGet = _OrderBy + Case UCase("OrderByOn") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = ( DatabaseForm.Order <> "" ) + Case UCase("Recordset") + If IsNull(DatabaseForm) Then Goto Trace_Error + If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? + Set oObject = New Recordset + With DatabaseForm + oObject._This = oObject + oObject._CommandType = .CommandType + oObject._Command = .Command + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Set oObject._ParentDatabase = oDatabase + Set oObject._ParentDatabase.Connection = .ActiveConnection + oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) + oObject._PassThrough = ( .EscapeProcessing = False ) + oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) + Call oObject._Initialize() + End With + With oDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + Set _PropertyGet = oObject + Case UCase("RecordSource") + If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Command + Case UCase("Visible") + _PropertyGet = ContainerWindow.IsVisible() + Case UCase("Width") + _PropertyGet = ContainerWindow.getPosSize().Width + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Form.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Form: + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("Form.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer, i As Integer +Dim oDatabase As Object + + If _Isleft(_A2B_.CalledSub, "Form.") Then iArgNr = 1 Else iArgNr = 2 + If Not IsLoaded Then Goto Trace_Error_Form + + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.AllowInserts = pvValue + DatabaseForm.reload() + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.AllowDeletes = pvValue + DatabaseForm.reload() + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.AllowUpdates = pvValue + DatabaseForm.reload() + Case UCase("Bookmark") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbObject), , False) Then Goto Trace_Error_Value + If IsNull(pvValue) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.MoveToBookmark(pvValue) + Case UCase("Caption") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Select Case oDatabase._DbConnect + Case DBCONNECTFORM : oDatabase.Document.CurrentController.Frame.Title = pvValue + Case DBCONNECTBASE : Component.CurrentController.Frame.Title = pvValue + End Select + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.absolute(pvValue) + Case UCase("Filter") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.ApplyFilter = pvValue + DatabaseForm.reload() + Case UCase("Height") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + ContainerWindow.IsMaximized = False + ContainerWindow.IsMinimized = False + End If + ContainerWindow.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT) + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + If Not Utils._RegisterEventScript(DatabaseForm _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue, _Name, True _ + ) Then GoTo Trace_Error + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + _OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = "" + DatabaseForm.reload() + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND + DatabaseForm.Filter = "" + DatabaseForm.reload() + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ContainerWindow.setVisible(pvValue) + Case UCase("Width") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + ContainerWindow.IsMaximized = False + ContainerWindow.IsMinimized = False + End If + ContainerWindow.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Form.set" & psProperty) + Exit Function +Trace_Error_Form: + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) + _PropertySet = False + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba new file mode 100644 index 000000000..ef11f6f3e --- /dev/null +++ b/wizards/source/access2base/L10N.xba @@ -0,0 +1,540 @@ +<?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="L10N" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _GetLabel(ByVal psShortlabel As String, Optional ByVal psLocale As String) As String +' Return the localized label corresponding with ShortLabel + + If IsMissing(psLocale) Then psLocale = UCase(Left(_A2B_.Locale, 2)) Else psLocale = UCase(psLocale) + On Local Error Goto Error_Function + If Not Utils._InList(psLocale, Array( _ + "EN", "FR", "ES", "DE" _ + )) Then psLocale = "DEFAULT" ' If list incomplete a recursive call will be provided anyway + +Dim sLocal As String + sLocal = psShortLabel + Select Case psLocale + Case "EN", "DEFAULT" + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No active connection to a database found" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Arguments are missing or are not initialized" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument nr. %0 [Value = '%1'] is invalid" + Case "ERR" & ERRMAINFORM : sLocal = "Document '%0' does not contain any form" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Form '%0' not identified in database Forms set" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "Form '%0' not found" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "Form '%0' is currently not open" + Case "ERR" & ERRDFUNCTION : sLocal = "DFunction execution failed, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "Form '%0' could not be opened" + Case "ERR" & ERRPROPERTY : sLocal = "Property '%0' not applicable in this context" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "Value '%0' is invalid for property '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Out of array range or incorrect array size for property '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Out of array range" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument nr.%0 should be an array" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Control '%0' not found in parent (form, grid or dialog) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "No active form or control found" + Case "ERR" & ERRDATABASEFORM : sLocal = "Form '%0' has no underlying dataset" + Case "ERR" & ERRFOCUSINGRID : sLocal = "Control '%0' not found in gridcontrol '%1'" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "No gridcontrol found in form '%0'" + Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() must be preceded by a successful FindRecord(...) call" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' not found" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' could not be opened" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' could not be closed" + Case "ERR" & ERRACTION : sLocal = "Action not applicable in this context" + Case "ERR" & ERRSENDMAIL : sLocal = "Mail service could not be activated" + Case "ERR" & ERRFORMYETOPEN : sLocal = "Form %0 is already open" + Case "ERR" & ERRMETHOD : sLocal = "Method '%0' not applicable in this context" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Property '%0' applicable but not initialized" + Case "ERR" & ERRFILENOTCREATED : sLocal = "File '%0' could not be created" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' not found in the currently loaded libraries" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unknown" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog already started" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' not active" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset delivered no data. Action on current record rejected" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset has been closed. Recordset action rejected" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "Current record out of range" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejected in a forward-only or not bookmarkable recordset" + Case "ERR" & ERRFIELDNULL : sLocal = "Field is null or empty. Action rejected" + Case "ERR" & ERRFILEACCESS : sLocal = "File access error on file '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "Field length (%0) exceeds maximum length. Use the '%1' method instead" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Query '%0' is not an action query" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "Database, recordset or field is read only" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Recordset update sequence error" + Case "ERR" & ERRNOTNULLABLE : sLocal = "Field '%0' must not contain a NULL value" + Case "ERR" & ERRROWDELETED : sLocal = "Current row has been deleted by another process or user" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "Cloning a cloned Recordset is forbidden" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Pre-existing query '%0' has been deleted" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Pre-existing table '%0' has been deleted" + Case "ERR" & ERRTABLECREATION : sLocal = "Table '%0' could not be created" + Case "ERR" & ERRFIELDCREATION : sLocal = "Field '%0' could not be created" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Subform '%0' not found in parent form '%1'" + 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" + Case "QUERY" : slocal = "Query" + Case "FORM" : sLocal = "Form" + Case "REPORT" : sLocal = "Report" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Field" + Case "TEMPVAR" : sLocal = "Temporary variable" + Case "COMMANDBAR" : sLocal = "Command bar" + Case "COMMANDBARCONTROL" : sLocal = "Command bar control" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "Error #" + Case "ERROCCUR" : sLocal = "occurred" + Case "ERRLINE" : sLocal = "at line" + Case "ERRIN" : sLocal = "in" + Case "CALLTO" : sLocal = "a call to function" + Case "SAVECONSOLE" : sLocal = "Save console" + Case "SAVECONSOLEENTRIES" : sLocal = "The console entries have been saved successfully." + Case "QUITSHORT" : sLocal = "Quit" + Case "QUIT" : sLocal = "Do you really want to quit the application ? Changed data will be saved." + Case "ENTERING" : sLocal = "Entering" + Case "EXITING" : sLocal = "Exiting" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Manage the console buffer and its entries" + Case "DLGTRACE_TITLE" : sLocal = "Console" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Clear the list and resize the circular buffer" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Set max number of entries" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text can be selected, copied, ..." + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log file is empty ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancel" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Clear the list" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Clear the list" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Register only logging requests above given level" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Set minimal trace level" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validate" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Choose a file and dump the actual list content in it" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Dump to file" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Actual size of list" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Actual number of entries:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Export the form" + Case "DLGFORMAT_TITLE" : sLocal = "OutputTo" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format in which the form should be exported" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Select the output format" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validate your choice" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancel" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = "" + End Select + Case "FR" + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Pas de connexion active trouvée à une banque de données" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Des arguments sont manquants ou non initialisés" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "L'argument n° %0 [Valeur = '%1'] n'est pas valable" + Case "ERR" & ERRMAINFORM : sLocal = "Le document '%0' ne contient aucun formulaire" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Le formulaire '%0' n'a pas pu être identifié parmi l'ensemble des formulaires de la Database" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formulaire '%0' non trouvé" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "Le formulaire '%0' n'est actuellement pas ouvert" + Case "ERR" & ERRDFUNCTION : sLocal = "L'exécution de la ""fonction database"" a échoué, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "Le formulaire '%0' n'a pas pu être ouvert" + Case "ERR" & ERRPROPERTY : sLocal = "La propriété '%0' n'est pas applicable dans ce contexte" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "La valeur '%0' est invalide pour la propriété '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Indice invalide ou dimension erronée du tableau pour la propriété '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Indice de tableau invalide" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "L'argument n°%0 doit être un tableau" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Contrôle '%0' non trouvé dans le parent (formulaire, contrôle de table ou dialogue) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "Pas de formulaire ou de contrôle actif" + Case "ERR" & ERRDATABASEFORM : sLocal = "Le formulaire '%0' n'a pas de données sous-jacentes" + Case "ERR" & ERRFOCUSINGRID : sLocal = "Contrôle '%0' non trouvé dans le contrôle de table '%1'" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "Aucun contrôle de table trouvé dans le formulaire '%0'" + Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() doit être précédé par un appel réussi à FindRecord(...)" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "Erreur SQL, instruction SQL = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' non trouvé(e)" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1': ouverture en échec" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1': fermeture en échec" + Case "ERR" & ERRACTION : sLocal = "Action non applicable dans ce contexte" + Case "ERR" & ERRSENDMAIL : sLocal = "Le service de messagerie n'a pas pu être activé" + Case "ERR" & ERRFORMYETOPEN : sLocal = "Le formulaire %0 est déjà ouvert" + Case "ERR" & ERRMETHOD : sLocal = "La méthode '%0' n'est pas applicable dans ce contexte" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Propriété '%0' applicable mais non initialisée" + Case "ERR" & ERRFILENOTCREATED : sLocal = "Erreur de création du fichier '%0'" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialogue '%0' introuvable dans les librairies chargées actuellement" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Boîte de dialogue inconnue" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialogue déjà initialisé précédemment" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialogue '%0' non initialisé" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset n'a pas fourni de données. Toute action sur les enregistrements est rejetée" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset a été clôturé. Action sur l'enregistrement courant est rejetée" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "L'enregistrement courant est hors cadre" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejetée car recordset lisible seulement vers l'avant ou n'acceptant pas de signets" + Case "ERR" & ERRFIELDNULL : sLocal = "Champ nul ou vide. Action rejetée" + Case "ERR" & ERRFILEACCESS : sLocal = "Erreur d'accès au fichier '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "La longueur du champ (%0) dépasse la taille maximale autorisée. Utiliser de préférence la méthode '%1'" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La requête '%0' n'est pas une requête d'action" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "La banque de données, le recordset ou le champ sont en lecture seulement" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Erreur de séquence lors de la mise à jour d'un Recordset" + Case "ERR" & ERRNOTNULLABLE : sLocal = "Le champ '%0' ne peut pas recevoir une valeur NULLe" + Case "ERR" & ERRROWDELETED : sLocal = "L'enregistrement courant a été effacé par un autre processus ou un autre utilisateur" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "Le clonage d'un Recordset cloné est interdit" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "La requête existante '%0' a été supprimée" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "La table existante '%0' a été supprimée" + Case "ERR" & ERRTABLECREATION : sLocal = "La table '%0' n'a pas pu être créée" + Case "ERR" & ERRFIELDCREATION : sLocal = "Le champ '%0' n'a pas pu être créé" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Sous-formulaire '%0' non trouvé dans le formulaire parent '%1'" + 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" + Case "QUERY" : slocal = "Requête" + Case "FORM" : sLocal = "Formulaire" + Case "REPORT" : sLocal = "Rapport" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Champ" + Case "TEMPVAR" : sLocal = "Variable temporaire" + Case "COMMANDBAR" : sLocal = "Barre de commande" + Case "COMMANDBARCONTROL" : sLocal = "Elément de barre de commande" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "L'erreur #" + Case "ERROCCUR" : sLocal = "s'est produite" + Case "ERRLINE" : sLocal = "à la ligne" + Case "ERRIN" : sLocal = "dans" + Case "CALLTO" : sLocal = "un appel à la fonction" + Case "SAVECONSOLE" : sLocal = "Sauver console" + Case "SAVECONSOLEENTRIES" : sLocal = "Les entrées de la console ont été sauvées avec succès." + Case "QUITSHORT" : sLocal = "Quitter" + Case "QUIT" : sLocal = "Voulez-vous réellement quitter l'application ? Les données modifiées seront sauvées." + Case "ENTERING" : sLocal = "Entrée dans" + Case "EXITING" : sLocal = "Sortie de" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Gestion du tampon de la console et toutes ses entrées" + Case "DLGTRACE_TITLE" : sLocal = "Console" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Effacer la liste et redimensionner le tampon circulaire" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Définir le nombre maximum d'entrées" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Le texte peut être sélectionné, copié, ..." + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Le fichier journal est vide ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Annuler" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Effacer la liste" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Effacer la liste" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "N'enregistrer que les demandes de journalisation à partir du niveau indiqué" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Définir le niveau minimal d'enregistrement" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Valider" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Sélectionner un fichier et y vider le contenu actuel des traces enregistrées" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Vider dans fichier" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Taille actuelle de la liste" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Nombre actuel d'entrées:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Exporter le formulaire" + Case "DLGFORMAT_TITLE" : sLocal = "OutputTo" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format dans lequel le formulaire sera exporté" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Selectionner le format de sortie" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Valider votre choix" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Annuler" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select +'******************************************************** +'Translated by Iñigo Zuluaga +'******************************************************** + Case "ES" '(España) + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No se ha encontrado una conexión activa a una base de datos" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Faltan argumentos o no están inicializados" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "El argumento nr. %0 [Value = '%1'] no es válido" + Case "ERR" & ERRMAINFORM : sLocal = "El documento '%0' no contiene ningún formulario" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "No se ha identificado el formulario '%0' en el conjunto de formularios de la base de datos" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "No se ha encontrado el formulario '%0'" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "El formulario '%0' no está abierto" + Case "ERR" & ERRDFUNCTION : sLocal = "La ejecución de DFunction falló, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "El formulario '%0' no se puede abrir" + Case "ERR" & ERRPROPERTY : sLocal = "La propiedad '%0' no es aplicable en este contexto" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "El valor '%0' es inválido para la propiedad '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Fuera del rango de la matriz o tamaño incorrecto de la matriz para la propiedad '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Fuera del rango de la matriz" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "El argumento nr.%0 deberÃa ser una matriz" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "El control '%0' not found in parent (formulario, control de tabla or diálogo) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "No se ha encontrado un formulario o control activo" + Case "ERR" & ERRDATABASEFORM : sLocal = "El formulario '%0' no tiene datos subyacentes" + Case "ERR" & ERRFOCUSINGRID : sLocal = "No se ha encontrado el control '%0' en el control de tabla '%1'" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "No se ha encontrado un control de tabla en el formulario '%0'" + Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() tiene que ser precedido por una llamada exitosa de FindRecord(...)" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "Error SQL, instrución SQL = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' no encontrado" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' no se puede abrir" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' no se puede abrir" + Case "ERR" & ERRACTION : sLocal = "Acción no aplicable en este contexto" + Case "ERR" & ERRSENDMAIL : sLocal = "No se puede activar el servicio de correo" + Case "ERR" & ERRFORMYETOPEN : sLocal = "El formulario %0 ya está abierto" + Case "ERR" & ERRMETHOD : sLocal = "El método '%0' no es aplicable en este contexto" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Propiedad '%0' aplicable pero no inicializada" + Case "ERR" & ERRFILENOTCREATED : sLocal = "No se ha podido crear el archivo '%0'" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "No se ha encontrado el diálogo '%0' en las bibliotecas cargadas actualmente" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Diálogo desconocido" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "El diálogo ya está iniciado" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "El diálogo '%0' no está activo" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "El Recordset no suministra datos. La acción en el registro actual rechazada" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "El recorset se ha cerrado. Acción con el Recordset rechazada" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "Registro actual fuera de rango" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Acción rechazada en un recorset legible sólo hacia adelante o que no admita marcadores" + Case "ERR" & ERRFIELDNULL : sLocal = "El campo es nulo o vacÃo. Acción rechazada" + Case "ERR" & ERRFILEACCESS : sLocal = "Error durante el acceso al archivo '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "La longitud del campo (%0) excede la longitud máxima. Reemplazar por el método '%1'" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La consulta '%0' no es una consulta de acción" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "La base de datos, el Recordset o el Campo es de sólo lectura" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Error durante la secuencia de actualización del Recordset" + Case "ERR" & ERRNOTNULLABLE : sLocal = "El campo '%0' no puede contener un valor NULL" + Case "ERR" & ERRROWDELETED : sLocal = "La fila actual ha sido borrada por otro proceso o usuario" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "No se puede clonar un Recordset clonado" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Se ha borrado la consulta pre-existente '%0'" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Se ha borrado la tabla pre-existente '%0'" + Case "ERR" & ERRTABLECREATION : sLocal = "No se ha podido crear la Tabla '%0'" + Case "ERR" & ERRFIELDCREATION : sLocal = "No se ha podido crear el campo '%0'" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "No se ha encontrado el Subformulario '%0' en el subformulario padre '%1'" + 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" + Case "QUERY" : slocal = "Consulta" + Case "FORM" : sLocal = "Formulario" + Case "REPORT" : sLocal = "Informe" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Campo" + Case "TEMPVAR" : sLocal = "Variable temporal" + Case "COMMANDBAR" : sLocal = "Barra de comandos" + Case "COMMANDBARCONTROL" : sLocal = "Control de barra de comandos" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "Error #" + Case "ERROCCUR" : sLocal = "ocurrido" + Case "ERRLINE" : sLocal = "en lÃnea" + Case "ERRIN" : sLocal = "en" + Case "CALLTO" : sLocal = "una llamada a la función" + Case "SAVECONSOLE" : sLocal = "Guardar consola" + Case "SAVECONSOLEENTRIES" : sLocal = "Las entradas de la consola han sido guardadas correctamente." + Case "QUITSHORT" : sLocal = "Cerrar" + Case "QUIT" : sLocal = "Quieres realmente cerrar la aplicación? los datos cambiados se guardarán." + Case "ENTERING" : sLocal = "Entrando" + Case "EXITING" : sLocal = "Saliendo" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Gestión del buffer de la consola y sus entradas" + Case "DLGTRACE_TITLE" : sLocal = "Consola" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Limpiar la lista y redimensionar el buffer circular" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Definir el número máximo de entradas" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "El texto puede ser seleccionado, copiado, ..." + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- El archivo Histórico está vacÃo ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancelar" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Limpiar la lista" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Limpiar la lista" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "No registrar más que las peticiones de registro a partir de un nivel indicado" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Definir el nivel mÃnimo de registro" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validar" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "Aceptar" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Elegir un archivo y guardar en él el contenido de la lista actual" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Guardar en a archivo" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Tamaño actual de la lista" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Numero actual de entradas:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Exportar el formulario" + Case "DLGFORMAT_TITLE" : sLocal = "Exportar como" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Formato en el que será ser exportado el formulario" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Seleccionar el formato de salida" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validar su elección" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "Aceptar" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancelar" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select +'******************************************************** +'Translated by Gisbert Friege +'******************************************************** + Case "DE" + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Keine aktive Verbindung zu einer Datenbank gefunden" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Argumente fehlen oder sind nicht initialisiert" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument Nr. %0 [Wert = '%1'] ist ungültig" + Case "ERR" & ERRMAINFORM : sLocal = "Dokument '%0' enthält kein Formular" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Formular '%0' nicht bei den Datenbank-Formularen erkannt" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formular '%0' nicht gefunden" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "Formular '%0' ist zur Zeit nicht offen" + Case "ERR" & ERRDFUNCTION : sLocal = "DFunction Ausführung misslungen, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "Formular '%0' konnte nicht geöffnet werden" + Case "ERR" & ERRPROPERTY : sLocal = "Eigenschaft '%0' in diesem Kontext nicht anwendbar" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "Wert '%0' ist ungültig für die Eigenschaft '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Außerhalb des Array-Bereichs oder falsche Array-Größe für Eigenschaft '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Außerhalb des Array-Bereichs" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument Nr.%0 sollte ein Array sein" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Steuerelement '%0' nicht gefunden in parent (Formular, Tabelle oder Dialog) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "Kein aktives Formular oder Steuerelement gefunden" + Case "ERR" & ERRDATABASEFORM : sLocal = "Formular '%0' basiert nicht auf einem Datensatz" + Case "ERR" & ERRFOCUSINGRID : sLocal = "Steuerelement '%0' im Tabellen-Steuerelement '%1' nicht gefunden" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "Kein Tabellen-Steuerelement im Formular '%0' gefunden" + Case "ERR" & ERRFINDRECORD : sLocal = "Bei FindNext() muss ein erfolgreicher FindRecord(...)-Aufruf vorhergehen" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' nicht gefunden" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' konnte nicht geöffnet werden" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' konnte nicht geschlossen werden" + Case "ERR" & ERRACTION : sLocal = "Aktion in diesem Kontext nicht anwendbar" + Case "ERR" & ERRSENDMAIL : sLocal = "Email-Dienst konnte nicht aktiviert werden" + Case "ERR" & ERRFORMYETOPEN : sLocal = "Formular %0 ist schon offen" + Case "ERR" & ERRMETHOD : sLocal = "Methode '%0' in diesem Kontext nicht anwendbar" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Eigenschaft '%0' anwendbar aber nicht initialisiert" + Case "ERR" & ERRFILENOTCREATED : sLocal = "Datei '%0' konnte nicht erzeugt werden" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' nicht in den aktuell geladenen Bibliotheken gefunden" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unbekannt" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog schon gestartet" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' nicht aktiv" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "Datensatz ergab keine Daten. Aktion auf aktuellem Datensatz verweigert" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Datensatz wurde geschlossen. Datensatz-Aktion verweigert" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "Aktueller Datensatz außerhalb des Bereichs" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Aktion verweigert auf einem nur vorwärts lesbaren oder keine Textmarken unterstützenden Datensatz" + Case "ERR" & ERRFIELDNULL : sLocal = "Feld ist null oder leer. Aktion verweigert" + Case "ERR" & ERRFILEACCESS : sLocal = "Dateizugriffs-Fehler bei Datei '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "Feldlänge (%0) überschreitet die maximale Länge. Verwende stattdessen die Methode '%1'" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Abfrage '%0' ist keine Aktionsabfrage" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "Datenbank, Datensatz oder Feld kann nur gelesen werden" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Datensatz-Update Folgefehler" + Case "ERR" & ERRNOTNULLABLE : sLocal = "Feld '%0' darf keinen NULL-Wert haben" + Case "ERR" & ERRROWDELETED : sLocal = "Aktuelle Zeile wurde durch einen anderen Prozess oder Benutzer gelösch" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "Ein geklonter Datensatz kann nicht geklont werden" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Bereits vorhandene Abfrage '%0' wurde gelöscht" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Bereits vorhandene Tabelle '%0' wurde gelöscht" + Case "ERR" & ERRTABLECREATION : sLocal = "Tabelle '%0' konnte nicht erzeugt werden" + Case "ERR" & ERRFIELDCREATION : sLocal = "Feld '%0' konnte nicht erzeugt werden" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Unterformular '%0' nicht im Eltern-Formular '%1‘ gefunden" + Case "ERR" & ERRWINDOW : sLocal = "Aktuelles Fenster ist kein Dokument" + Case "ERR" & ERRCOMPATIBILITY : sLocal = "Feld '%0' konnte wegen inkompatibler Feldtypen der Datenbanksysteme nicht konvertiert werden" + Case "ERR" & ERRPRECISION : sLocal = "Feld '%0' konnte wegen fehlender Speicherkapazität nicht in den Datensatz #%1 geladen werden" + Case "ERR" & ERRMODULENOTFOUND : sLocal = "Modul '%0' nicht gefunden in den aktuell geladen Bibliotheken" + Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Prozedur '%0' im Modul '%1' nicht gefunden" + '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Objekt" + Case "TABLE" : sLocal = "Tabelle" + Case "QUERY" : slocal = "Abfrage" + Case "FORM" : sLocal = "Formular" + Case "REPORT" : sLocal = "Report" + Case "RECORDSET" : sLocal = "Datensatz" + Case "FIELD" : sLocal = "Feld" + Case "TEMPVAR" : sLocal = "Temporäre Variable" + Case "COMMANDBAR" : sLocal = "Befehlsleiste" + Case "COMMANDBARCONTROL" : sLocal = "Befehlsleisten-Steuerelement" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "Error #" + Case "ERROCCUR" : sLocal = "aufgetreten" + Case "ERRLINE" : sLocal = "in Zeile" + Case "ERRIN" : sLocal = "in" + Case "CALLTO" : sLocal = "ein Funktionsaufruf" + Case "SAVECONSOLE" : sLocal = "Konsoleneingaben sichern" + Case "SAVECONSOLEENTRIES" : sLocal = "Die Konsoleneingaben wurden erfolgreich gesichert." + Case "QUITSHORT" : sLocal = "Beenden" + Case "QUIT" : sLocal = "Wollen Sie wirklich die Anwendung beenden? Geänderte Daten werden gesichert." + Case "ENTERING" : sLocal = "Beginne mit" + Case "EXITING" : sLocal = "Verlasse" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Verwalte den Konsolenpuffer und seine Eingaben" + Case "DLGTRACE_TITLE" : sLocal = "Konsole" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Leere die Liste und ändere die Größe des Umlaufpuffers" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Setze maximale Anzahl von Eingaben" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text kann ausgewählt, kopiert, ... werden" + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log Datei ist leer ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Abbrechen" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Leere die Liste" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Leere die Liste" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Registriere nur Logging-Anfragen oberhalb des gegebenen Levels" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Setze minimalen Fehlerbehandlungs-Level" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Ãœbernehmen" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Wähle eine Datei und speichere darin den aktuellen Listeninhalt" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Ausgabe in Datei" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Aktuelle Länge der Liste" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Aktuelle Anzahl von Einträgen:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Exportiere das Formular" + Case "DLGFORMAT_TITLE" : sLocal = "Export" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format, in dem das Formular exportiert werden soll" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Wähle das Ausgabe-Format" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Auswahl übernehmen" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Abbrechen" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select +REM ******************************************************************************************************************************************* +REM *** *** +REM *** ANY OTHER LANGUAGE TO BE INSERTED HERE *** +REM *** *** +REM ******************************************************************************************************************************************* + Case Else + sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select + +Exit_Function: + _Getlabel = sLocal + Exit Function +Error_Function: + sLocal = psShortLabel + GoTo Exit_Function +End Function ' GetLabel V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetLabelArray(ByVal pvShortlabel As Variant, Optional ByVal psLocale As String) As Variant +' Return the localized label corresponding with the ShortLabel array of strings + + If IsMissing(psLocale) Then psLocale = UCase(Left(_GetLocale(), 2)) Else psLocale = UCase(psLocale) + On Local Error Goto Error_Function + +Dim vLocal() As Variant, i As integer + vLocal = Array() + + If Not IsArray(pvShortLabel) Then + vLocal = _GetLabel(pvShortLabel, psLocale) + Goto Exit_Function + End If + + ReDim vLocal(LBound(pvShortLabel) To UBound(pvShortlabel)) + For i = LBound(pvShortLabel) To UBound(pvShortlabel) + vLocal(i) = _GetLabel(pvShortLabel(i), psLocale) + Next i + +Exit_Function: + _GetlabelArray = vLocal() + Exit Function +Error_Function: + vLocal = Array() + GoTo Exit_Function +End Function ' GetLabelArray V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetLocale() as String +'Return OO localization +'Derived from Tools library + +Dim oLocale as Object + oLocale = _GetRegistryKeyContent("org.openoffice.Setup/L10N") + _GetLocale = oLocale.getByName("ooLocale") +End Function ' GetLocale V0.8.9 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Methods.xba b/wizards/source/access2base/Methods.xba new file mode 100644 index 000000000..7f809c6c1 --- /dev/null +++ b/wizards/source/access2base/Methods.xba @@ -0,0 +1,300 @@ +<?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="Methods" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AddItem(Optional pvBox As Variant, ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean +' Add an item in a Listbox + + Utils._SetCalledSub("AddItem") + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvBox) Or IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvIndex) Then pvIndex = -1 + If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function + + AddItem = pvBox.AddItem(pvItem, pvIndex) + +Exit_Function: + Utils._ResetCalledSub("AddItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "AddItem", Erl) + AddItem = False + GoTo Exit_Function +End Function ' AddItem V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(Optional pvObject As Variant, ByVal Optional pvProperty As Variant) As Boolean +' Return True if pvObject has a valid property called pvProperty (case-insensitive comparison !) + +Dim vPropertiesList As Variant + + Utils._SetCalledSub("hasProperty") + If IsMissing(pvObject) Or IsMissing(pvProperty) Then Call _TraceArguments() + + hasProperty = False + If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _ + , OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _ + )) Then Goto Exit_Function + If Not Utils._CheckArgument(pvProperty, 2, vbString) Then Goto Exit_Function + + hasProperty = pvObject.hasProperty(pvProperty) + +Exit_Function: + Utils._ResetCalledSub("hasProperty") + Exit Function +End Function ' hasProperty V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move(Optional pvObject As Object _ + , ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute Move method + Utils._SetCalledSub("Move") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + Move = False + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + If IsMissing(pvLeft) Then Call _TraceArguments() + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + + Move = pvObject.Move(pvLeft, pvTop, pvWidth, pvHeight) + +Exit_Function: + Utils._ResetCalledSub("Move") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Move", Erl) + GoTo Exit_Function +End Function ' Move V.0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenHelpFile() +' Open the help file from the Help menu (IDE only) +Const cstHelpFile = "http://www.access2base.com/access2base.html" + + On Local Error Resume Next + Call _ShellExecute(cstHelpFile) + +End Function ' OpenHelpFile V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperties As Variant, oCounter As Variant, opProperty As Variant +Dim vPropertiesList() As Variant + + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments() + Utils._SetCalledSub("Properties") + + Set vProperties = Nothing + If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _ + , OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _ + )) Then Goto Exit_Function + + If IsMissing(pvIndex) Then vProperties = pvObject.Properties Else vProperties = pvObject.Properties(pvIndex) + +Exit_Function: + Set Properties = vProperties + Utils._ResetCalledSub("Properties") + Exit Function +End Function ' Properties V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Refresh(Optional pvObject As Variant) As Boolean +' Refresh data with its most recent value in the database in a form or subform + Utils._SetCalledSub("Refresh") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + Refresh = False + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + + Refresh = pvObject.Refresh() + +Exit_Function: + Utils._ResetCalledSub("Refresh") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Refresh", Erl) + GoTo Exit_Function +End Function ' Refresh V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveItem(Optional pvBox As Variant,ByVal Optional pvIndex) As Boolean +' Remove an item from a Listbox +' Index may be a string value or an index-position + + Utils._SetCalledSub("RemoveItem") + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvBox) Or IsMissing(pvIndex) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function + + RemoveItem = pvBox.RemoveItem(pvIndex) + +Exit_Function: + Utils._ResetCalledSub("RemoveItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "RemoveItem", Erl) + RemoveItem = False + GoTo Exit_Function +End Function ' RemoveItem V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery(Optional pvObject As Variant) As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("Requery") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL, OBJSUBFORM)) Then Goto Exit_Function + + Requery = pvObject.Requery() + +Exit_Function: + Utils._ResetCalledSub("Requery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Requery", Erl) + GoTo Exit_Function +End Function ' Requery V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetFocus(Optional pvObject As Variant) As Boolean +' Execute SetFocus method + Utils._SetCalledSub("setFocus") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL)) Then Goto Exit_Function + + SetFocus = pvObject.setFocus() + +Exit_Function: + Utils._ResetCalledSub("SetFocus") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SetFocus", Erl) + Goto Exit_Function +Error_Grid: + TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name)) + Goto Exit_Function +End Function ' SetFocus V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _OptionGroup(ByVal pvGroupName As Variant _ + , ByVal psParentType As String _ + , poComponent As Object _ + , poParent As Object _ + ) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name + + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + Set _OptionGroup = Nothing + + If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function + +Dim ogGroup As Variant, i As Integer, j As Integer, bFound As Boolean +Dim vOptionButtons() As Variant, sGroupName As String +Dim lXY() As Long, iIndex() As Integer ' Two indexes X-Y coordinates +Dim oView As Object, oDatabaseForm As Object, vControls As Variant + +Const cstPixels = 10 ' Tolerance on coordinates when drawn approximately + + bFound = False + Select Case psParentType + Case CTLPARENTISFORM + 'poParent is a forms collection, find the appropriate database form + For i = 0 To poParent.Count - 1 + Set oDatabaseForm = poParent.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + oDatabaseForm.getGroup(j, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For + End If + Next j + If bFound Then Exit For + End If + If bFound Then Exit For + Next i + Case CTLPARENTISSUBFORM + 'poParent is already a database form + Set oDatabaseForm = poParent + For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + oDatabaseForm.getGroup(j, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For + End If + Next j + End Select + + If bFound Then + + ogGroup = New Optiongroup + ogGroup._This = ogGroup + ogGroup._Name = sGroupName + ogGroup._ButtonsGroup = vOptionButtons + ogGroup._Count = UBound(vOptionButtons) + 1 + ogGroup._ParentType = psParentType + ogGroup._MainForm = oDatabaseForm.Name + Set ogGroup._ParentComponent = poComponent + + ReDim lXY(1, ogGroup._Count - 1) + ReDim iIndex(ogGroup._Count - 1) + For i = 0 To ogGroup._Count - 1 ' Find the position of each radiobutton + Set oView = poComponent.CurrentController.getControl(ogGroup._ButtonsGroup(i)) + lXY(0, i) = oView.PosSize.X + lXY(1, i) = oView.PosSize.Y + Next i + For i = 0 To ogGroup._Count - 1 ' Sort them on XY coordinates + If i = 0 Then + iIndex(0) = 0 + Else + iIndex(i) = i + For j = i - 1 To 0 Step -1 + If lXY(1, i) - lXY(1, j) < - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) <= cstPixels And lXY(0, i) - lXY(0, j) < - cstPixels ) Then + iIndex(i) = iIndex(j) + iIndex(j) = iIndex(j) + 1 + End If + Next j + End If + Next i + ogGroup._ButtonsIndex = iIndex() + + Set _OptionGroup = ogGroup + + Else + + Set _OptionGroup = Nothing + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName)) + + End If + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err,"_OptionGroup", Erl) + GoTo Exit_Function +End Function ' _OptionGroup V1.1.0 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Module.xba b/wizards/source/access2base/Module.xba new file mode 100644 index 000000000..d3095d645 --- /dev/null +++ b/wizards/source/access2base/Module.xba @@ -0,0 +1,722 @@ +<?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 _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +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 + Set _This = Nothing + Set _Parent = Nothing + _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 otherwise + +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, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, 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 name + +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 = """[^""\n]*""" +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, 4)) = "REM " Or UCase(Left(sMatch, 4)) = "REM" & vbTab Or UCase(Left(sMatch, 4)) = "REM" & vbNewLine + 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/OptionGroup.xba b/wizards/source/access2base/OptionGroup.xba new file mode 100644 index 000000000..f4b749ef6 --- /dev/null +++ b/wizards/source/access2base/OptionGroup.xba @@ -0,0 +1,315 @@ +<?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="OptionGroup" 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 FORM +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _ParentType As String +Private _ParentComponent As Object +Private _MainForm As String +Private _DocEntry As Integer +Private _DbEntry As Integer +Private _ButtonsGroup() As Variant +Private _ButtonsIndex() As Variant +Private _Count As Long + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJOPTIONGROUP + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _ParentType = "" + _ParentComponent = Nothing + _DocEntry = -1 + _DbEntry = -1 + _ButtonsGroup = Array() + _ButtonsIndex = Array() + _Count = 0 +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 ----------------------------------------------------------------------------------------------------------------------- +Property Get Count() As Variant + Count = _PropertyGet("Count") +End Property ' Count (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("OptionGroup.Controls") + +Dim ocControl As Variant, iArgNr As Integer, i As Integer +Dim oCounter As Object + + Set ocControl = Nothing + + If IsMissing(pvIndex) Then ' No argument, return Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + oCounter._Count = _Count + Set Controls = oCounter + Goto Exit_Function + End If + + If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2 + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < 0 Or pvIndex > _Count - 1 Then Goto Trace_Error_Index + + ' Start building the ocControl object + ' Determine exact name + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISGROUP + + ocControl._Shortcut = "" + For i = 0 To _Count - 1 + If _ButtonsIndex(i) = pvIndex Then + Set ocControl.ControlModel = _ButtonsGroup(i) + Select Case _ParentType + Case CTLPARENTISDIALOG : ocControl._Name = _ButtonsGroup(i).Name + Case Else : ocControl._Name = _Name ' OptionGroup and individual radio buttons share the same name + End Select + ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() + Exit For + End If + Next i + ocControl._FormComponent = _ParentComponent + ocControl._ClassId = acRadioButton + Select Case _ParentType + Case CTLPARENTISDIALOG : Set ocControl.ControlView = _ParentComponent.getControl(ocControl._Name) + Case Else : Set ocControl.ControlView = _ParentComponent.CurrentController.getControl(ocControl.ControlModel) + End Select + + ocControl._Initialize() + ocControl._DocEntry = _DocEntry + ocControl._DbEntry = _DbEntry + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("OptionGroup.Controls") + Exit Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "OptionGroup.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("OptionGroup.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("OptionGroup.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("OptionGroup.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("OptionGroup.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("Count", "Name", "ObjectType", "Value") + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("OptionGroup.get" & psProperty) + +'Execute +Dim oDatabase As Object, vBookmark As Variant +Dim iValue As Integer, i As Integer + _PropertyGet = EMPTY + Select Case UCase(psProperty) + Case UCase("Count") + _PropertyGet = _Count + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + iValue = -1 + For i = 0 To _Count - 1 ' Find the selected RadioButton + If _ButtonsGroup(i).State = 1 Then + iValue = _ButtonsIndex(i) + Exit For + End If + Next i + _PropertyGet = iValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("OptionGroup.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "OptionGroup._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("OptionGroup.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim i As Integer, iRadioIndex As Integer, oModel As Object, iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("Value") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > _Count - 1 Then Goto Trace_Error_Value + For i = 0 To _Count - 1 + _ButtonsGroup(i).State = 0 + If _ButtonsIndex(i) = pvValue Then iRadioIndex = i + Next i + _ButtonsGroup(iRadioIndex).State = 1 + Set oModel = _ButtonsGroup(iRadioIndex) + If Utils._hasUNOProperty(oModel, "DataField") Then + If Not IsNull(oModel.Datafield) And Not IsEmpty(oModel.Datafield) Then + If oModel.Datafield <> "" And Utils._hasUNOMethod(oModel, "commit") Then oModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM] + End If + End If + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("OptionGroup.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "OptionGroup._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/PropertiesGet.xba b/wizards/source/access2base/PropertiesGet.xba new file mode 100644 index 000000000..332eaaa2e --- /dev/null +++ b/wizards/source/access2base/PropertiesGet.xba @@ -0,0 +1,1120 @@ +<?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="PropertiesGet" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAbsolutePosition(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAbsolutePosition") + getAbsolutePosition = PropertiesGet._getProperty(pvObject, "AbsolutePosition") +End Function ' getAbsolutePosition + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAllowAdditions(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowAdditions") + getAllowAdditions = PropertiesGet._getProperty(pvObject, "AllowAdditions") +End Function ' getAllowAdditions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAllowDeletions(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowDeletions") + getAllowDeletions = PropertiesGet._getProperty(pvObject, "AllowDeletions") +End Function ' getAllowDeletions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAllowEdits(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowEdits") + getAllowEdits = PropertiesGet._getProperty(pvObject, "AllowEdits") +End Function ' getAllowEdits + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBackColor(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBackColor") + getBackColor = PropertiesGet._getProperty(pvObject, "BackColor") +End Function ' getBackColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBeginGroup(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBeginGroup") + getBeginGroup = PropertiesGet._getProperty(pvObject, "BeginGroup") +End Function ' getBeginGroup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBOF(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBOF") + getBOF = PropertiesGet._getProperty(pvObject, "BOF") +End Function ' getBOF + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBookmark(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBookmark") + getBookmark = PropertiesGet._getProperty(pvObject, "Bookmark") +End Function ' getBookmark + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBookmarkable(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBookmarkable") + getBookmarkable = PropertiesGet._getProperty(pvObject, "Bookmarkable") +End Function ' getBookmarkable + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBorderColor(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBorderColor") + getBorderColor = PropertiesGet._getProperty(pvObject, "BorderColor") +End Function ' getBorderColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBorderStyle(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBorderStyle") + getBorderStyle = PropertiesGet._getProperty(pvObject, "BorderStyle") +End Function ' getBorderStyle + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBuiltIn(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBuiltIn") + getBuiltIn = PropertiesGet._getProperty(pvObject, "BuiltIn") +End Function ' getBuiltIn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getButtonLeft(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonLeft") + getButtonLeft = PropertiesGet._getProperty(pvObject, "ButtonLeft") +End Function ' getButtonLeft + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getButtonMiddle(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonMiddle") + getButtonMiddle = PropertiesGet._getProperty(pvObject, "ButtonMiddle") +End Function ' getButtonMiddle + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getButtonRight(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonRight") + getButtonRight = PropertiesGet._getProperty(pvObject, "ButtonRight") +End Function ' getButtonRight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCancel(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCancel") + getCancel = PropertiesGet._getProperty(pvObject, "Cancel") +End Function ' getCancel + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCaption(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCaption") + getCaption = PropertiesGet._getProperty(pvObject, "Caption") +End Function ' getCaption + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getClickCount(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getClickCount") + getClickCount = PropertiesGet._getProperty(pvObject, "ClickCount") +End Function ' getClickCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getContextShortcut(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getContextShortcut") + getContextShortcut = PropertiesGet._getProperty(pvObject, "ContextShortcut") +End Function ' getContextShortcut + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getControlSource(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlSource") + getControlSource = PropertiesGet._getProperty(pvObject, "ControlSource") +End Function ' getControlSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getControlTipText(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlTipText") + getControlTipText = PropertiesGet._getProperty(pvObject, "ControlTipText") +End Function ' getControlTipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getControlType(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlType") + getControlType = PropertiesGet._getProperty(pvObject, "ControlType") +End Function ' getControlType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCount(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCount") + getCount = PropertiesGet._getProperty(pvObject, "Count") +End Function ' getCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCurrentRecord(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCurrentRecord") + getCurrentRecord = PropertiesGet._getProperty(pvObject, "CurrentRecord") +End Function ' getCurrentRecord + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDataType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDataType") + getDataType = PropertiesGet._getProperty(pvObject, "DataType") +End Function ' getDataType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDbType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDbType") + getDbType = PropertiesGet._getProperty(pvObject, "DbType") +End Function ' getDbType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDefault(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDefault") + getDefault = PropertiesGet._getProperty(pvObject, "Default") +End Function ' getDefault + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDefaultValue(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDefaultValue") + getDefaultValue = PropertiesGet._getProperty(pvObject, "DefaultValue") +End Function ' getDefaultValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDescription(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDescription") + getDescription = PropertiesGet._getProperty(pvObject, "Description") +End Function ' getDescription + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEditMode(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEditMode") + getEditMode = PropertiesGet._getProperty(pvObject, "EditMode") +End Function ' getEditMode + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEnabled(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEnabled") + getEnabled = PropertiesGet._getProperty(pvObject, "Enabled") +End Function ' getEnabled + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEOF(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEOF") + getEOF = PropertiesGet._getProperty(pvObject, "EOF") +End Function ' getEOF + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEventName(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEventName") + getEventName = PropertiesGet._getProperty(pvObject, "EventName") +End Function ' getEventName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEventType(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEventType") + getEventType = PropertiesGet._getProperty(pvObject, "EventType") +End Function ' getEventType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFieldSize(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFieldSize") + getFieldSize = PropertiesGet._getProperty(pvObject, "FieldSize") +End Function ' getFieldSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFilter(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFilter") + getFilter = PropertiesGet._getProperty(pvObject, "Filter") +End Function ' getFilter + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFilterOn(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFilterOn") + getFilterOn = PropertiesGet._getProperty(pvObject, "FilterOn") +End Function ' getFilterOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFocusChangeTemporary(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFocusChangeTemporary") + getFocusChangeTemporary = PropertiesGet._getProperty(pvObject, "FocusChangeTemporary") +End Function ' getFocusChangeTemporary + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontBold(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontBold") + getFontBold = PropertiesGet._getProperty(pvObject, "FontBold") +End Function ' getFontBold + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontItalic(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontItalic") + getFontItalic = PropertiesGet._getProperty(pvObject, "FontItalic") +End Function ' getFontItalic + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontName(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontName") + getFontName = PropertiesGet._getProperty(pvObject, "FontName") +End Function ' getFontName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontSize(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontSize") + getFontSize = PropertiesGet._getProperty(pvObject, "FontSize") +End Function ' getFontSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontUnderline(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontUnderline") + getFontUnderline = PropertiesGet._getProperty(pvObject, "FontUnderline") +End Function ' getFontUnderline + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontWeight(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontWeight") + getFontWeight = PropertiesGet._getProperty(pvObject, "FontWeight") +End Function ' getFontWeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getForm(Optional pvObject As Variant) As Variant ' Return Subform pseudo + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getForm") + getForm = PropertiesGet._getProperty(pvObject, "Form") +End Function ' getForm + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFormat(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFormat") + getFormat = PropertiesGet._getProperty(pvObject, "Format") +End Function ' getFormat + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getHeight(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getHeight") + getHeight = PropertiesGet._getProperty(pvObject, "Height") +End Function ' getHeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getForeColor(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getForeColor") + getForeColor = PropertiesGet._getProperty(pvObject, "ForeColor") +End Function ' getForeColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getIsLoaded(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getIsLoaded") + getIsLoaded = PropertiesGet._getProperty(pvObject, "IsLoaded") +End Function ' getIsLoaded + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getItemData(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getItemData") + If IsMissing(pvIndex) Then + getItemData = PropertiesGet._getProperty(pvObject, "ItemData") + Else + getItemData = PropertiesGet._getProperty(pvObject, "ItemData", pvIndex) + End If +End Function ' getItemData + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyAlt(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyAlt") + getKeyAlt = PropertiesGet._getProperty(pvObject, "KeyAlt") +End Function ' getKeyAlt + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyChar(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyChar") + getKeyChar = PropertiesGet._getProperty(pvObject, "KeyChar") +End Function ' getKeyChar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyCode(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyCode") + getKeyCode = PropertiesGet._getProperty(pvObject, "KeyCode") +End Function ' getKeyCode + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyCtrl(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyCtrl") + getKeyCtrl = PropertiesGet._getProperty(pvObject, "KeyCtrl") +End Function ' getKeyCtrl + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyFunction(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyFunction") + getKeyFunction = PropertiesGet._getProperty(pvObject, "KeyFunction") +End Function ' getKeyFunction + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyShift(pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyShift") + getKeyShift = PropertiesGet._getProperty(pvObject, "KeyShift") +End Function ' getKeyShift + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getLinkChildFields(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLinkChildFields") + If IsMissing(pvObject) Then + getLinkChildFields = PropertiesGet._getProperty(pvObject, "LinkChildFields") + Else + getLinkChildFields = PropertiesGet._getProperty(pvObject, "LinkChildFields", pvIndex) + End If +End Function ' getLinkChildFields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getLinkMasterFields(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLinkMasterFields") + If IsMissing(pvIndex) Then + getLinkMasterFields = PropertiesGet._getProperty(pvObject, "LinkMasterFields") + Else + getLinkMasterFields = PropertiesGet._getProperty(pvObject, "LinkMasterFields", pvIndex) + End If +End Function ' getLinkMasterFields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getListCount(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getListCount") + getListCount = PropertiesGet._getProperty(pvObject, "ListCount") +End Function ' getListCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getListIndex(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getListIndex") + getListIndex = PropertiesGet._getProperty(pvObject, "ListIndex") +End Function ' getListIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getLocked(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLocked") + getLocked = PropertiesGet._getProperty(pvObject, "Locked") +End Function ' getLocked + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getMultiSelect(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getMultiSelect") + getMultiSelect = PropertiesGet._getProperty(pvObject, "MultiSelect") +End Function ' getMultiSelect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getName(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getName") + getName = PropertiesGet._getProperty(pvObject, "Name") +End Function ' getName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getObjectType(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getObjectType") + getObjectType = PropertiesGet._getProperty(pvObject, "ObjectType") +End Function ' getObjectType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOpenArgs(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOpenArgs") + getOpenArgs = PropertiesGet._getProperty(pvObject, "OpenArgs") +End Function ' getOpenArgs + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOptionGroup(Optional pvObject As Variant, pvName As variant) As Variant +' Return an OptionGroup object based on its name + + Utils._SetCalledSub("getOptionGroup") + If IsMissing(pvObject) Or IsMissing(pvName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvName, 2, vbString) Then Goto Exit_Function + + getOptionGroup = pvObject.OptionGroup(pvName) + +Exit_Function: + Utils._ResetCalledSub("getOptionGroup") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "getOptionGroup", Erl) + GoTo Exit_Function +End Function ' getOptionGroup V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOptionValue(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOptionValue") + getOptionValue = PropertiesGet._getProperty(pvObject, "OptionValue") +End Function ' getOptionValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOrderBy(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOrderBy") + getOrderBy = PropertiesGet._getProperty(pvObject, "OrderBy") +End Function ' getOrderBy + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOrderByOn(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOrderByOn") + getOrderByOn = PropertiesGet._getProperty(pvObject, "OrderByOn") +End Function ' getOrderByOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getPage(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getPage") + getPage = PropertiesGet._getProperty(pvObject, "Page") +End Function ' getPage V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getParent(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getParent") + getParent = PropertiesGet._getProperty(pvObject, "Parent") +End Function ' getParent V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional pvItem As Variant, Optional ByVal pvProperty As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return property value of object pvItem, and psProperty property name + Utils._SetCalledSub("getProperty") + If IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvProperty) Then Call _TraceArguments() + If IsMissing(pvIndex) Then getProperty = PropertiesGet._getProperty(pvItem, pvProperty) Else getProperty = PropertiesGet._getProperty(pvItem, pvProperty, pvIndex) + Utils._ResetCalledSub("getProperty") +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecommendation(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecommendation") + getRecommendation = PropertiesGet._getProperty(pvObject, "Recommendation") +End Function ' getRecommendation + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecordCount(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordCount") + getRecordCount = PropertiesGet._getProperty(pvObject, "RecordCount") +End Function ' getRecordCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecordset(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordset") + getRecordset = PropertiesGet._getProperty(pvObject, "Recordset") +End Function ' getRecordset V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecordSource(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordSource") + getRecordSource = PropertiesGet._getProperty(pvObject, "RecordSource") +End Function ' getRecordSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRequired(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRequired") + getRequired = PropertiesGet._getProperty(pvObject, "Required") +End Function ' getRequired + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRowChangeAction(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowChangeAction") + getRowChangeAction = PropertiesGet._getProperty(pvObject, "RowChangeAction") +End Function ' getRowChangeAction + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRowSource(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowSource") + getRowSource = PropertiesGet._getProperty(pvObject, "RowSource") +End Function ' getRowSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRowSourceType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowSourceType") + getRowSourceType = PropertiesGet._getProperty(pvObject, "RowSourceType") +End Function ' getRowSourceType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSelected(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSelected") + If IsMissing(pvIndex) Then + getSelected = PropertiesGet._getProperty(pvObject, "Selected") + Else + getSelected = PropertiesGet._getProperty(pvObject, "Selected", pvIndex) + End If +End Function ' getSelected + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSize(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSize") + getSize = PropertiesGet._getProperty(pvObject, "Size") +End Function ' getSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSource(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSource") + getSource = PropertiesGet._getProperty(pvObject, "Source") +End Function ' getSource V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSourceField(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSourceField") + getSourceField = PropertiesGet._getProperty(pvObject, "SourceField") +End Function ' getSourceField + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSourceTable(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSourceTable") + getSourceTable = PropertiesGet._getProperty(pvObject, "SourceTable") +End Function ' getSourceTable + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSpecialEffect(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSpecialEffect") + getSpecialEffect = PropertiesGet._getProperty(pvObject, "SpecialEffect") +End Function ' getSpecialEffect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSubType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubType") + getSubType = PropertiesGet._getProperty(pvObject, "SubType") +End Function ' getSubType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSubComponentName(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubComponentName") + getSubComponentName = PropertiesGet._getProperty(pvObject, "SubComponentName") +End Function ' getSubComponentName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSubComponentType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubComponentType") + getSubComponentType = PropertiesGet._getProperty(pvObject, "SubComponentType") +End Function ' getSubComponentType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTabIndex(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTabIndex") + getTabIndex = PropertiesGet._getProperty(pvObject, "TabIndex") +End Function ' getTabIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTabStop(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTabStop") + getTabStop = PropertiesGet._getProperty(pvObject, "TabStop") +End Function ' getTabStop + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTag(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTag") + getTag = PropertiesGet._getProperty(pvObject, "Tag") +End Function ' getTag + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getText(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getText") + getText = PropertiesGet._getProperty(pvObject, "Text") +End Function ' getText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTextAlign(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTextAlign") + getTextAlign = PropertiesGet._getProperty(pvObject, "TextAlign") +End Function ' getTextAlign + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTooltipText(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTooltipText") + getTooltipText = PropertiesGet._getProperty(pvObject, "TooltipText") +End Function ' getTooltipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTripleState(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTripleState") + getTripleState = PropertiesGet._getProperty(pvObject, "TripleState") +End Function ' getTripleState + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTypeName(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTypeName") + getTypeName = PropertiesGet._getProperty(pvObject, "TypeName") +End Function ' getTypeName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getVisible(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getVisible") + getVisible = PropertiesGet._getProperty(pvObject, "Visible") +End Function ' getVisible + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getWidth(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getWdth") + getWidth = PropertiesGet._getProperty(pvObject, "Width") +End Function ' getWidth + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getXPos(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getXPos") + getXPos = PropertiesGet._getProperty(pvObject, "XPos") +End Function ' getXPos + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getYPos(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getYPos") + getYPos = PropertiesGet._getProperty(pvObject, "YPos") +End Function ' getYPos + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _getProperty(pvItem As Variant, ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant +' Return property value of the psProperty property name within object pvItem + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("get" & psProperty) + _getProperty = Nothing + +'pvItem must be an object and have the requested property + If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function + If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error +'Check Index argument + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 3, Utils._AddNumeric()) Then Goto Exit_Function + End If +'Execute + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.AbsolutePosition + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.AllowAdditions + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.AllowDeletions + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.AllowEdits + Case UCase("BackColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BackColor + Case UCase("BeginGroup") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BeginGroup + Case UCase("BOF") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.BOF + Case UCase("Bookmark") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function + _getProperty = pvItem.Bookmark + Case UCase("Bookmarkable") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.Bookmarkable + Case UCase("BorderColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BorderColor + Case UCase("BorderStyle") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BorderStyle + Case UCase("BuiltIn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.BuiltIn + Case UCase("ButtonLeft") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ButtonLeft + Case UCase("ButtonMiddle") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ButtonMiddle + Case UCase("ButtonRight") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ButtonRight + Case UCase("Cancel") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Cancel + Case UCase("Caption") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Caption + Case UCase("ClickCount") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ClickCount + Case UCase("ContextShortcut") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ContextShortcut + Case UCase("ControlSource") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ControlSource + Case UCase("ControlTipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ControlTipText + Case UCase("ControlType") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ControlType + Case UCase("Count") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCOLLECTION,OBJOPTIONGROUP)) Then Goto Exit_Function + _getProperty = pvItem.Count + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.CurrentRecord + Case UCase("DataType") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.DataType + Case UCase("DbType") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.DbType + Case UCase("Default") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Default + Case UCase("DefaultValue") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function + _getProperty = pvItem.DefaultValue + Case UCase("Description") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.Description + Case UCase("EditMode") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.EditMode + Case UCase("Enabled") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Enabled + Case UCase("EOF") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.EOF + Case UCase("EventName") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.EventName + Case UCase("EventType") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.EventType + Case UCase("FieldSize") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.FieldSize + Case UCase("Filter") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function + _getProperty = pvItem.Filter + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.FilterOn + Case UCase("FocusChangeTemporary") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.FocusChangeTemporary + Case UCase("FontBold") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontBold + Case UCase("FontItalic") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontItalic + Case UCase("FontName") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontName + Case UCase("FontSize") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontSize + Case UCase("FontUnderline") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontUnderline + Case UCase("FontWeight") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontWeight + Case UCase("ForeColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ForeColor + Case UCase("Form") + If Not Utils._CheckArgument(pvItem, 1, CTLSUBFORM) Then Goto Exit_Function + _getProperty = pvItem.Form + Case UCase("Format") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Format + Case UCase("Height") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + _getProperty = pvItem.Height + Case UCase("Index") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Index + Case UCase("IsLoaded") + If Not Utils._CheckArgument(pvItem, 1, OBJFORM) Then Goto Exit_Function + _getProperty = pvItem.IsLoaded + Case UCase("ItemData") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.ItemData Else _getProperty = pvItem.ItemData(pvIndex) + Case UCase("KeyAlt") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyAlt + Case UCase("KeyChar") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyChar + Case UCase("KeyCode") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyCode + Case UCase("KeyCtrl") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyCtrl + Case UCase("KeyFunction") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyFunction + Case UCase("KeyShift") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyShift + Case UCase("LinkChildFields") + If Not Utils._CheckArgument(pvItem, 1, OBJSUBFORM) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.LinkChildFields Else _getProperty = pvItem.LinkChildFields(pvIndex) + Case UCase("LinkMasterFields") + If Not Utils._CheckArgument(pvItem, 1, OBJSUBFORM) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.LinkMasterFields Else _getProperty = pvItem.LinkMasterFields(pvIndex) + Case UCase("ListCount") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ListCount + Case UCase("ListIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ListIndex + Case UCase("Locked") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsNull(pvItem.Locked) Then Goto Trace_Error + _ge ExitProperty = pvItem.Locked + Case UCase("MultiSelect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.MultiSelect + Case UCase("Name") + If Not Utils._CheckArgument(pvItem, 1, _ + Array(OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJDIALOG, OBJTABLEDEF, OBJRECORDSET, OBJFIELD, OBJTEMPVAR, OBJCOMMANDBAR) _ + ) Then Goto Exit_Function + _getProperty = pvItem.Name + Case UCase("ObjectType") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJDATABASE, OBJCOLLECTION, OBJFORM, OBJDIALOG, OBJSUBFORM, OBJCONTROL _ + , OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY, OBJRECORDSET, OBJTABLEDEF, OBJFIELD, OBJTEMPVAR _ + , OBJCOMMANDBAR, OBJCOMMANDBARCONTROL) _ + ) Then Goto Exit_Function + _getProperty = pvItem.ObjectType + Case UCase("OnAction") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.OnAction + Case UCase("OpenArgs") + If Not Utils._CheckArgument(pvItem, 1, OBJFORM) Then Goto Exit_Function + _getProperty = pvItem.OpenArgs + Case UCase("OptionValue") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.OptionValue + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.OrderBy + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.OrderByOn + Case UCase("Page") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Page + Case UCase("Parent") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJSUBFORM, OBJCONTROL, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Parent + Case UCase("Recommendation") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.Recommendation + Case UCase("RecordCount") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.RecordCount + Case UCase("Recordset") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.Recordset + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.RecordSource + Case UCase("Required") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Required + Case UCase("RowChangeAction") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.RowChangeAction + Case UCase("RowSource") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.RowSource + Case UCase("RowSourceType") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.RowSourceType + Case UCase("Selected") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.Selected Else _getProperty = pvItem.Selected(pvIndex) + Case UCase("Size") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.Size + Case UCase("Source") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.Source + Case UCase("SourceTable") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.SourceTable + Case UCase("SourceField") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.SourceField + Case UCase("SpecialEffect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.SpecialEffect + Case UCase("SubComponentName") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.SubComponentName + Case UCase("SubComponentType") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.SubComponentType + Case UCase("SubType") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.SubType + Case UCase("TabIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TabIndex + Case UCase("TabStop") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TabStop + Case UCase("Tag") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Tag + Case UCase("Text") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Text + Case UCase("TextAlign") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TextAlign + Case UCase("TooltipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TooltipText + Case UCase("TripleState") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TripleState + Case UCase("TypeName") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.TypeName + Case UCase("Value") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function + _getProperty = pvItem.Value + Case UCase("Visible") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Visible + Case UCase("Width") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + _getProperty = pvItem.Width + Case UCase("XPos") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + If IsNull(pvItem.XPos) Then Goto Trace_Error + _getProperty = pvItem.XPos + Case UCase("YPos") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + If IsNull(pvItem.YPos) Then Goto Trace_Error + _getProperty = pvItem.YPos + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _getProperty = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _getProperty = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "_getProperty", Erl) + _getProperty = Nothing + GoTo Exit_Function +End Function ' _getProperty V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasProperty(ByVal psObject As String, ByVal pvPropertiesList() As Variant, ByVal pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) +' Generic hasProperty function called from all class modules + +Dim sObject As String + sObject = Utils._PCase(psObject) + Utils._SetCalledSub(sObject & ".hasProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + + _hasProperty = False + If Not Utils._CheckArgument(pvProperty, 1, vbString) Then Goto Exit_Function + + _hasProperty = Utils._InList(pvProperty, pvPropertiesList(), , True) + +Exit_Function: + Utils._ResetCalledSub(sObject & ".hasProperty") + Exit Function +End Function ' _hasProperty + +REM ------------------------------------------------------------------------------------------------------------------------ +Public Function _ParentObject(psShortcut As String) As Object +' Return parent object from shortcut as a string + +Dim sParent As String, vParent() As Variant, iBound As Integer + vParent = Split(psShortcut, "!") + iBound = UBound(vParent) - 1 + ReDim Preserve vParent(0 To iBound) ' Remove last element + sParent = Join(vParent, "!") + + 'Remove ".Form" if present +Const cstForm = ".FORM" + Set _ParentObject = Nothing + If Len(sParent) > Len(cstForm) Then + If UCase(Right(sParent, Len(cstForm))) = cstForm Then + Set _ParentObject = getValue(sParent) + Else + Set _ParentObject = getObject(sParent) + End If + End If + +End Function ' _ParentObject V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Properties(ByVal psObject As String _ + , ByRef pvParent As Object _ + , ByVal pvPropertiesList() As Variant _ + , ByVal Optional pvIndex As Variant _ + ) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise +' Generic function called from Properties methods stored in classes + +Dim vProperties As Variant, oCounter As Object, opProperty As Object +Dim iArgNr As Integer, iLen As Integer + + Utils._SetCalledSub(psObject & ".Properties") + + vProperties = Null + + If IsMissing(pvIndex) Then ' Call without index argument prepares a Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLPROPERTIES + Set oCounter._Parent = pvParent + oCounter._Count = UBound(pvPropertiesList) + 1 + Set vProperties = oCounter + Else + iLen = Len(psObject) + 1 + If Len(_A2B_.CalledSub) > iLen Then + If Left(_A2B_.CalledSub, iLen) = psObject & "." Then iArgNr = 1 Else iArgNr = 2 + End If + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < LBound(pvPropertiesList) Or pvIndex > UBound(pvPropertiesList) Then + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Else + Set opProperty = New Property + Set opProperty._This = opProperty + opProperty._Name = pvPropertiesList(pvIndex) + opProperty._Value = Null + Set vProperties = opProperty + End If + End If + +Exit_Function: + Set _Properties = vProperties + Utils._ResetCalledSub(psObject & ".Properties") + Exit Function +End Function ' _Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _PropertiesList(pvObject As Variant) As Variant +' Return an array of strings containing the list of valid properties of pvObject + +Dim vProperties As Variant +Dim vPropertiesList As Variant, bPropertiesList() As Boolean, sPropertiesList() As String +Dim i As Integer, j As Integer, iCount As Integer + + Set vProperties = Nothing + Select Case pvObject._Type + Case OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJEVENT, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _ + , OBJDATABASE, OBJTABLEDEF, OBJQUERYDEF, OBJDIALOG, OBJFIELD, OBJRECORDSET, OBJTEMPVAR _ + , OBJCOMMANDBAR, OBJCOMMANDBARCONTROL + vPropertiesList = pvObject._PropertiesList() + Case Else + End Select + +Exit_Function: + Set _PropertiesList = vPropertiesList + Exit Function +End Function ' PropertiesList V0.9.0 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/PropertiesSet.xba b/wizards/source/access2base/PropertiesSet.xba new file mode 100644 index 000000000..100806bea --- /dev/null +++ b/wizards/source/access2base/PropertiesSet.xba @@ -0,0 +1,577 @@ +<?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="PropertiesSet" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAbsolutePosition(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAbsolutePosition") + setAbsolutePosition = PropertiesSet._setProperty(pvObject, "AbsolutePosition", pvValue) +End Function ' setAbsolutePosition + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAllowAdditions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowAdditions") + setAllowAdditions = PropertiesSet._setProperty(pvObject, "AllowAdditions", pvValue) +End Function ' setAllowAdditions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAllowDeletions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowDeletions") + setAllowDeletions = PropertiesSet._setProperty(pvObject, "AllowDeletions", pvValue) +End Function ' setAllowDeletions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAllowEdits(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowEdits") + setAllowEdits = PropertiesSet._setProperty(pvObject, "AllowEdits", pvValue) +End Function ' setAllowEdits + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBackColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBackColor") + setBackColor = PropertiesSet._setProperty(pvObject, "BackColor", pvValue) +End Function ' setBackColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBookmark(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBookmark") + setBookmark = PropertiesSet._setProperty(pvObject, "Bookmark", pvValue) +End Function ' setBookmark + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBorderColor (Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderColor") + setBorderColor = PropertiesSet._setProperty(pvObject, "BorderColor", pvValue) +End Function ' setBorderColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBorderStyle(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderStyle") + setBorderStyle = PropertiesSet._setProperty(pvObject, "BorderStyle", pvValue) +End Function ' setBorderStyle + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setCancel(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCancel") + setCancel = PropertiesSet._setProperty(pvObject, "Cancel", pvValue) +End Function ' setCancel + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setCaption(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCaption") + setCaption = PropertiesSet._setProperty(pvObject, "Caption", pvValue) +End Function ' setCaption + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setControlTipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setControlTipText") + setControlTipText = PropertiesSet._setProperty(pvObject, "ControlTipText", pvValue) +End Function ' setControlTipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setCurrentRecord(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCurrentRecord") + setCurrentRecord = PropertiesSet._setProperty(pvObject, "CurrentRecord", pvValue) +End Function ' setCurrentRecord + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDefault(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefault") + setDefault = PropertiesSet._setProperty(pvObject, "Default", pvValue) +End Function ' setDefault + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDefaultValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefaultValue") + setDefaultValue = PropertiesSet._setProperty(pvObject, "DefaultValue", pvValue) +End Function ' setDefaultValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDescription(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDescription") + setDescription = PropertiesSet._setProperty(pvObject, "Description", pvValue) +End Function ' setDescription + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setEnabled(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setEnabled") + setEnabled = PropertiesSet._setProperty(pvObject, "Enabled", pvValue) +End Function ' setEnabled + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFilter(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilter") + setFilter = PropertiesSet._setProperty(pvObject, "Filter", pvValue) +End Function ' setFilter + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFilterOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilterOn") + setFilterOn = PropertiesSet._setProperty(pvObject, "FilterOn", pvValue) +End Function ' setFilterOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontBold(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontBold") + setFontBold = PropertiesSet._setProperty(pvObject, "FontBold", pvValue) +End Function ' setFontBold + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontItalic(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontItalic") + setFontItalic = PropertiesSet._setProperty(pvObject, "FontItalic", pvValue) +End Function ' setFontItalic + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontName(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontName") + setFontName = PropertiesSet._setProperty(pvObject, "FontName", pvValue) +End Function ' setFontName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontSize(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontSize") + setFontSize = PropertiesSet._setProperty(pvObject, "FontSize", pvValue) +End Function ' setFontSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontUnderline(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontUnderline") + setFontUnderline = PropertiesSet._setProperty(pvObject, "FontUnderline", pvValue) +End Function ' setFontUnderline + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontWeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontWeight") + setFontWeight = PropertiesSet._setProperty(pvObject, "FontWeight", pvValue) +End Function ' setFontWeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setForeColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setForeColor") + setForeColor = PropertiesSet._setProperty(pvObject, "ForeColor", pvValue) +End Function ' setForeColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setHeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setHeight") + setHeight = PropertiesSet._setProperty(pvObject, "Height", pvValue) +End Function ' setHeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setListIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setListIndex") + setListIndex = PropertiesSet._setProperty(pvObject, "ListIndex", pvValue) +End Function ' setListIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setLocked(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setLocked") + setLocked = PropertiesSet._setProperty(pvObject, "Locked", pvValue) +End Function ' setLocked + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setMultiSelect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setMultiSelect") + setMultiSelect = PropertiesSet._setProperty(pvObject, "MultiSelect", pvValue) +End Function ' setMultiSelect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOnAction(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOnAction") + setOnAction = PropertiesSet._setProperty(pvObject, "OnAction", pvValue) +End Function ' setOnAction + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOptionValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOptionValue") + setOptionValue = PropertiesSet._setProperty(pvObject, "OptionValue", pvValue) +End Function ' setOptionValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOrderBy(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderBy") + setOrderBy = PropertiesSet._setProperty(pvObject, "OrderBy", pvValue) +End Function ' setOrderBy + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOrderByOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderByOn") + setOrderByOn = PropertiesSet._setProperty(pvObject, "OrderByOn", pvValue) +End Function ' setOrderByOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setPage(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setPage") + setPage = PropertiesSet._setProperty(pvObject, "Page", pvValue) +End Function ' setPage V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(Optional pvItem As Variant, ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return True if property setting OK + Utils._SetCalledSub("setProperty") + If IsMissing(pvItem) Or IsMissing(psProperty) Or IsMissing(pvValue) Or IsEmpty(pvItem) Then Call _TraceArguments() + If IsMissing(pvIndex) Then + setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue) + Else + setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue, pvIndex) + End If + Utils._ResetCalledSub("setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRecordSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRecordSource") + setRecordSource = PropertiesSet._setProperty(pvObject, "RecordSource", pvValue) +End Function ' setRecordSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRequired(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRequired") + setRequired = PropertiesSet._setProperty(pvObject, "Required", pvValue) +End Function ' setRequired + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRowSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSource") + setRowSource = PropertiesSet._setProperty(pvObject, "RowSource", pvValue) +End Function ' setRowSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRowSourceType(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSourceType") + setRowSourceType = PropertiesSet._setProperty(pvObject, "RowSourceType", pvValue) +End Function ' setRowSourceType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelected(Optional pvObject As Variant, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Then Call _TraceArguments("setSelected") + If IsEmpty(pvObject) Then Call _TraceArguments("setSelected") + If IsMissing(pvIndex) Then + setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue) + Else + setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue, pvIndex) + End If +End Function ' setSelected + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelLength(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelLength") + setSelLength = PropertiesSet._setProperty(pvObject, "SelLength", pvValue) +End Function ' setSelLength + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelStart(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelStart") + setSelStart = PropertiesSet._setProperty(pvObject, "SelStart", pvValue) +End Function ' setSelStart + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelText") + setSelText = PropertiesSet._setProperty(pvObject, "SelText", pvValue) +End Function ' setSelText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSpecialEffect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSpecialEffect") + setSpecialEffect = PropertiesSet._setProperty(pvObject, "SpecialEffect", pvValue) +End Function ' setSpecialEffect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTabIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabIndex") + setTabIndex = PropertiesSet._setProperty(pvObject, "TabIndex", pvValue) +End Function ' setTabIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTabStop(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabStop") + setTabStop = PropertiesSet._setProperty(pvObject, "TabStop", pvValue) +End Function ' setTabStop + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTag(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTag") + setTag = PropertiesSet._setProperty(pvObject, "Tag", pvValue) +End Function ' setTag + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTextAlign(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTextAlign") + setTextAlign = PropertiesSet._setProperty(pvObject, "TextAlign", pvValue) +End Function ' setTextAlign + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTooltipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTooltipText") + setTooltipText = PropertiesSet._setProperty(pvObject, "TooltipText", pvValue) +End Function ' setTooltipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTripleState(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTripleState") + setTripleState = PropertiesSet._setProperty(pvObject, "TripleState", pvValue) +End Function ' setTripleState + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setVisible(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms and controls + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setVisible") + setVisible = PropertiesSet._setProperty(pvObject, "Visible", pvValue) +End Function ' setVisible + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setWidth(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setWidth") + setWidth = PropertiesSet._setProperty(pvObject, "Width", pvValue) +End Function ' setWidth + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private Function _CheckProperty(pvObject As Object, ByVal psProperty As String) As Boolean +' Return False if psProperty not within the PropertyValues set of pvItem + +Dim i As Integer, oPropertyValues As Variant, oProperty As Variant + oPropertyValues = pvObject.PropertyValues + + For i = LBound(oPropertyValues) To UBound(oPropertyValues) + oProperty = oPropertyValues(i) + If UCase(oProperty.Name) = UCase(psProperty) Then + _CheckProperty = True + Exit Function + End If + Next i + + _CheckProperty = False + Exit Function + +End Function ' CheckProperty V0.7.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _setProperty(pvItem As Variant, ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + +'pvItem must be an object and have the requested property + If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function +'Check Index argument + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 4, Utils._AddNumeric()) Then Goto Exit_Function + End If +'Execute +Dim iArgNr As Integer, lFormat As Long +Dim i As Integer, iCount As Integer, iSelectedItems() As Integer, bListboxBound As Boolean +Dim odbDatabase As Object, vNames As Variant, bFound As Boolean, sName As String, oModel As Object +Dim ocButton As Variant, iRadioIndex As Integer + _setProperty = True + If _A2B_.CalledSub = "setProperty" Then iArgNr = 3 Else iArgNr = 2 + If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error_Control + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + pvItem.AbsolutePosition = pvValue + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.AllowAdditions = pvValue + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.AllowDeletions = pvValue + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.AllowEdits = pvValue + Case UCase("BackColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.BackColor = pvValue + Case UCase("Bookmark") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function + pvItem.Bookmark = pvValue + Case UCase("BorderColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.BorderColor = pvValue + Case UCase("BorderStyle") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.BorderColor = pvValue + Case UCase("Cancel") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Cancel = pvValue + Case UCase("Caption") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function + pvItem.Caption = pvValue + Case UCase("ControlTipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.ControlTipText = pvValue + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.CurrentRecord = pvValue + Case UCase("Default") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Default = pvValue + Case UCase("DefaultValue") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function + pvItem.DefaultValue = pvValue + Case UCase("Description") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + pvItem.DefaultValue = pvValue + Case UCase("Enabled") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Enabled = pvValue + Case UCase("Filter") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function + pvItem.Filter = pvValue + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.FilterOn = pvValue + Case UCase("FontBold") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontBold = pvValue + Case UCase("FontItalic") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontItalic = pvValue + Case UCase("FontName") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontName = pvValue + Case UCase("FontSize") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontSize = pvValue + Case UCase("FontUnderline") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontUnderline = pvValue + Case UCase("FontWeight") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontWeight = pvValue + Case UCase("ForeColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.ForeColor = pvValue + Case UCase("Height") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + pvItem.Height = pvValue + Case UCase("ListIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.ListIndex = pvValue + Case UCase("Locked") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Locked = pvValue + Case UCase("MultiSelect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.MultiSelect = pvValue + Case UCase("OnAction") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + pvItem.OnAction = pvValue + Case UCase("OptionValue") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.OptionValue = pvValue + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.OrderBy = pvValue + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.OrderByOn = pvValue + Case UCase("Page") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function + pvItem.Page = pvValue + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.RecordSource = pvValue + Case UCase("Required") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Required = pvValue + Case UCase("RowSource") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.RowSource = pvValue + Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.RowSourceType = pvValue + Case UCase("Selected") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsMissing(pvIndex) Then pvItem.Selected = pvValue Else pvItem.SelectedI(pvValue, pvIndex) + Case UCase("SelLength") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelLength = pvValue + Case UCase("SelStart") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelStart = pvValue + Case UCase("SelText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelText = pvValue + Case UCase("SpecialEffect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SpecialEffect = pvValue + Case UCase("TabIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TabIndex = pvValue + Case UCase("TabStop") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TabStop = pvValue + Case UCase("Tag") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Tag = pvValue + Case UCase("TextAlign") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TextAlign = pvValue + Case UCase("TooltipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + pvItem.TooltipText = pvValue + Case UCase("TripleState") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TripleState = pvValue + Case UCase("Value") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function + pvItem.Value = pvValue + Case UCase("Visible") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + pvItem.Visible = pvValue + Case UCase("Width") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + pvItem.Width = pvValue + Case Else + Goto Trace_Error_Control + End Select + +Exit_Function: + Utils._ResetCalledSub("set" & psProperty) + Exit Function +Trace_Error_Form: + TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, 1, pvItem._Name) + _setProperty = False + Goto Exit_Function +Trace_Error_Control: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _setProperty = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _setProperty = False + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _setProperty = Nothing + Goto Exit_Function +Trace_Error_Array: + TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr) + _setProperty = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "_setProperty", Erl) + GoTo Exit_Function +End Function ' _setProperty V0.9.1 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Property.xba b/wizards/source/access2base/Property.xba new file mode 100644 index 000000000..8b881c284 --- /dev/null +++ b/wizards/source/access2base/Property.xba @@ -0,0 +1,152 @@ +<?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="Property" 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 PROPERTY +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Value As Variant +Private _ParentDatabase As Object + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJPROPERTY + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _Value = Null +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 ----------------------------------------------------------------------------------------------------------------------- + +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Property.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Property.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Name", "ObjectType", "Value") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Property.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + _PropertyGet = _Value + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Property.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Property._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Python.xba b/wizards/source/access2base/Python.xba new file mode 100644 index 000000000..94a442159 --- /dev/null +++ b/wizards/source/access2base/Python.xba @@ -0,0 +1,613 @@ +<?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="Python" 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 Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub DebugPrint(ParamArray pvArgs() As Variant) + +'Print arguments unconditionally in console +'Arguments are separated by a TAB (simulated by spaces) +'Some pvArgs might be missing: a TAB is still generated + +Dim vVarTypes() As Variant, i As Integer +Const cstTab = 5 + On Local Error Goto Exit_Sub ' Never interrupt processing + Utils._SetCalledSub("DebugPrint") + vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, vbArray + vbByte)) + + If UBound(pvArgs) >= 0 Then + For i = 0 To UBound(pvArgs) + If Not Utils._CheckArgument(pvArgs(i), i + 1, vVarTypes(), , False) Then pvArgs(i) = "[TYPE?]" + Next i + End If + +Dim sOutput As String, sArg As String + sOutput = "" + For i = 0 To UBound(pvArgs) + sArg = Replace(Utils._CStr(pvArgs(i), _A2B_.DebugPrintShort), "\;", ";") + ' Add argument to output + If i = 0 Then + sOutput = sArg + Else + sOutput = sOutput & Space(cstTab - (Len(sOutput) Mod cstTab)) & sArg + End If + Next i + + TraceLog(TRACEANY, sOutput, False) + +Exit_Sub: + Utils._ResetCalledSub("DebugPrint") + Exit Sub +End Sub ' DebugPrint V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PYTHON WRAPPERS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PythonEventsWrapper(Optional poEvent As Variant) As Variant +' Python wrapper when Application.Events() method is invoked +' The ParamArray mechanism empties UNO objects when they are member of the arguments list +' As a workaround, the Application.Events function is executed directly + + If _ErrorHandler() Then On Local Error GoTo Exit_Function ' Do never interrupt + PythonEventsWrapper = Null + +Dim vReturn As Variant, vArray As Variant +Const cstObject = 1 + + vReturn = Application.Events(poEvent) + vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type) + + PythonEventsWrapper = vArray + +Exit_Function: + Exit Function +End Function ' PythonEventsWrapper V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PythonWrapper(ByVal pvCallType As Variant _ + , ByVal pvObject As Variant _ + , ByVal pvScript As Variant _ + , ParamArray pvArgs() As Variant _ + ) As Variant +' Called from Python to apply +' - on object with entry pvObject in PythonCache +' Conventionally: -1 = Application +' -2 = DoCmd +' - a script pvScript which type is described by pvCallType +' - with arguments pvArgs(0)... (max. 8 for object methods) +' The value returned by the method/property is encapsulated in an array +' [0] => 0 = scalar or array returned by the method +' => 1 = basic object returned by the method +' => 2 = a null value +' [1] => the object reference or the returned value (complemented with arguments passed by reference, if any) or Null +' [2] => the object type or Null +' [3] => the object name, if any +' or, when pvCallType == vbUNO, as the UNO object returned by the property + +Dim vReturn As Variant, vArray As Variant +Dim vObject As Variant, sScript As String, sModule As String +Dim i As Integer, iNbArgs As Integer, vArg As Variant, vArgs() As Variant + +Const cstApplication = -1, cstDoCmd = -2 +Const cstScalar = 0, cstObject = 1, cstNull = 2, cstUNO = 3 + +'Conventional special values +Const cstNoArgs = "+++NOARGS+++", cstSymEmpty = "+++EMPTY+++", cstSymNull = "+++NULL+++", cstSymMissing = "+++MISSING+++" + +'https://support.office.com/en-us/article/CallByName-fonction-49ce9475-c315-4f13-8d35-e98cfe98729a +'Determines the pvCallType +Const vbGet = 2, vbLet = 4, vbMethod = 1, vbSet = 8, vbUNO = 16 + + If _ErrorHandler() Then On Local Error GoTo Error_Function + PythonWrapper = Null + + 'Reinterpret arguments one by one into vArgs, examine iso-dates and conventional NoArgs/Empty/Null values + iNbArgs = -1 + vArgs = Array() + If UBound(pvArgs) >= 0 Then + For i = 0 To UBound(pvArgs) + vArg = pvArgs(i) + If i = 0 And VarType(vArg) = vbString Then + If vArg = cstNoArgs Then Exit For + End If + If VarType(vArg) = vbString Then + If vArg = cstSymEmpty Then + vArg = Empty + ElseIf vArg = cstSymNull Then + vArg = Null + ElseIf vArg = cstSymMissing Then + Exit For ' Next arguments must be missing also + Else + vArg = _CDate(vArg) + End If + End If + iNbArgs = iNbArgs + 1 + ReDim Preserve vArgs(iNbArgs) + vArgs(iNbArgs) = vArg + Next i + End If + + 'Check pvObject + Select Case pvObject ' Always numeric + Case cstApplication + sModule = "Application" + Select Case pvScript + Case "AllDialogs" : If iNbArgs < 0 Then vReturn = Application.AllDialogs() Else vReturn = Application.AllDialogs(vArgs(0)) + Case "AllForms" : If iNbArgs < 0 Then vReturn = Application.AllForms() Else vReturn = Application.AllForms(vArgs(0)) + Case "AllModules" : If iNbArgs < 0 Then vReturn = Application.AllModules() Else vReturn = Application.AllModules(vArgs(0)) + Case "CloseConnection" + vReturn = Application.CloseConnection() + Case "CommandBars" : If iNbArgs < 0 Then vReturn = Application.CommandBars() Else vReturn = Application.CommandBars(vArgs(0)) + Case "CurrentDb" : vReturn = Application.CurrentDb() + Case "CurrentUser" : vReturn = Application.CurrentUser() + Case "DAvg" : vReturn = Application.DAvg(vArgs(0), vArgs(1), vArgs(2)) + Case "DCount" : vReturn = Application.DCount(vArgs(0), vArgs(1), vArgs(2)) + Case "DLookup" : vReturn = Application.DLookup(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "DMax" : vReturn = Application.DMax(vArgs(0), vArgs(1), vArgs(2)) + Case "DMin" : vReturn = Application.DMin(vArgs(0), vArgs(1), vArgs(2)) + Case "DStDev" : vReturn = Application.DStDev(vArgs(0), vArgs(1), vArgs(2)) + Case "DStDevP" : vReturn = Application.DStDevP(vArgs(0), vArgs(1), vArgs(2)) + Case "DSum" : vReturn = Application.DSum(vArgs(0), vArgs(1), vArgs(2)) + Case "DVar" : vReturn = Application.DVar(vArgs(0), vArgs(1), vArgs(2)) + Case "DVarP" : vReturn = Application.DVarP(vArgs(0), vArgs(1), vArgs(2)) + Case "Forms" : If iNbArgs < 0 Then vReturn = Application.Forms() Else vReturn = Application.Forms(vArgs(0)) + Case "getObject" : vReturn = Application.getObject(vArgs(0)) + Case "getValue" : vReturn = Application.getValue(vArgs(0)) + Case "HtmlEncode" : vReturn = Application.HtmlEncode(vArgs(0), vArgs(1)) + Case "OpenDatabase" : vReturn = Application.OpenDatabase(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "ProductCode" : vReturn = Application.ProductCode() + Case "setValue" : vReturn = Application.setValue(vArgs(0), vArgs(1)) + Case "SysCmd" : vReturn = Application.SysCmd(vArgs(0), vArgs(1), vARgs(2)) + Case "TempVars" : If iNbArgs < 0 Then vReturn = Application.TempVars() Else vReturn = Application.TempVars(vArgs(0)) + Case "Version" : vReturn = Application.Version() + Case Else + GoTo Error_Proc + End Select + Case cstDoCmd + sModule = "DoCmd" + Select Case pvScript + Case "ApplyFilter" : vReturn = DoCmd.ApplyFilter(vArgs(0), vArgs(1), vArgs(2)) + Case "Close" : vReturn = DoCmd.mClose(vArgs(0), vArgs(1), vArgs(2)) + Case "CopyObject" : vReturn = DoCmd.CopyObject(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "FindNext" : vReturn = DoCmd.FindNext() + Case "FindRecord" : vReturn = DoCmd.FindRecord(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case "GetHiddenAttribute" + vReturn = DoCmd.GetHiddenAttribute(vArgs(0), vArgs(1)) + Case "GoToControl" : vReturn = DoCmd.GoToControl(vArgs(0)) + Case "GoToRecord" : vReturn = DoCmd.GoToRecord(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "Maximize" : vReturn = DoCmd.Maximize() + Case "Minimize" : vReturn = DoCmd.Minimize() + Case "MoveSize" : vReturn = DoCmd.MoveSize(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "OpenForm" : vReturn = DoCmd.OpenForm(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case "OpenQuery" : vReturn = DoCmd.OpenQuery(vArgs(0), vArgs(1), vArgs(2)) + Case "OpenReport" : vReturn = DoCmd.OpenReport(vArgs(0), vArgs(1)) + Case "OpenSQL" : vReturn = DoCmd.OpenSQL(vArgs(0), vArgs(1)) + Case "OpenTable" : vReturn = DoCmd.OpenTable(vArgs(0), vArgs(1), vArgs(2)) + Case "OutputTo" : vReturn = DoCmd.OutputTo(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7)) + Case "Quit" : _A2B_.CalledSub = "Quit" : GoTo Error_Action + Case "RunApp" : vReturn = DoCmd.RunApp(vArgs(0)) + Case "RunCommand" : vReturn = DoCmd.RunCommand(vArgs(0)) + Case "RunSQL" : vReturn = DoCmd.RunSQL(vArgs(0), vArgs(1)) + Case "SelectObject" : vReturn = DoCmd.SelectObject(vArgs(0), vArgs(1), vArgs(2)) + Case "SendObject" : vReturn = DoCmd.SendObject(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7), vArgs(8), vArgs(9)) + Case "SetHiddenAttribute" + vReturn = DoCmd.SetHiddenAttribute(vArgs(0), vArgs(1), vArgs(2)) + Case "SetOrderBy" : vReturn = DoCmd.SetOrderBy(vArgs(0), vArgs(1)) + Case "ShowAllRecords" + vReturn = DoCmd.ShowAllRecords() + Case Else + GoTo Error_Proc + End Select + Case Else + ' Locate targeted object + If pvObject > UBound(_A2B_.PythonCache) Or pvObject < 0 Then GoTo Error_Object + Set vObject = _A2B_.PythonCache(pvObject) + If IsNull(vObject) Then + If pvScript = "Dispose" Then GoTo Exit_Function Else GoTo Error_Object + End If + ' Preprocessing + sScript = pvScript + sModule = vObject._Type + Select Case sScript + Case "Add" + If vObject._Type = "COLLECTION" And vObject._CollType = COLLTABLEDEFS Then vArgs = Array(_A2B_.PythonCache(vArgs(0))) + Case "Close" + sSCript = "mClose" + Case "Type" + sScript = "pType" + Case Else + End Select + ' Execute method + Select Case UBound(vArgs) ' Dirty but ... CallByName does not support an array of arguments or return values + Case -1 + If pvCallType = vbUNO Then + With vObject + Select Case sScript ' List all properties that should be called directly (UNO) + Case "BoundField" : vReturn = .BoundField + Case "Column" : vReturn = .Column + Case "Connection" : vReturn = .Connection + case "ContainerWindow" : vReturn = .ContainerWindow + Case "ControlModel" : vReturn = .ControlModel + Case "ControlView" : vReturn = .ControlView + Case "DatabaseForm" : vReturn = .DatabaseForm + Case "Document" : vReturn = .Document + Case "FormsCollection" : vReturn = .FormsCollection + Case "LabelControl" : vReturn = .LabelControl + Case "MetaData" : vReturn = .MetaData + Case "ParentComponent" : vReturn = .ParentComponent + Case "Query" : vReturn = .Query + Case "RowSet" : vReturn = .RowSet + Case "Table" : vReturn = .Table + Case "UnoDialog" : vReturn = .UnoDialog + Case Else + End Select + End With + ElseIf sScript = "ItemData" Then ' List all properties that should be called directly (arrays not supported by CallByName) + vReturn = vObject.ItemData + ElseIf sScript = "LinkChildFields" Then + vReturn = vObject.LinkChildFields + ElseIf sScript = "LinkMasterFields" Then + vReturn = vObject.LinkMasterFields + ElseIf sScript = "OpenArgs" Then + vReturn = vObject.OpenArgs + ElseIf sScript = "Selected" Then + vReturn = vObject.Selected + ElseIf sScript = "Value" Then + vReturn = vObject.Value + Else + vReturn = CallByName(vObject, sScript, pvCallType) + End If + Case 0 + Select Case sScript + Case "AppendChunk" ' Arg is a vector, not supported by CallByName + vReturn = vObject.GetChunk(vArgs(0), vArgs(1)) + Case "GetRows" ' Returns an array, not supported by CallByName + vReturn = vObject.GetRows(vArgs(0), True) ' Force iso dates + Case Else + vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0)) + End Select + Case 1 + Select Case sScript + Case "GetChunk" ' Returns a vector, not supported by CallByName + vReturn = vObject.GetChunk(vArgs(0), vArgs(1)) + Case Else + vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1)) + End Select + Case 2 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2)) + Case 3 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case 4 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + Case 5 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5)) + Case 6 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case 7 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7)) + End Select + ' Postprocessing + Select Case pvScript + Case "Close", "Dispose", "Terminate" + Set _A2B_.PythonCache(pvObject) = Nothing + Case "Move", "MoveFirst", "MoveLast", "MoveNext", "MovePrevious" ' Pass the new BOF, EOF values (binary format) + If vObject._Type = "RECORDSET" Then + vReturn = (Iif(vObject.BOF, 1, 0) * 2 + Iif(vObject.EOF, 1, 0)) * Iif(vReturn, 1, -1) + End If + Case "Find" ' Store in array the arguments passed by reference + If vObject._Type = "MODULE" And vReturn = True Then + vReturn = Array(vReturn, vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + End If + Case "ProcOfLine" ' Store in array the arguments passed by reference + vReturn = Array(vReturn, vArgs(1)) + Case Else + End Select + End Select + + ' Structure the returned array + If pvCallType = vbUNO Then + vArray = vReturn + Else + If IsNull(vReturn) Then + vArray = Array(cstNull, Null, Null) + ElseIf IsObject(vReturn) Then + Select Case vReturn._Type + Case "COLLECTION", "COMMANDBARCONTROL", "EVENT" + vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type) + Case Else + vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type, vReturn.Name) + End Select + Else + If VarType(vReturn) = vbDate Then + vArray = Array(cstScalar, _CStr(vReturn), Null) + ElseIf VarType(vReturn) = vbBigint Then ' Could happen for big integer database fields + vArray = Array(cstScalar, CLng(vReturn), Null) + Else + vArray = Array(cstScalar, vReturn, Null) + End If + End If + End If + + PythonWrapper = vArray + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "PythonWrapper", Erl) + GoTo Exit_Function +Error_Object: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, "Python Wrapper (" & pvScript & ")", 0, , Array(_GetLabel("OBJECT"), "#" & pvObject)) + GoTo Exit_Function +Error_Action: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) + GoTo Exit_Function +Error_Proc: + TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, "Python Wrapper", 0, , Array(pvScript, sModule)) + GoTo Exit_Function +End Function ' PythonWrapper V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PYTHON HELPER FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyConvertFromUrl(ByVal pvFile As Variant) As String +' Convenient function to have common conversions of filenames from/to url notations both in Python and Basic + + On Local Error GoTo Exit_Function + PyConvertFromUrl = "" + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + + PyConvertFromUrl = ConvertFromUrl(pvFile) + +Exit_Function: + Exit Function +End Function ' PyConvertFromUrl V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyConvertToUrl(ByVal pvFile As Variant) As String +' Convenient function to have common conversions of filenames from/to url notations both in Python and Basic + + On Local Error GoTo Exit_Function + PyConvertToUrl = "" + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + + PyConvertToUrl = ConvertToUrl(pvFile) + +Exit_Function: + Exit Function +End Function ' PyConvertToUrl V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyCreateUnoService(ByVal pvService As Variant) As Variant +' Convenient function to create a UNO service in Python + + On Local Error GoTo Exit_Function + Set PyCreateUnoService = Nothing + If Not Utils._CheckArgument(pvService, 1, vbString) Then Goto Exit_Function + + Set PyCreateUnoService = CreateUnoService(pvService) + +Exit_Function: + Exit Function +End Function ' PyCreateUnoService V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDateAdd(ByVal pvAdd As Variant _ + , ByVal pvCount As Variant _ + , ByVal pvDate As Variant _ + ) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate As Variant, vNewDate As Variant + On Local Error GoTo Exit_Function + PyDateAdd = Null + + If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvCount, 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate, 3, vbString) Then Goto Exit_Function + + vDate = _CDate(pvDate) + vNewDate = DateAdd(pvAdd, pvCount, vDate) + If VarType(vNewDate) = vbDate Then PyDateAdd = _CStr(vNewDate) Else PyDateAdd = vNewDate + +Exit_Function: + Exit Function +End Function ' PyDateAdd V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDateDiff(ByVal pvAdd As Variant _ + , ByVal pvDate1 As Variant _ + , ByVal pvDate2 As Variant _ + , ByVal pvWeekStart As Variant _ + , ByVal pvYearStart As Variant _ + ) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate1 As Variant, vDate2 As Variant + On Local Error GoTo Exit_Function + PyDateDiff = Null + + If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate1, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate2, 3, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 4, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 5, Utils._AddNumeric()) Then Goto Exit_Function + + vDate1 = _CDate(pvDate1) + vDate2 = _CDate(pvDate2) + PyDateDiff = DateDiff(pvAdd, vDate1, vDate2, pvWeekStart, pvYearStart) + +Exit_Function: + Exit Function +End Function ' PyDateDiff V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDatePart(ByVal pvAdd As Variant _ + , ByVal pvDate As Variant _ + , ByVal pvWeekStart As Variant _ + , ByVal pvYearStart As Variant _ + ) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate As Variant + On Local Error GoTo Exit_Function + PyDatePart = Null + + If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 4, Utils._AddNumeric()) Then Goto Exit_Function + + vDate = _CDate(pvDate) + PyDatePart = DatePart(pvAdd, vDate, pvWeekStart, pvYearStart) + +Exit_Function: + Exit Function +End Function ' PyDatePart V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDateValue(ByVal pvDate As Variant) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate As Variant + On Local Error GoTo Exit_Function + PyDateValue = Null + If Not Utils._CheckArgument(pvDate, 1, vbString) Then Goto Exit_Function + + vDate = DateValue(pvDate) + If VarType(vDate) = vbDate Then PyDateValue = _CStr(vDate) Else PyDateValue = vDate + +Exit_Function: + Exit Function +End Function ' PyDateValue V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyFormat(ByVal pvValue As Variant, pvFormat As Variant) As String +' Convenient function to format numbers or dates + + On Local Error GoTo Exit_Function + PyFormat = "" + If Not Utils._CheckArgument(pvValue, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + pvValue = _CDate(pvValue) + If IsEmpty(pvFormat) Then + PyFormat = Str(pvValue) + Else + If Not Utils._CheckArgument(pvFormat, 2, vbString) Then Goto Exit_Function + PyFormat = Format(pvValue, pvFormat) + End If + +Exit_Function: + Exit Function +End Function ' PyFormat V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyGetGUIType() As Variant + + PyGetGUIType = GetGUIType() + +End Function ' PyGetGUIType V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyGetSystemTicks() As Variant + + PyGetSystemTicks = GetSystemTicks() + +End Function ' PyGetSystemTicks V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyGlobalScope(ByVal pvLib As Variant) As Variant + + Select Case pvLib + Case "Basic" + PyGlobalScope = GlobalScope.BasicLibraries() + Case "Dialog" + PyGlobalScope = GlobalScope.DialogLibraries() + Case Else + End Select + +End Function ' PyGlobalScope V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyInputBox(ByVal pvText As Variant _ + , ByVal pvTitle As Variant _ + , ByVal pvDefault As Variant _ + , ByVal pvXPos As Variant _ + , ByVal pvYPos As Variant _ + ) As Variant +' Convenient function to open input box from Python + + On Local Error GoTo Exit_Function + PyInputBox = Null + + If Not Utils._CheckArgument(pvText, 1, vbString) Then Goto Exit_Function + If IsEmpty(pvTitle) Then pvTitle = "" + If Not Utils._CheckArgument(pvTitle, 2, vbString) Then Goto Exit_Function + If IsEmpty(pvDefault) Then pvDefault = "" + If Not Utils._CheckArgument(pvDefault, 3, vbString) Then Goto Exit_Function + + If IsEmpty(pvXPos) Or IsEmpty(pvYPos) Then + PyInputBox = InputBox(pvText, pvTitle, pvDefault) + Else + If Not Utils._CheckArgument(pvXPos, 4, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvYPos, 5, Utils._AddNumeric()) Then Goto Exit_Function + PyInputBox = InputBox(pvText, pvTitle, pvDefault, pvXPos, pvYPos) + End If + +Exit_Function: + Exit Function +End Function ' PyInputBox V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyMsgBox(ByVal pvText As Variant _ + , ByVal pvType As Variant _ + , ByVal pvDialogTitle As Variant _ + ) As Variant +' Convenient function to open message box from Python + + On Local Error GoTo Exit_Function + PyMsgBox = Null + + If Not Utils._CheckArgument(pvText, 1, vbString) Then Goto Exit_Function + If IsEmpty(pvType) Then pvType = 0 + If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric()) Then Goto Exit_Function + If IsEmpty(pvDialogTitle) Then + PyMsgBox = MsgBox(pvText, pvType) + Else + If Not Utils._CheckArgument(pvDialogTitle, 3, vbString) Then Goto Exit_Function + PyMsgBox = MsgBox(pvText, pvType, pvDialogTitle) + End If + +Exit_Function: + Exit Function +End Function ' PyMsgBox V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyTimer() As Long +' Convenient function to call Timer from Python + + PyTimer = Timer + +End Function ' PyTimer V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _CDate(ByVal pvValue As Variant) As Variant +' Return a Date type if iso date, otherwise return input + +Dim vValue As Variant + vValue = pvValue + If VarType(pvValue) = vbString Then + If pvValue <> "" And IsDate(pvValue) Then vValue = CDate(pvValue) ' IsDate("") gives True !? + End If + _CDate = vValue + +End Function + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba new file mode 100644 index 000000000..094bba000 --- /dev/null +++ b/wizards/source/access2base/Recordset.xba @@ -0,0 +1,1268 @@ +<?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="Recordset" 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 RECORDSET +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String ' Unique, generated +Private _Fields() As Variant +Private _ParentName As String +Private _ParentType As String +Private _ParentDatabase As Object +Private _ForwardOnly As Boolean +Private _PassThrough As Boolean +Private _ReadOnly As Boolean +Private _CommandType As Long +Private _Command As String +Private _DataSet As Boolean ' True if execute() successful +Private _BOF As Boolean +Private _EOF As Boolean +Private _Filter As String +Private _EditMode As Integer ' dbEditxxx constants +Private _BookmarkBeforeNew As Variant +Private _BookmarkLastModified As Variant +Private _IsClone As Boolean +Private _ManageChunks As Variant ' Array of ChunkDescriptors +Private RowSet As Object ' com.sun.star.comp.dba.ORowSet + +Type ChunkDescriptor + ChunksRequested As Boolean + FieldName As String + ChunkType As Integer ' vbString or vbByte + FileName As String + FileHandler As Object +End Type + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJRECORDSET + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _Fields = Array() + _ParentName = "" + Set _ParentDatabase = Nothing + _ParentType = "" + _ForwardOnly = False + _PassThrough = False + _ReadOnly = False + _CommandType = 0 + _Command = "" + _DataSet = False + _BOF = True + _EOF = True + _Filter = "" + _EditMode = dbEditNone + _BookmarkBeforeNew = Null + _BookmarkLastModified = Null + _IsClone = False + Set _ManageChunks = Array() + Set RowSet = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + mClose() +End Sub + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AbsolutePosition() As Variant + AbsolutePosition = _PropertyGet("AbsolutePosition") +End Property ' AbsolutePosition (get) + +Property Let AbsolutePosition(ByVal pvValue As Variant) + Call _PropertySet("AbsolutePosition", pvValue) +End Property ' AbsolutePosition (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BOF() As Boolean + BOF = _PropertyGet("BOF") +End Property ' BOF (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Bookmark() As Variant + Bookmark = _PropertyGet("Bookmark") +End Property ' Bookmark (get) + +Property Let Bookmark(ByVal pvValue As Variant) + Call _PropertySet("Bookmark", pvValue) +End Property ' Bookmark (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Bookmarkable() As Boolean + Bookmarkable = _PropertyGet("Bookmarkable") +End Property ' Bookmarkable (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EOF() As Boolean + EOF = _PropertyGet("EOF") +End Property ' EOF (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EditMode() As Integer + EditMode = _PropertyGet("EditMode") +End Property ' EditMode (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Filter() As Variant + Filter = _PropertyGet("Filter") +End Property ' Filter (get) + +Property Let Filter(ByVal pvValue As Variant) + Call _PropertySet("Filter", pvValue) +End Property ' Filter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get LastModified() As Variant +' DO NOT PUBLISH + LastModified = _PropertyGet("LastModified") +End Property ' LastModified (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 ----------------------------------------------------------------------------------------------------------------------- +Property Get RecordCount() As Long + RecordCount = _PropertyGet("RecordCount") +End Property ' RecordCount (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AddNew() As Boolean +' Initiates the creation of a new record + +Const cstThisSub = "Recordset.AddNew" +Dim i As Integer, iFieldsCount As Integer, oField As Object +Dim sDefault As String, oColumn As Object +Dim iValue As Integer, lValue As Long, sgValue As Single, dbValue As Double, dValue As Date +Dim vTemp As Variant + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + AddNew = False + + With RowSet + 'Is inserting a new row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + If Not .CanUpdateInsertedRows Then Goto Error_NoUpdate + If Not .IsBookmarkable Then Goto Error_NoUpdate + If _EditMode <> dbEditNone Then CancelUpdate() + If _BOF And _EOF Then ' Records before first or after last do not have a bookmark + _BookmarkBeforeNew = "_BOF_" + ElseIf .isBeforeFirst() Then + _BookmarkBeforeNew = "_BOF_" + ElseIf .isAfterLast() Then + _BookmarkBeforeNew = "_EOF_" + Else + _BookmarkBeforeNew = .getBookmark() + End If + + .moveToInsertRow() + + 'Set all fields to their default value + iFieldsCount = Fields().Count + On Local Error Resume Next ' Do not stop if default setting fails + For i = 0 To iFieldsCount - 1 + Set oField = Fields(i) + Set oColumn = oField.Column + sDefault = oField.DefaultValue + If sDefault = "" Then ' No default value + If oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then oColumn.updateNull() + Else + With com.sun.star.sdbc.DataType + Select Case oColumn.Type + Case .BIT, .BOOLEAN + If sDefault = "1" Then oColumn.updateBoolean(True) Else oColumn.updateBoolean(False) + Case .TINYINT + iValue = CInt(sDefault) + If iValue >= -128 And iValue <= +127 Then oColumn.updateShort(iValue) + Case .SMALLINT + lValue = CLng(sDefault) + If lValue >= -32768 And lValue <= 32767 Then oColumn.updateInt(lValue) + Case .INTEGER + lValue = CLng(sDefault) + If lValue >= -2147483648 And lValue <= 2147483647 Then oColumn.updateInt(lValue) + Case .BIGINT + lValue = CLng(sDefault) + Column.updateLong(lValue) ' No proper type conversion for HYPER data type + Case .FLOAT + sgValue = CSng(sDefault) + If Abs(sgValue) < 3.402823E38 And Abs(sgValue) > 1.401298E-45 Then oColumn.updateFloat(sgValue) + Case .REAL, .DOUBLE + dbValue = CDbl(sDefault) + 'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue) + oColumn.updateDouble(dbValue) + Case .NUMERIC, .DECIMAL + dbValue = CDbl(sDefault) + If Utils._hasUNOProperty(Column, "Scale") Then + If Column.Scale > 0 Then + 'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue) + oColumn.updateDouble(dbValue) + Else + oColumn.updateString(sDefault) + End If + Else + oColumn.updateString(sDefault) + End If + Case .CHAR, .VARCHAR, .LONGVARCHAR + oColumn.updateString(sDefault) ' vbString + Case .DATE + dValue = DateValue(sDefault) + vTemp = New com.sun.star.util.Date + With vTemp + .Day = Day(dValue) + .Month = Month(dValue) + .Year = Year(dValue) + End With + oColumn.updateDate(vTemp) + Case .TIME + dValue = TimeValue(sDefault) + vTemp = New com.sun.star.util.Time + With vTemp + .Hours = Hour(dValue) + .Minutes = Minute(dValue) + .Seconds = Second(dValue) + '.HundredthSeconds = 0 + End With + oColumn.updateTime(vTemp) + Case .TIMESTAMP + dValue = DateValue(sDefault) + vTemp = New com.sun.star.util.DateTime + With vTemp + .Day = Day(dValue) + .Month = Month(dValue) + .Year = Year(dValue) + .Hours = Hour(dValue) + .Minutes = Minute(dValue) + .Seconds = Second(dValue) + '.HundredthSeconds = 0 + End With + oColumn.updateTimestamp(vTemp) +' Case .BINARY, .VARBINARY, .LONGVARBINARY + ' Case .BLOB +' Case .CLOB + Case Else + End Select + End With + End If + Next i + End With + If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0 + + _EditMode = dbEditAdd + AddNew = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' AddNew + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CancelUpdate() As Boolean +' Cancel any edit action + +Const cstThisSub = "Recordset.CancelUpdate" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + CancelUpdate = False + + With RowSet + Select Case _EditMode + Case dbEditNone + Case dbEditAdd + _AppendChunkClose(True) + If Not IsNull(_BookmarkBeforeNew) Then + Select Case _BookmarkBeforeNew + Case "_BOF_" : .beforeFirst() + Case "_EOF_" : .afterLast() + Case Else : .moveToBookmark(_BookmarkBeforeNew) + End Select + End If + Case dbEditInProgress + .cancelRowUpdates() + _AppendChunkClose(True) + End Select + End With + + _EditMode = dbEditNone + _BookmarkBeforeNew = Null + _BookmarkLastModified = Null + CancelUpdate = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CancelUpdate + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Clone() As Object +' Duplicate an existing recordset + +Const cstThisSub = "Recordset.Clone" + +Const cstNull = -1 +Dim iType As Integer, iOptions As Integer, iLockEdit As Integer + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Set Clone = Nothing + + If _IsClone Then Goto Error_Clone + If _ForwardOnly Then iType = dbOpenForwardOnly Else iType = cstNull + If _PassThrough Then iOptions = dbSQLPassThrough Else iOptions = cstNull + iLockEdit = dbReadOnly ' Always read-only + + Set Clone = OpenRecordset(iType, iOptions, iLockEdit, True) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_Clone: + TraceError(TRACEFATAL, ERRRECORDSETCLONE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Clone + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose(ByVal Optional pbRemove As Boolean) As Variant +' Dispose UNO objects +' If pbRemove = True, remove recordset from Recordsets collection + +Const cstThisSub = "Recordset.Close" +Dim i As Integer + + If _ErrorHandler() Then On Local Error Goto Exit_Function ' Do not stop execution + Utils._SetCalledSub(cstThisSub) + If Not IsNull(RowSet) Then + RowSet.close() + RowSet.dispose() + End If + _ForwardOnly = False + _PassThrough = False + _ReadOnly = False + _CommandType = 0 + _Command = "" + _ParentName = "" + _ParentType = "" + _DataSet = False + _BOF = True + _EOF = True + _Filter = "" + _EditMode = dbEditNone + _BookmarkBeforeNew = Null + _BookmarkLastModified = Null + _IsClone = False + For i = 0 To UBound(_Fields) + If Not IsNull(_Fields(i)) Then + _Fields(i).Dispose() + Set _Fields(i) = Nothing + End If + Next i + _Fields = Array() + Set RowSet = Nothing + If IsMissing(pbRemove) Then pbRemove = True + If pbRemove Then _ParentDatabase.RecordsetsColl.Remove(_Name) + Set _ParentDatabase = Nothing + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Close + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Delete() As Boolean +' Deletes the current record + +Const cstThisSub = "Recordset.Delete" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Delete = False + + 'Is deleting a row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + If _EditMode <> dbEditNone Then + CancelUpdate() + Goto Error_Sequence + End If + If RowSet.rowDeleted() Then Goto Error_RowDeleted + + RowSet.deleteRow() + Delete = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + Goto Exit_Function +End Function ' Delete + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Edit() As Boolean +' Updates the current record + +Const cstThisSub = "Recordset.Edit" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Edit = False + + 'Is updating a row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + If _EditMode <> dbEditNone Then CancelUpdate() + If RowSet.rowDeleted() Then Goto Error_RowDeleted + + _EditMode = dbEditInProgress + Edit = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Edit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Fields(ByVal Optional pvIndex As variant) As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Recordset.Fields" + Utils._SetCalledSub(cstThisSub) + + Set Fields = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, oFields As Object, iIndex As Integer + + ' No argument, return a collection + If IsMissing(pvIndex) Then + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLFIELDS + Set oObject._Parent = _This + oObject._Count = RowSet.getColumns().Count + Goto Exit_Function + End If + + Set oFields = RowSet.getColumns() + sObjects = oFields.ElementNames() + + ' Argument is the field name + If VarType(pvIndex) = vbString Then + iIndex = -1 + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then Goto Trace_NotFound + ' Argument is numeric + Else + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + iIndex = pvIndex + End If + + ' Check if field object already buffered in _Fields() array + If UBound(_Fields) < 0 Then ' Initialize _Fields + ReDim _Fields(0 To UBound(sObjects)) + For i = 0 To UBound(sObjects) + Set _Fields(i) = Nothing + Next i + End If + If Not IsNull(_Fields(iIndex)) Then + Set oObject = _Fields(iIndex) + ' Otherwise create new field object + Else + Set oObject = New Field + Set oObject._This = oObject + oObject._Name = sObjectName + Set oObject.Column = oFields.getByName(sObjectName) + If Utils._hasUNOProperty(oObject.Column, "Precision") Then oObject._Precision = oObject.Column.Precision + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oObject._ParentDatabase = _ParentDatabase + Set oObject._ParentRecordset = _This + Set _Fields(iIndex) = oObject + End If + +Exit_Function: + Set Fields = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Fields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Const cstThisSub = "Recordset.getProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +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() + If IsMissing(pvNumRows) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvNumRows, 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvNumRows < 1 Then Goto Trace_Error + If IsNull(RowSet) Then Goto Trace_Closed + If Not _DataSet Then Goto Exit_Function + + If _EditMode <> dbEditNone Then CancelUpdate() + + If _EOF Then Goto Exit_Function + + lSize = -1 + iNumFields = RowSet.getColumns().Count - 1 + If iNumFields < 0 Then Goto Exit_Function + + ReDim vMatrix(0 To iNumFields, 0 To pvNumRows - 1) + + Do While Not _EOF And lSize < pvNumRows - 1 + lSize = lSize + 1 + For i = 0 To iNumFields + vMatrix(i, lSize) = Utils._getResultSetColumnValue(RowSet, i + 1) + If pbStrDate And IsDate(vMatrix(i, lSize)) Then vMatrix(i, lSize) = _CStr(vMatrix(i, lSize)) + Next i + _Move("NEXT") + Loop + If lSize < pvNumRows - 1 Then ' Resize to number of fetched records + ReDim Preserve vMatrix(0 To iNumFields, 0 To lSize) + End If + +Exit_Function: + GetRows() = vMatrix() + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvNumRows)) + Set Controls = Nothing + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' GetRows V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +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 = "Recordset.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 ----------------------------------------------------------------------------------------------------------------------- +Public Function Move(ByVal Optional pvRelative As Variant, ByVal Optional pvBookmark As variant) As Boolean +' Move record pointer Relative rows vs. bookmark or current record + + If IsMissing(pvRelative) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvRelative, 1, Utils._AddNumeric()) Then Goto Exit_Function + + If IsMissing(pvBookmark) Then Move = _Move(pvRelative) Else Move = _Move(pvRelative, pvBookmark) + +Exit_Function: + Exit Function +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveFirst() As Boolean + MoveFirst = _Move("First") +End Function ' MoveFirst + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveLast() As Boolean + MoveLast = _Move("Last") +End Function ' MoveLast + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveNext() As Boolean + MoveNext = _Move("Next") +End Function ' MoveNext + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MovePrevious() As Boolean + MovePrevious = _Move("Previous") +End Function ' MovePrevious + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenRecordset(ByVal Optional pvType As Variant _ + , ByVal Optional pvOptions As Variant _ + , ByVal Optional pvLockEdit As Variant _ + , ByVal Optional pbClone As Boolean) As Object +'Return a Recordset object based on current recordset object with filter addition + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" + Utils._SetCalledSub(cstThisSub) + Set OpenRecordset = Nothing +Const cstNull = -1 + +Dim oObject As Object + Set oObject = Nothing + If IsMissing(pvType) Then + pvType = cstNull + Else + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function + End If + If IsMissing(pvOptions) Then + pvOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + If IsMissing(pvLockEdit) Then + pvLockEdit = cstNull + Else + If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function + End If + If IsMissing(pbClone) Then pbClone = False ' pbClone is a not published argument + + Set oObject = New Recordset + With oObject + ._CommandType = _CommandType + ._Command = _Command + ._ParentName = _Name + ._ParentType = _Type + Set ._ParentDatabase = _ParentDatabase + Set ._This = oObject + ._ForwardOnly = ( pvType = dbOpenForwardOnly ) + ._PassThrough = ( pvOptions = dbSQLPassThrough ) + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) + Select Case True + Case pbClone : Call ._Initialize(, RowSet) + Case _Filter <> "" : Call ._Initialize(_Filter) + Case Else : Call ._Initialize() + End Select + End With + With _ParentDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + +Exit_Function: + Set OpenRecordset = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' OpenRecordset + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Const cstThisSub = "Recordset.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, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + Set vProperty._ParentDatabase = _ParentDatabase + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Const cstThisSub = "Recordset.setProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Update() As Boolean +' Finalize the updates of the current record + +Const cstThisSub = "Recordset.Update" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Update = False + + 'Is updating a row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + With RowSet + If .rowDeleted() Then Goto Error_RowDeleted + Select Case _EditMode + Case dbEditNone + Goto Trace_Error_Update + Case dbEditAdd + _AppendChunkClose(False) + If .IsNew And .IsModified Then .insertRow() + _BookmarkLastModified = .getBookmark() + If Not IsNull(_BookmarkBeforeNew) Then + Select Case _BookmarkBeforeNew + Case "_BOF_" : .beforeFirst() + Case "_EOF_" : .afterLast() + Case Else : .moveToBookmark(_BookmarkBeforeNew) + End Select + End If + Case dbEditInProgress + _AppendChunkClose(False) + If .IsModified Then + .updateRow() + _BookmarkLastModified = .getBookmark() + End If + End Select + End With + _EditMode = dbEditNone + Update = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + Goto Exit_Function +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Update + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AppendChunk(ByVal psFieldName As String, ByRef pvChunk As Variant, piChunkType) As Boolean +' Write chunk at the end of the file dedicated to the given field + + If _ErrorHandler() Then On Local Error GoTo Error_Function +Dim oFileAccess As Object +Dim i As Integer, oChunk As Object, iChunk As Integer + + ' Do nothing if chunk meaningless + _AppendChunk = False + If IsNull(pvChunk) Then GoTo Exit_Function + If IsArray(pvChunk) Then + If UBound(pvChunk) < LBound(pvChunk) Then GoTo Exit_Function ' Empty array + End If + + ' Find or create relevant chunk entry + iChunk = -1 + For i = 0 To UBound(_ManageChunks) + Set oChunk = _ManageChunks(i) + If oChunk.FieldName = psFieldName Then + iChunk = i + Exit For + End If + Next i + If iChunk = -1 Then + _AppendChunkInit(psFieldName) + iChunk = UBound(_ManageChunks) + End If + + Set oChunk = _ManageChunks(iChunk) + With oChunk + If Not .ChunksRequested Then ' First chunk + .ChunksRequested = True + .ChunkType = piChunkType + .FileName = Utils._GetRandomFileName(_Name) + Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + .FileHandler = oFileAccess.openFileWrite(.FileName) + End If + .FileHandler.writeBytes(pvChunk) + End With + _AppendChunk = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Recordset._AppendChunk", Erl) + GoTo Exit_Function +End Function ' AppendChunk V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AppendChunkClose(ByVal pbCancel As Boolean) As Boolean +' Stores file content to database field(s) +' Called from Update() [pbCancel = False] or CancelUpdate() [pbCancel = True] + + If _ErrorHandler() Then On Local Error GoTo Error_Function +Dim oFileAccess As Object, oStream As Object, lFileLength As Long, oField As Object +Dim i As Integer, oChunk As Object + + _AppendChunkClose = False + For i = 0 To UBound(_ManageChunks) + Set oChunk = _ManageChunks(i) + With oChunk + If Not .ChunksRequested Then GoTo Exit_Function + If IsNull(.FileHandler) Then GoTo Exit_Function + .Filehandler.closeOutput + Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + ' Copy file to field + If Not pbCancel Then + Set oStream = oFileAccess.openFileRead(.FileName) + lFileLength = oStream.getLength() + If lFileLength > 0 Then + Set oField = RowSet.getColumns.getByName(.FieldName) + Select Case .ChunkType + Case vbByte + oField.updateBinaryStream(oStream, lFileLength) +' Case vbString ' DOES NOT WORK FOR CHARACTER TYPES +' oField.updateCharacterStream(oStream, lFileLength) + End Select + End If + oStream.closeInput() + End If + If oFileAccess.exists(.FileName) Then oFileAccess.kill(.FileName) + End With + Next i + Set _ManageChunks = Array() + _AppendChunkClose = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Recordset._AppendChunkClose", Erl) + GoTo Exit_Function +End Function ' AppendChunkClose V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AppendChunkInit(psFieldName As String) As Boolean +' Initialize chunks manager + +Dim iSize As Integer + iSize = UBound(_ManageChunks) + 1 + ReDim Preserve _ManageChunks(0 To iSize) + Set _ManageChunks(iSize) = New ChunkDescriptor + With _ManageChunks(iSize) + .ChunksRequested = False + .FieldName = psFieldName + .FileName = "" + Set .FileHandler = Nothing + End With + +End Function ' AppendChunkInit V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize(ByVal Optional pvFilter As Variant, Optional poRowSet As Object) +' Initialize new recordset + + If _Command = "" Then Exit Sub + + If _ErrorHandler() Then On Local Error Goto Error_Sub + If IsMissing(pvFilter) Then pvFilter = "" + If Not IsMissing(poRowSet) Then ' Clone + Set RowSet = poRowSet.createResultSet() + _IsClone = True + RowSet.last() ' Solves bookmark desynchro when parent bookmark is used ?!? + Else + Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet") + _IsClone = False + With RowSet + If IsNull(.ActiveConnection) Then Set .ActiveConnection = _ParentDatabase.Connection + .CommandType = _CommandType + .Command = _Command + If _ForwardOnly Then .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY _ + Else .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_SENSITIVE + If _PassThrough Then .EscapeProcessing = False _ + Else .EscapeProcessing = True + If _ReadOnly Then + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_UNCOMMITTED ' Dirty read + Else + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.UPDATABLE + .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_COMMITTED + End If + End With + + If Not IsMissing(pvFilter) Then ' Filter must be set before execute() + If pvFilter <> "" Then + RowSet.Filter = pvFilter + RowSet.ApplyFilter = True + End If + End If + On Local Error Goto SQL_Error + RowSet.execute() + On Local Error Goto Error_Sub + End If + _DataSet = True +'If the Recordset contains no records, the BOF and EOF properties are True, and there is no current record. + _BOF = ( RowSet.IsRowCountFinal And RowSet.RowCount = 0 ) + _EOF = _BOF + +Exit_Sub: + Exit Sub +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , _Command) + Goto Exit_Sub +Error_Sub: + TraceError(TRACEABORT, Err, "Recordset._Initialize", Erl) + GoTo Exit_Sub +End Sub ' _Initialize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Move(pvTarget As Variant, ByVal Optional pvBookmark As Variant, ByVal Optional pbAbsolute As Boolean) As Boolean +'Move to the first, last, next, or previous record in a specified Recordset object and make that record the current record. + +Dim cstThisSub As String + cstThisSub = "Recordset.Move" & Iif(VarType(pvTarget) = vbString, pvTarget, "") + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsNull(RowSet) Then Goto Trace_Closed + If Not _DataSet Then Goto Trace_NoData + If _BOF And _EOF Then Goto Trace_NoData + _Move = False + CancelUpdate() ' Any Move cancels all updates, even Move(0) ! + +Dim l As Long, lRow As Long + With RowSet + Select Case VarType(pvTarget) + Case vbString + Select Case UCase(pvTarget) + Case "FIRST" + If _ForwardOnly Then + If Not ( .isBeforeFirst() Or .isFirst() ) Then + Goto Trace_Forward + Else + .next() + End If + Else + .first() + End If + Case "LAST" + If _ForwardOnly Then + If .isAfterLast() Then Goto Trace_Forward + Do While Not ( .isRowCountFinal And .Row = .RowCount ) ' isLast() = True after reading of first records chunk + .next() + Loop + Else + .last() + End If + Case "NEXT" + If _EOF Then Goto Trace_OutOfRange + .next() + Case "PREVIOUS" + If _ForwardOnly Then Goto Trace_Forward + If _BOF Then Goto Trace_OutOfRange + .previous() + End Select + Case Else ' Relative or absolute move + If IsMissing(pbAbsolute) Then pbAbsolute = False ' Relative move is default + If _ForwardOnly And pvTarget < 0 then Goto Trace_Forward + If IsMissing(pvBookmark) Then + If pvTarget = 0 Then Goto Exit_Function ' Do nothing + If _ForwardOnly Then + If pbAbsolute Then lRow = .getRow() Else lRow = 0 + For l = 1 To pvTarget - lRow + If .isAfterLast() Then Exit For + .next() + Next l + Else + If pbAbsolute Then .absolute(pvTarget) Else .relative(pvTarget) + End If + Else ' Move is always relative when bookmark argument present + If _ForwardOnly Then Goto Trace_Forward + If pvTarget = 0 Then + .moveToBookmark(pvBookmark) + Else + .moveRelativeToBookmark(pvBookmark, pvTarget) + End If + End If + End Select + + _BOF = .isBeforeFirst() ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=76640 + _EOF = .isAfterlast() + If _BOF Or _EOF Then + _Move = False + Else + If .rowDeleted() Then Goto Error_RowDeleted + If .rowUpdated() Then .refreshRow() + _Move = True + End If + End With + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Exit_Close: ' Force close of recordset when error raised + mClose() + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Close +Trace_Forward: + TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0) + Goto Exit_Close +Trace_NoData: + TraceError(TRACEFATAL, ERRRECORDSETNODATA, Utils._CalledSub(), 0) + Goto Exit_Close +Trace_OutOfRange: + TraceError(TRACEFATAL, ERRRECORDSETRANGE, Utils._CalledSub(), 0) + Goto Exit_Close +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Close +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("AbsolutePosition", "BOF", "Bookmarkable", "Bookmark", "EditMode" _ + , "EOF", "Filter", "LastModified", "Name", "ObjectType" , "RecordCount" _ + ) + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "Recordset.get" + Utils._SetCalledSub(cstThisSub & psProperty) + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If IsNull(RowSet) Then Goto Trace_Closed + With RowSet + Select Case True + Case _BOF And _EOF : _PropertyGet = -1 + Case .isBeforeFirst() Or .isAfterLast() : _PropertyGet = -1 + Case Else : _PropertyGet = .getRow() ' Not getRow() - 1 as MSAccess requires + End Select + End With + Case UCase("BOF") + If IsNull(RowSet) Then Goto Trace_Closed + Select Case True + Case _BOF And _EOF : _PropertyGet = True + Case RowSet.isBeforeFirst() : _PropertyGet = True + Case Else : _PropertyGet = False + End Select + Case UCase("Bookmarkable") + If IsNull(RowSet) Then Goto Trace_Closed + If _ForwardOnly Then _PropertyGet = False Else _PropertyGet = RowSet.IsBookmarkable + Case UCase("Bookmark") + If IsNull(RowSet) Then Goto Trace_Closed + If RowSet.IsBookmarkable And Not _ForwardOnly Then + If _BOF Or _EOF Then _PropertyGet = Null Else _PropertyGet = RowSet.getBookmark() + Else + _PropertyGet = Null + If _ForwardOnly Then Goto Trace_Forward + End If + Case UCase("EditMode") + If IsNull(RowSet) Then Goto Trace_Closed + _PropertyGet = _EditMode + Case UCase("EOF") + If IsNull(RowSet) Then Goto Trace_Closed + Select Case True + Case _BOF And _EOF : _PropertyGet = True + Case RowSet.isAfterLast() : _PropertyGet = True + Case Else : _PropertyGet = False + End Select + Case UCase("Filter") + If IsNull(RowSet) Then Goto Trace_Closed + _PropertyGet = RowSet.Filter + Case UCase("LastModified") + If IsNull(RowSet) Then Goto Trace_Closed + If RowSet.IsBookmarkable And Not _ForwardOnly Then + _PropertyGet = _BookmarkLastModified + Else + _PropertyGet = Null + If _ForwardOnly Then Goto Trace_Forward + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("RecordCount") + If IsNull(RowSet) Then Goto Trace_Closed + _PropertyGet = RowSet.RowCount + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Forward: + TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + +Dim cstThisSub As String + cstThisSub = "Recordset.set" + Utils._SetCalledSub(cstThisSub & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer +Dim oObject As Object + + If _IsLeft(_A2B_.CalledSub, "Recordset.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Then Goto Trace_Error_Value + _Move(pvValue, , True) + Case UCase("Bookmark") + If IsNull(RowSet) Then Goto Trace_Closed + _Move(0, pvValue) + Case UCase("Filter") + If IsNull(RowSet) Then Goto Trace_Closed + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + _Filter = _ParentDatabase._ReplaceSquareBrackets(pvValue) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Root_.xba b/wizards/source/access2base/Root_.xba new file mode 100644 index 000000000..73f743278 --- /dev/null +++ b/wizards/source/access2base/Root_.xba @@ -0,0 +1,311 @@ +<?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="Root_" 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 --- FOR INTERNAL USE ONLY --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private ErrorHandler As Boolean +Private MinimalTraceLevel As Integer +Private TraceLogs() As Variant +Private TraceLogCount As Integer +Private TraceLogLast As Integer +Private TraceLogMaxEntries As Integer +Private LastErrorCode As Integer +Private LastErrorLevel As String +Private ErrorText As String +Private ErrorLongText As String +Private CalledSub As String +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 +Private TempVars As Object ' Collection +Private CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents +Private PythonCache() As Variant ' Array of objects created in Python scripts + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + VersionNumber = Access2Base_Version + ErrorHandler = True + MinimalTraceLevel = 0 + TraceLogs() = Array() + TraceLogCount = 0 + TraceLogLast = 0 + TraceLogMaxEntries = 0 + LastErrorCode = 0 + LastErrorLevel = "" + ErrorText = "" + ErrorLongText = "" + 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 + Set TempVars = New Collection + CurrentDoc = Array() + ReDim CurrentDoc(0 To 0) + Set CurrentDoc(0) = Nothing + PythonCache = Array() +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + 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 ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AddPython(ByRef pvObject As Variant) As Long +' Store the object as a new entry in PythonCache and return its entry number + +Dim lVars As Long, vObject As Variant + + lVars = UBound(PythonCache) + 1 + ReDim Preserve PythonCache(0 To lVars) + PythonCache(lVars) = pvObject + + AddPython = lVars + +End Function ' AddPython V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub CloseConnection() +' Close all connections established by current document to free memory. +' - if Base document => close the one concerned database connection +' - if non-Base documents => close the connections of each individual standalone form + +Dim i As Integer, iCurrentDoc As Integer +Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant + + If ErrorHandler Then On Local Error Goto Error_Sub + + If Not IsArray(CurrentDoc) Then Goto Exit_Sub + If UBound(CurrentDoc) < 0 Then Goto Exit_Sub + iCurrentDoc = CurrentDocIndex( , False) ' False prevents error raising if not found + If iCurrentDoc < 0 Then GoTo Exit_Sub ' If not found ignore + + vDocContainer = CurrentDocument(iCurrentDoc) + With vDocContainer + If Not .Active Then GoTo Exit_Sub ' e.g. if multiple calls to CloseConnection() + For i = 0 To UBound(.DbContainers) + If Not IsNull(.DbContainers(i).Database) Then + .DbContainers(i).Database.Dispose() + Set .DbContainers(i).Database = Nothing + End If + TraceLog(TRACEANY, UCase(CalledSub) & " " & .URL & Iif(i = 0, "", " Form=" & .DbContainers(i).FormName), False) + Set .DbContainers(i) = Nothing + Next i + .DbContainers = Array() + .URL = "" + .DbConnect = 0 + .Active = False + Set .Document = Nothing + End With + CurrentDoc(iCurrentDoc) = vDocContainer + +Exit_Sub: + Exit Sub +Error_Sub: + TraceError(TRACEABORT, Err, CalledSub, Erl, False) ' No error message addressed to the user, only stored in console + GoTo Exit_Sub +End Sub ' CloseConnection + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties + +Dim iCurrentDoc As Integer + + Set CurrentDb = Nothing + + If Not IsArray(CurrentDoc) Then Goto Exit_Function + If UBound(CurrentDoc) < 0 Then Goto Exit_Function + iCurrentDoc = CurrentDocIndex(, False) ' False = no abort + If iCurrentDoc >= 0 Then + If UBound(CurrentDoc(iCurrentDoc).DbContainers) >= 0 Then Set CurrentDb = CurrentDoc(iCurrentDoc).DbContainers(0).Database + End If + +Exit_Function: + Exit Function +End Function ' CurrentDb + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDocIndex(Optional pvURL As Variant, Optional pbAbort As Variant) As Integer +' Returns the entry in CurrentDoc(...) referring to the current document + +Dim i As Integer, bFound As Boolean, sURL As String +Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument" + + bFound = False + CurrentDocIndex = -1 + + If Not IsArray(CurrentDoc) Then Goto Trace_Error + If UBound(CurrentDoc) < 0 Then Goto Trace_Error + For i = 1 To UBound(CurrentDoc) ' [0] reserved to database .odb document + If IsMissing(pvURL) Then ' Not on 1 single line ?!? + If Utils._hasUNOProperty(ThisComponent, "URL") Then + sURL = ThisComponent.URL + Else + Exit For ' f.i. ThisComponent = Basic IDE ... + End If + Else + sURL = pvURL ' To support the SelectObject action + End If + If CurrentDoc(i).Active And CurrentDoc(i).URL = sURL Then + CurrentDocIndex = i + bFound = True + Exit For + End If + Next i + + If Not bFound Then + If IsNull(CurrentDoc(0)) Then GoTo Trace_Error + With CurrentDoc(0) + If Not .Active Then GoTo Trace_Error + If IsNull(.Document) Then GoTo Trace_Error + End With + CurrentDocIndex = 0 + End If + +Exit_Function: + Exit Function +Trace_Error: + If IsMissing(pbAbort) Then pbAbort = True + If pbAbort Then TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Else CurrentDocIndex = -1 + Goto Exit_Function +End Function ' CurrentDocIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDocument(ByVal Optional piDocIndex As Integer) As Variant +' Returns the CurrentDoc(...) referring to the current document or to the argument + +Dim iDocIndex As Integer + If IsMissing(piDocIndex) Then iDocIndex = CurrentDocIndex(, False) Else iDocIndex = piDocIndex + If iDocIndex >= 0 And iDocIndex <= UBound(CurrentDoc) Then Set CurrentDocument = CurrentDoc(iDocIndex) Else Set CurrentDocument = Nothing + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dump() +' For debugging purposes +Dim i As Integer, j As Integer, vCurrentDoc As Variant + On Local Error Resume Next + + DebugPrint "Version", VersionNumber + DebugPrint "TraceLevel", MinimalTraceLevel + DebugPrint "TraceCount", TraceLogCount + DebugPrint "CalledSub", CalledSub + If IsArray(CurrentDoc) Then + For i = 0 To UBound(CurrentDoc) + vCurrentDoc = CurrentDoc(i) + If Not IsNull(vCurrentDoc) Then + DebugPrint i, "URL", vCurrentDoc.URL + For j = 0 To UBound(vCurrentDoc.DbContainers) + DebugPrint i, j, "Form", vCurrentDoc.DbContainers(j).FormName + DebugPrint i, j, "Database", vCurrentDoc.DbContainers(j).Database.Title + Next j + End If + Next i + End If + +End Sub + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasItem(psCollType As String, ByVal psName As String) As Boolean +' Return True if psName if in the collection + +Dim oItem As Object + On Local Error Goto Error_Function ' Whatever ErrorHandler ! + + hasItem = True + Select Case psCollType + Case COLLALLDIALOGS + Set oItem = Dialogs.Item(UCase(psName)) + Case COLLTEMPVARS + Set oItem = TempVars.Item(UCase(psName)) + Case Else + hasItem = False + End Select + +Exit_Function: + Exit Function +Error_Function: ' Item by key aborted + hasItem = False + GoTo Exit_Function +End Function ' hasItem + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant +REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use) +REM With 2 arguments return the corresponding entry in Root + +Dim odbDatabase As Variant + If IsMissing(piDocEntry) Then + Set odbDatabase = CurrentDb() + Else + If Not IsArray(CurrentDoc) Then Goto Trace_Error + If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error + If piDocEntry > UBound(CurrentDoc) Then Goto Trace_Error + If piDbEntry > UBound(CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error + Set odbDatabase = CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database + End If + If IsNull(odbDatabase) Then GoTo Trace_Error + +Exit_Function: + Set _CurrentDb = odbDatabase + Exit Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) + Goto Exit_Function +End Function ' _CurrentDb + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/SubForm.xba b/wizards/source/access2base/SubForm.xba new file mode 100644 index 000000000..d905a9836 --- /dev/null +++ b/wizards/source/access2base/SubForm.xba @@ -0,0 +1,757 @@ +<?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="SubForm" 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 SUBFORM +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Shortcut As String +Private _Name As String +Private _MainForm As String +Private _DocEntry As Integer +Private _DbEntry As Integer +Private _OrderBy As String +Public ParentComponent As Object ' com.sun.star.text.TextDocument +Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJSUBFORM + Set _This = Nothing + Set _Parent = Nothing + _Shortcut = "" + _Name = "" + _MainForm = "" + _DocEntry = -1 + _DbEntry = -1 + _OrderBy = "" + Set ParentComponent = Nothing + Set DatabaseForm = Nothing +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 ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowAdditions() As Variant + AllowAdditions = _PropertyGet("AllowAdditions") +End Property ' AllowAdditions (get) + +Property Let AllowAdditions(ByVal pvValue As Variant) + Call _PropertySet("AllowAdditions", pvValue) +End Property ' AllowAdditions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowDeletions() As Variant + AllowDeletions = _PropertyGet("AllowDeletions") +End Property ' AllowDeletions (get) + +Property Let AllowDeletions(ByVal pvValue As Variant) + Call _PropertySet("AllowDeletions", pvValue) +End Property ' AllowDeletions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowEdits() As Variant + AllowEdits = _PropertyGet("AllowEdits") +End Property ' AllowEdits (get) + +Property Let AllowEdits(ByVal pvValue As Variant) + Call _PropertySet("AllowEdits", pvValue) +End Property ' AllowEdits (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get CurrentRecord() As Variant + CurrentRecord = _PropertyGet("CurrentRecord") +End Property ' CurrentRecord (get) + +Property Let CurrentRecord(ByVal pvValue As Variant) + Call _PropertySet("CurrentRecord", pvValue) +End Property ' CurrentRecord (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Filter() As Variant + Filter = _PropertyGet("Filter") +End Property ' Filter (get) + +Property Let Filter(ByVal pvValue As Variant) + Call _PropertySet("Filter", pvValue) +End Property ' Filter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FilterOn() As Variant + FilterOn = _PropertyGet("FilterOn") +End Property ' FilterOn (get) + +Property Let FilterOn(ByVal pvValue As Variant) + Call _PropertySet("FilterOn", pvValue) +End Property ' FilterOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get LinkChildFields(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then LinkChildFields = _PropertyGet("LinkChildFields") Else LinkChildFields = _PropertyGet("LinkChildFields", pvIndex) +End Property ' LinkChildFields (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get LinkMasterFields(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then LinkMasterFields = _PropertyGet("LinkMasterFields") Else LinkMasterFields = _PropertyGet("LinkMasterFields", pvIndex) +End Property ' LinkMasterFields (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveCursorMove() As Variant + OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") +End Property ' OnApproveCursorMove (get) + +Property Let OnApproveCursorMove(ByVal pvValue As Variant) + Call _PropertySet("OnApproveCursorMove", pvValue) +End Property ' OnApproveCursorMove (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveParameter() As Variant + OnApproveParameter = _PropertyGet("OnApproveParameter") +End Property ' OnApproveParameter (get) + +Property Let OnApproveParameter(ByVal pvValue As Variant) + Call _PropertySet("OnApproveParameter", pvValue) +End Property ' OnApproveParameter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' OnApproveReset (get) + +Property Let OnApproveReset(ByVal pvValue As Variant) + Call _PropertySet("OnApproveReset", pvValue) +End Property ' OnApproveReset (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveRowChange() As Variant + OnApproveRowChange = _PropertyGet("OnApproveRowChange") +End Property ' OnApproveRowChange (get) + +Property Let OnApproveRowChange(ByVal pvValue As Variant) + Call _PropertySet("OnApproveRowChange", pvValue) +End Property ' OnApproveRowChange (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveSubmit() As Variant + OnApproveSubmit = _PropertyGet("OnApproveSubmit") +End Property ' OnApproveSubmit (get) + +Property Let OnApproveSubmit(ByVal pvValue As Variant) + Call _PropertySet("OnApproveSubmit", pvValue) +End Property ' OnApproveSubmit (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnConfirmDelete() As Variant + OnConfirmDelete = _PropertyGet("OnConfirmDelete") +End Property ' OnConfirmDelete (get) + +Property Let OnConfirmDelete(ByVal pvValue As Variant) + Call _PropertySet("OnConfirmDelete", pvValue) +End Property ' OnConfirmDelete (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnCursorMoved() As Variant + OnCursorMoved = _PropertyGet("OnCursorMoved") +End Property ' OnCursorMoved (get) + +Property Let OnCursorMoved(ByVal pvValue As Variant) + Call _PropertySet("OnCursorMoved", pvValue) +End Property ' OnCursorMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' OnErrorOccurred (get) + +Property Let OnErrorOccurred(ByVal pvValue As Variant) + Call _PropertySet("OnErrorOccurred", pvValue) +End Property ' OnErrorOccurred (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoaded() As Variant + OnLoaded = _PropertyGet("OnLoaded") +End Property ' OnLoaded (get) + +Property Let OnLoaded(ByVal pvValue As Variant) + Call _PropertySet("OnLoaded", pvValue) +End Property ' OnLoaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloaded() As Variant + OnReloaded = _PropertyGet("OnReloaded") +End Property ' OnReloaded (get) + +Property Let OnReloaded(ByVal pvValue As Variant) + Call _PropertySet("OnReloaded", pvValue) +End Property ' OnReloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloading() As Variant + OnReloading = _PropertyGet("OnReloading") +End Property ' OnReloading (get) + +Property Let OnReloading(ByVal pvValue As Variant) + Call _PropertySet("OnReloading", pvValue) +End Property ' OnReloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnResetted() As Variant + OnResetted = _PropertyGet("OnResetted") +End Property ' OnResetted (get) + +Property Let OnResetted(ByVal pvValue As Variant) + Call _PropertySet("OnResetted", pvValue) +End Property ' OnResetted (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnRowChanged() As Variant + OnRowChanged = _PropertyGet("OnRowChanged") +End Property ' OnRowChanged (get) + +Property Let OnRowChanged(ByVal pvValue As Variant) + Call _PropertySet("OnRowChanged", pvValue) +End Property ' OnRowChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloaded() As Variant + OnUnloaded = _PropertyGet("OnUnloaded") +End Property ' OnUnloaded (get) + +Property Let OnUnloaded(ByVal pvValue As Variant) + Call _PropertySet("OnUnloaded", pvValue) +End Property ' OnUnloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloading() As Variant + OnUnloading = _PropertyGet("OnUnloading") +End Property ' OnUnloading (get) + +Property Let OnUnloading(ByVal pvValue As Variant) + Call _PropertySet("OnUnloading", pvValue) +End Property ' OnUnloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name + +Const cstThisSub = "SubForm.OptionGroup" +Dim ogGroup As Object + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, ParentComponent, DatabaseForm) + If Not IsNull(ogGroup) Then + ogGroup._DocEntry = _DocEntry + ogGroup._DbEntry = _DbEntry + End If + Set OptionGroup = ogGroup + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' OptionGroup V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderBy() As Variant + OrderBy = _PropertyGet("OrderBy") +End Property ' OrderBy (get) V1.2.0 + +Property Let OrderBy(ByVal pvValue As Variant) + Call _PropertySet("OrderBy", pvValue) +End Property ' OrderBy (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderByOn() As Variant + OrderByOn = _PropertyGet("OrderByOn") +End Property ' OrderByOn (get) V1.2.0 + +Property Let OrderByOn(ByVal pvValue As Variant) + Call _PropertySet("OrderByOn", pvValue) +End Property ' OrderByOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + + Utils._SetCalledSub("SubForm.getParent") + On Error Goto Error_Function + + Set Parent = _Parent + +Exit_Function: + Utils._ResetCalledSub("SubForm.getParent") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.getParent", Erl) + Set Parent = Nothing + GoTo Exit_Function +End Function ' Parent + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Recordset() As Object + Recordset = _PropertyGet("Recordset") +End Property ' Recordset (get) V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RecordSource() As Variant + RecordSource = _PropertyGet("RecordSource") +End Property ' RecordSource (get) + +Property Let RecordSource(ByVal pvValue As Variant) + Call _PropertySet("RecordSource", pvValue) +End Property ' RecordSource (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("SubForm.Controls") + +Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer + + Set ocControl = Nothing + iControlCount = DatabaseForm.getCount() + + If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + oCounter._Parent = _This + oCounter._Count = iControlCount + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISSUBFORM + sParentShortcut = _Shortcut + sControls() = DatabaseForm.getElementNames() + + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + ocControl._Name = sControls(pvIndex) + Case vbString ' Check control name validity (non case sensitive) + bFound = False + sIndex = UCase(Utils._Trim(pvIndex)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sIndex Then + bFound = True + Exit For + End If + Next i + If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + End Select + + With ocControl + ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) + Set .ControlModel = DatabaseForm.getByName(._Name) + ._ImplementationName = .ControlModel.getImplementationName() + ._FormComponent = ParentComponent + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + If ._ClassId > 0 And ._ClassId <> acHiddenControl Then + Set .ControlView = ParentComponent.CurrentController.getControl(.ControlModel) + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("SubForm.Controls") + Exit Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("SubForm.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("SubForm.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Refresh() As Boolean +' Refresh data with its most recent value in the database in a form or subform + Utils._SetCalledSub("SubForm.Refresh") + If _ErrorHandler() Then On Local Error Goto Error_Function + Refresh = False + +Dim oSet As Object + Set oSet = DatabaseForm.createResultSet() + If Not IsNull(oSet) Then + oSet.refreshRow() + Refresh = True + End If + +Exit_Function: + Set oSet = Nothing + Utils._ResetCalledSub("SubForm.Refresh") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl) + GoTo Exit_Function +End Function ' Refresh + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery() As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("SubForm.Requery") + If _ErrorHandler() Then On Local Error Goto Error_Function + Requery = False + + DatabaseForm.reload() + Requery = True + +Exit_Function: + Utils._ResetCalledSub("SubForm.Requery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Requery", Erl) + GoTo Exit_Function +End Function ' Requery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("SubForm.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("SubForm.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnApproveCursorMove") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveParameter") + _GetListener = "XDatabaseParameterListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveRowChange") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveSubmit") + _GetListener = "XSubmitListener" + Case UCase("OnConfirmDelete") + _GetListener = "XConfirmDeleteListener" + Case UCase("OnCursorMoved"), UCase("OnRowChanged") + _GetListener = "XRowSetListener" + Case UCase("OnErrorOccurred") + _GetListener = "XSQLErrorListener" + Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") + _GetListener = "XLoadListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "CurrentRecord" _ + , "Filter", "FilterOn", "LinkChildFields", "LinkMasterFields", "Name" _ + , "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _ + , "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _ + , "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _ + , "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OrderBy" _ + , "OrderByOn", "Parent", "RecordSource" _ + ) ' Recordset removed + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("SubForm.get" & psProperty) +Dim iArgNr As Integer + If Not IsMissing(pvIndex) Then + Select Case UCase(_A2B_.CalledSub) + Case UCase("getProperty") : iArgNr = 3 + Case UCase("SubForm.getProperty") : iArgNr = 2 + Case UCase("SubForm.get" & psProperty) : iArgNr = 1 + End Select + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + End If + +'Execute +Dim oDatabase As Object, vBookmark As Variant, oObject As Object + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + _PropertyGet = DatabaseForm.AllowInserts + Case UCase("AllowDeletions") + _PropertyGet = DatabaseForm.AllowDeletes + Case UCase("AllowEdits") + _PropertyGet = DatabaseForm.AllowUpdates + Case UCase("CurrentRecord") + _PropertyGet = DatabaseForm.Row + Case UCase("Filter") + _PropertyGet = DatabaseForm.Filter + Case UCase("FilterOn") + _PropertyGet = DatabaseForm.ApplyFilter + Case UCase("LinkChildFields") + If Utils._hasUNOProperty(DatabaseForm, "DetailFields") Then + If IsMissing(pvIndex) Then + _PropertyGet = DatabaseForm.DetailFields + Else + If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.DetailFields) Then Goto trace_Error_Index + _PropertyGet = DatabaseForm.DetailFields(pvIndex) + End If + End If + Case UCase("LinkMasterFields") + If Utils._hasUNOProperty(DatabaseForm, "MasterFields") Then + If IsMissing(pvIndex) Then + _PropertyGet = DatabaseForm.MasterFields + Else + If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.MasterFields) Then Goto trace_Error_Index + _PropertyGet = DatabaseForm.MasterFields(pvIndex) + End If + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + _PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name) + Case UCase("OrderBy") + _PropertyGet = _OrderBy + Case UCase("OrderByOn") + If DatabaseForm.Order = "" Then _PropertyGet = False Else _PropertyGet = True + Case UCase("Parent") ' Only for indirect access from property object + _PropertyGet = Parent + Case UCase("Recordset") + If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? + Set oObject = New Recordset + With DatabaseForm + Set oObject._This = oObject + oObject._CommandType = .CommandType + oObject._Command = .Command + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Set oObject._ParentDatabase = oDatabase + Set oObject._ParentDatabase.Connection = .ActiveConnection + oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) + oObject._PassThrough = ( .EscapeProcessing = False ) + oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) + Call oObject._Initialize() + End With + With oDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + Set _PropertyGet = oObject + Case UCase("RecordSource") + _PropertyGet = DatabaseForm.Command + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("SubForm.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("SubForm.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "SubForm.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.AllowInserts = pvValue + DatabaseForm.reload() + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.AllowDeletes = pvValue + DatabaseForm.reload() + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.AllowUpdates = pvValue + DatabaseForm.reload() + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + DatabaseForm.absolute(pvValue) + Case UCase("Filter") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.ApplyFilter = pvValue + DatabaseForm.reload() + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Not Utils._RegisterEventScript(DatabaseForm _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue, _Name _ + ) Then GoTo Trace_Error + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + _OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = "" + DatabaseForm.reload() + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND + DatabaseForm.Filter = "" + DatabaseForm.reload() + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("SubForm.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/TempVar.xba b/wizards/source/access2base/TempVar.xba new file mode 100644 index 000000000..d600de3b2 --- /dev/null +++ b/wizards/source/access2base/TempVar.xba @@ -0,0 +1,195 @@ +<?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="TempVar" 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 TEMPVAR +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Value As Variant + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJTEMPVAR + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _Value = Null +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 ----------------------------------------------------------------------------------------------------------------------- + +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 ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("TempVar.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("TempVar.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("TempVar.getProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("TempVar.getProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Name", "ObjectType", "Value") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("TempVar.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + _PropertyGet = _Value + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("TempVar.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "TempVar._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("TempVar.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "TempVar.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("Value") + _Value = pvValue + _A2B_.TempVars.Item(UCase(_Name)).Value = pvValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("TempVar.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "TempVar._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Test.xba b/wizards/source/access2base/Test.xba new file mode 100644 index 000000000..7ad95904e --- /dev/null +++ b/wizards/source/access2base/Test.xba @@ -0,0 +1,14 @@ +<?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="Test" script:language="StarBasic">Option Explicit +'Option Compatible + +Sub Main +Dim a, b() + _ErrorHandler(False) +' DebugPrint vbLF +' TraceConsole() + exit sub +End Sub + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Trace.xba b/wizards/source/access2base/Trace.xba new file mode 100644 index 000000000..220f1f623 --- /dev/null +++ b/wizards/source/access2base/Trace.xba @@ -0,0 +1,432 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Trace" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +Public Const cstLogMaxEntries = 99 + +REM Typical Usage +REM TraceLog("INFO", "The OK button was pressed") +REM +REM Typical Usage for error logging +REM Sub MySub() +REM On Local Error GoTo Error_Sub +REM ... +REM Exit_Sub: +REM Exit Sub +REM Error_Sub: +REM TraceError("ERROR", Err, "MySub", Erl) +REM GoTo Exit_Sub +REM End Sub +REM +REM To display the current logged traces and/or to set parameters +REM TraceConsole() + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceConsole() +' Display the Trace dialog with current trace log values and parameter choices + If _ErrorHandler() Then On Local Error Goto Error_Sub + +Dim sLineBreak As String, oTraceDialog As Object + sLineBreak = vbNewLine + + Set oTraceDialog = CreateUnoDialog(Utils._GetDialogLib().dlgTrace) + oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE") + oTraceDialog.Model.HelpText = _GetLabel("DLGTRACE_HELP") + +Dim oEntries As Object, oTraceLog As Object, oClear As Object, oMinLevel As Object, oNbEntries As Object, oDump As Object +Dim oControl As Object +Dim i As Integer, sText As String, iOKCancel As Integer + + Set oNbEntries = oTraceDialog.Model.getByName("numNbEntries") + oNbEntries.Value = _A2B_.TraceLogCount + oNbEntries.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblNbEntries") + oControl.Label = _GetLabel("DLGTRACE_LBLNBENTRIES_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP") + + Set oEntries = oTraceDialog.Model.getByName("numEntries") + If _A2B_.TraceLogMaxEntries = 0 Then _A2B_.TraceLogMaxEntries = cstLogMaxEntries + oEntries.Value = _A2B_.TraceLogMaxEntries + oEntries.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblEntries") + oControl.Label = _GetLabel("DLGTRACE_LBLENTRIES_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP") + + Set oDump = oTraceDialog.Model.getByName("cmdDump") + oDump.Enabled = 0 + oDump.Label = _GetLabel("DLGTRACE_CMDDUMP_LABEL") + oDump.HelpText = _GetLabel("DLGTRACE_CMDDUMP_HELP") + + Set oTraceLog = oTraceDialog.Model.getByName("txtTraceLog") + oTraceLog.HelpText = _GetLabel("DLGTRACE_TXTTRACELOG_HELP") + If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized + oTraceLog.HardLineBreaks = True + sText = "" + If _A2B_.TraceLogCount > 0 Then + If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast + Do + If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0 + If Len(_A2B_.TraceLogs(i)) > 11 Then + sText = sText & Right(_A2B_.TraceLogs(i), Len(_A2B_.TraceLogs(i)) - 11) & sLineBreak ' Skip date in display + End If + Loop While i <> _A2B_.TraceLogLast + oDump.Enabled = 1 ' Enable DumpToFile only if there is something to dump + End If + If Len(sText) > 0 Then sText = Left(sText, Len(sText) - Len(sLineBreak)) ' Skip last linefeed + oTraceLog.Text = sText + Else + oTraceLog.Text = _GetLabel("DLGTRACE_TXTTRACELOG_TEXT") + End If + + Set oClear = oTraceDialog.Model.getByName("chkClear") + oClear.State = 0 ' Unchecked + oClear.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblClear") + oControl.Label = _GetLabel("DLGTRACE_LBLCLEAR_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP") + + Set oMinLevel = oTraceDialog.Model.getByName("cboMinLevel") + If _A2B_.MinimalTraceLevel = 0 Then _A2B_.MinimalTraceLevel = _TraceLevel(TRACEERRORS) + oMinLevel.Text = _TraceLevel(_A2B_.MinimalTraceLevel) + oMinLevel.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblMinLevel") + oControl.Label = _GetLabel("DLGTRACE_LBLMINLEVEL_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP") + + Set oControl = oTraceDialog.Model.getByName("cmdOK") + oControl.Label = _GetLabel("DLGTRACE_CMDOK_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_CMDOK_HELP") + + Set oControl = oTraceDialog.Model.getByName("cmdCancel") + oControl.Label = _GetLabel("DLGTRACE_CMDCANCEL_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_CMDCANCEL_HELP") + + iOKCancel = oTraceDialog.Execute() + + Select Case iOKCancel + Case 1 ' OK + If oClear.State = 1 Then + _A2B_.TraceLogs() = Array() ' Erase logged traces + _A2B_.TraceLogCount = 0 + End If + If oMinLevel.Text <> "" Then _A2B_.MinimalTraceLevel = _TraceLevel(oMinLevel.Text) + If oEntries.Value <> 0 And oEntries.Value <> _A2B_.TraceLogMaxEntries Then + _A2B_.TraceLogs() = Array() + _A2B_.TraceLogMaxEntries = oEntries.Value + End If + Case 0 ' Cancel + Case Else + End Select + +Exit_Sub: + If Not IsNull(oTraceDialog) Then oTraceDialog.Dispose() + Exit Sub +Error_Sub: + With _A2B_ + .TraceLogs() = Array() + .TraceLogCount = 0 + .TraceLogLast = 0 + End With + GoTo Exit_Sub +End Sub ' TraceConsole V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceError(ByVal psErrorLevel As String _ + , ByVal piErrorCode As Integer _ + , ByVal psErrorProc As String _ + , ByVal piErrorLine As Integer _ + , ByVal Optional pvMsgBox As Variant _ + , ByVal Optional pvArgs As Variant _ + ) +' Store error code and description in trace rolling buffer +' Display error message if errorlevel >= ERROR +' Stop program execution if errorlevel = FATAL or ABORT + + On Local Error Resume Next + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session + +Dim sErrorText As String, sErrorDesc As String, oDb As Object + sErrorDesc = _ErrorMessage(piErrorCode, pvArgs) + sErrorText = _GetLabel("ERR#") & CStr(piErrorCode) _ + & " (" & sErrorDesc & ") " & _GetLabel("ERROCCUR") _ + & Iif(piErrorLine > 0, " " & _GetLabel("ERRLINE") & " " & CStr(piErrorLine), "") _ + & Iif(psErrorProc <> "", " " & _GetLabel("ERRIN") & " " & psErrorProc, Iif(_A2B_.CalledSub = "", "", " " & _Getlabel("ERRIN") & " " & _A2B_.CalledSub)) + With _A2B_ + .LastErrorCode = piErrorCode + .LastErrorLevel = psErrorLevel + .ErrorText = sErrorDesc + .ErrorLongText = sErrorText + .CalledSub = "" + End With + If IsMissing(pvMsgBox) Then pvMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT ) + TraceLog(psErrorLevel, sErrorText, pvMsgBox) + + ' Unexpected error detected in user program or in Access2Base + If psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT Then + If psErrorLevel = TRACEFATAL Then + Set oDb = _A2B_.CurrentDb() + If Not IsNull(oDb) Then oDb.CloseAllrecordsets() + End If + Stop + End If + +End Sub ' TraceError V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TraceErrorCode() As Variant +' Return the last encountered error code, level, description in an array +' UNPUBLISHED + +Dim vError As Variant + + With _A2B_ + vError = Array( _ + .LastErrorCode _ + , .LastErrorLevel _ + , .ErrorText _ + , .ErrorLongText _ + ) + End With + TraceErrorCode = vError + +End Function ' TraceErrorCode V6.3 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceLevel(ByVal Optional psTraceLevel As String) +' Set trace level to argument + + If _ErrorHandler() Then On Local Error Goto Error_Sub + Select Case True + Case IsMissing(psTraceLevel) : psTraceLevel = "ERROR" + Case psTraceLevel = "" : psTraceLevel = "ERROR" + Case Utils._InList(UCase(psTraceLevel), Array( _ + TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT _ + )) + Case Else : Goto Exit_Sub + End Select + _A2B_.MinimalTraceLevel = _TraceLevel(psTraceLevel) + +Exit_Sub: + Exit Sub +Error_Sub: + With _A2B_ + .TraceLogs() = Array() + .TraceLogCount = 0 + .TraceLogLast = 0 + End With + GoTo Exit_Sub +End Sub ' TraceLevel V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceLog(Byval psTraceLevel As String _ + , ByVal psText As String _ + , ByVal Optional pbMsgBox As Boolean _ + ) +' Store Text in trace log (circular buffer) + + If _ErrorHandler() Then On Local Error Goto Error_Sub +Dim vTraceLogs() As String, sTraceLevel As String + + With _A2B_ + If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) + If _TraceLevel(psTraceLevel) < .MinimalTraceLevel Then Exit Sub + + If UBound(.TraceLogs) = -1 Then ' Initialize TraceLog + If .TraceLogMaxEntries = 0 Then .TraceLogMaxEntries = cstLogMaxEntries + + Redim vTraceLogs(0 To .TraceLogMaxEntries - 1) + .TraceLogs = vTraceLogs + .TraceLogCount = 0 + .TraceLogLast = -1 + If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) ' Set default value + End If + + .TraceLogLast = .TraceLogLast + 1 + If .TraceLogLast > UBound(.TraceLogs) Then .TraceLogLast = LBound(.TraceLogs) ' Circular buffer + If Len(psTraceLevel) > 7 Then sTraceLevel = Left(psTraceLevel, 7) Else sTraceLevel = psTraceLevel & Spc(8 - Len(psTraceLevel)) + .TraceLogs(.TraceLogLast) = Format(Now(), "YYYY-MM-DD hh:mm:ss") & " " & sTraceLevel & psText + If .TraceLogCount <= UBound(.TraceLogs) Then .TraceLogCount = .TraceLogCount + 1 ' # of active entries + End With + + If IsMissing(pbMsgBox) Then pbMsgBox = True +Dim iMsgBox As Integer + If pbMsgBox Then + Select Case psTraceLevel + Case TRACEINFO: iMsgBox = vbInformation + Case TRACEERRORS, TRACEWARNING: iMsgBox = vbExclamation + Case TRACEFATAL, TRACEABORT: iMsgBox = vbCritical + Case Else: iMsgBox = vbInformation + End Select + MsgBox psText, vbOKOnly + iMsgBox, psTraceLevel + End If + +Exit_Sub: + Exit Sub +Error_Sub: + With _A2B_ + .TraceLogs() = Array() + .TraceLogCount = 0 + .TraceLogLast = 0 + End With + GoTo Exit_Sub +End Sub ' TraceLog V0.9.5 + + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private Sub _DumpToFile(oEvent As Object) +' Execute the Dump To File command from the Trace dialog +' Modified from Andrew Pitonyak's Base Macro Programming §10.4 + + + If _ErrorHandler() Then On Local Error GoTo Error_Sub + +Dim sPath as String, iFileNumber As Integer, i As Integer + + sPath = _PromptFilePicker("txt") + If sPath <> "" Then ' Save button pressed + If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized + iFileNumber = FreeFile() + Open sPath For Append Access Write Lock Read As iFileNumber + If _A2B_.TraceLogCount > 0 Then + If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast + Do + If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0 + Print #iFileNumber _A2B_.TraceLogs(i) + Loop While i <> _A2B_.TraceLogLast + End If + Close iFileNumber + MsgBox _GetLabel("SAVECONSOLEENTRIES"), vbOK + vbInformation, _GetLabel("SAVECONSOLE") + End If + End If + +Exit_Sub: + Exit Sub +Error_Sub: + TraceError("ERROR", Err, "DumpToFile", Erl) + GoTo Exit_Sub +End Sub ' DumpToFile V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ErrorHandler(Optional ByVal pbCheck As Boolean) As Boolean +' Indicate if error handler is activated or not +' When argument present set error handler + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session + If Not IsMissing(pbCheck) Then _A2B_.ErrorHandler = pbCheck + _ErrorHandler = _A2B_.ErrorHandler + Exit Function +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _ErrorMessage(ByVal piErrorNumber As Integer, Optional ByVal pvArgs As Variant) As String +' Return error message corresponding to ErrorNumber (standard or not) +' and replaces %0, %1, ... , %9 by psArgs(0), psArgs(1), ... + +Dim sErrorMessage As String, i As Integer, sErrLabel + _ErrorMessage = "" + If piErrorNumber > ERRINIT Then + sErrLabel = "ERR" & piErrorNumber + sErrorMessage = _Getlabel(sErrLabel) + If Not IsMissing(pvArgs) Then + If Not IsArray(pvArgs) Then + sErrorMessage = Join(Split(sErrorMessage, "%0"), Utils._CStr(pvArgs, False)) + Else + For i = LBound(pvArgs) To UBound(pvArgs) + sErrorMessage = Join(Split(sErrorMessage, "%" & i), Utils._CStr(pvArgs(i), False)) + Next i + End If + End If + Else + sErrorMessage = Error(piErrorNumber) + ' Most (or all?) error messages terminate with a "." + If Len(sErrorMessage) > 1 And Right(sErrorMessage, 1) = "." Then sErrorMessage = Left(sErrorMessage, Len(sErrorMessage)-1) + End If + + _ErrorMessage = sErrorMessage + Exit Function + +End Function ' ErrorMessage V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _PromptFilePicker(ByVal psSuffix As String) As String +' Prompt for output file name +' Return "" if Cancel +' Modified from Andrew Pitonyak's Base Macro Programming §10.4 + + If _ErrorHandler() Then On Local Error GoTo Error_Function + +Dim oFileDialog as Object, oUcb as object, oPath As Object +Dim iAccept as Integer, sInitPath as String + + Set oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") + oFileDialog.Initialize(Array(com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION)) + Set oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + + oFileDialog.appendFilter("*." & psSuffix, "*." & psSuffix) + oFileDialog.appendFilter("*.*", "*.*") + oFileDialog.setCurrentFilter("*." & psSuffix) + Set oPath = createUnoService("com.sun.star.util.PathSettings") + sInitPath = oPath.Work ' Probably My Documents + If oUcb.Exists(sInitPath) Then oFileDialog.SetDisplayDirectory(sInitPath) + + iAccept = oFileDialog.Execute() + + _PromptFilePicker = "" + If iAccept = 1 Then ' Save button pressed + _PromptFilePicker = oFileDialog.Files(0) + End If + +Exit_Function: + If Not IsEmpty(oFileDialog) And Not IsNull(oFileDialog) Then oFileDialog.Dispose() + Exit Function +Error_Function: + TraceError("ERROR", Err, "PromptFilePicker", Erl) + GoTo Exit_Function +End Function ' PromptFilePicker V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _TraceArguments(Optional psCall As String) +' Process the ERRMISSINGARGUMENTS error +' psCall is present if error detected before call to _SetCalledSub + + If Not IsMissing(psCall) Then Utils._SetCalledSub(psCall) + TraceError(TRACEFATAL, ERRMISSINGARGUMENTS, Utils._CalledSub(), 0) + Exit Sub + +End Sub ' TraceArguments + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _TraceLevel(ByVal pvTraceLevel As Variant) As Variant +' Convert string trace level to numeric value or the opposite + +Dim vTraces As Variant, i As Integer + vTraces = Array(TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT, TRACEANY) + + Select Case VarType(pvTraceLevel) + Case vbString + _TraceLevel = 4 ' 4 = Default + For i = 0 To UBound(vTraces) + If UCase(pvTraceLevel) = UCase(vTraces(i)) Then + _TraceLevel = i + 1 + Exit For + End If + Next i + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvTraceLevel < 1 Or pvTraceLevel > UBound(vTraces) + 1 Then _TraceLevel = TRACEERRORS Else _TraceLevel = vTraces(pvTraceLevel - 1) + End Select + +End Function ' TraceLevel + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/UtilProperty.xba b/wizards/source/access2base/UtilProperty.xba new file mode 100644 index 000000000..9f7ee4821 --- /dev/null +++ b/wizards/source/access2base/UtilProperty.xba @@ -0,0 +1,331 @@ +<?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="UtilProperty" 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 ======================================================================================================================= + +'********************************************************************** +' UtilProperty module +' +' Module of utilities to manipulate arrays of PropertyValue's. +'********************************************************************** + +'********************************************************************** +' Copyright (c) 2003-2004 Danny Brewer +' d29583@groovegarden.com +'********************************************************************** + +'********************************************************************** +' If you make changes, please append to the change log below. +' +' 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 +' Support of empty arrays to allow JSON conversions +'********************************************************************** + +Option Explicit + +Private Const cstHEADER = "### PROPERTYVALUES ###" +Private Const cstEMPTYARRAY = "### EMPTY ARRAY ###" + +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 New com.sun.star.beans.PropertyValue + + If Not IsMissing(psName) Then oPropertyValue.Name = psName + If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue) + _MakePropertyValue() = oPropertyValue + +End Function ' _MakePropertyValue V1.3.0 + +REM ======================================================================================================================= +Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant +' Date BASIC variables give error. Change them to strings +' Empty arrays should be replaced by cstEMPTYARRAY + + If VarType(pvValue) = vbDate Then + _CheckPropertyValue = Utils._CStr(pvValue, False) + ElseIf IsArray(pvValue) Then + If UBound(pvValue, 1) < LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue + Else + _CheckPropertyValue = pvValue + End If + +End Function ' _CheckPropertyValue + +REM ======================================================================================================================= +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. +' Returns zero if the array contains no elements. + +Dim iNumProperties As Integer + If Not IsArray(pvPropertyValuesArray) Then iNumProperties = 0 Else iNumProperties = UBound(pvPropertyValuesArray) + 1 + _NumPropertyValues() = iNumProperties + +End Function ' _NumPropertyValues V1.3.0 + +REM ======================================================================================================================= +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. + +Dim iNumProperties As Integer, i As Integer, vProp As Variant + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + For i = 0 To iNumProperties - 1 + vProp = pvPropertyValuesArray(i) + If UCase(vProp.Name) = UCase(psPropName) Then + _FindPropertyIndex() = i + Exit Function + EndIf + Next i + _FindPropertyIndex() = -1 + +End Function ' _FindPropertyIndex V1.3.0 + +REM ======================================================================================================================= +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. + +Dim iPropIndex As Integer, vProp As Variant + iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName) + If iPropIndex >= 0 Then + vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript + _FindProperty() = vProp + EndIf + +End Function ' _FindProperty V1.3.0 + +REM ======================================================================================================================= +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, 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 + If VarType(vValue) = vbString Then + If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue + ElseIf 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 ======================================================================================================================= +Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue As Variant) +' 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) + If iPropIndex >= 0 Then + ' Found, the PropertyValue is already in the array. Just modify its value. + vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript + vProp.Value = _CheckPropertyValue(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. + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + If iNumProperties = 0 Then + pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue)) + Else + ' Make array larger. + Redim Preserve pvPropertyValuesArray(iNumProperties) + ' Assign new PropertyValue + pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue) + EndIf + EndIf + +End Sub ' _SetPropertyValue V1.3.0 + +REM ======================================================================================================================= +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) + If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex) + +End Sub ' _DeletePropertyValue V1.3.0 + +REM ======================================================================================================================= +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 + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + + ' Did we find it? + If piPropIndex < 0 Then + ' Do nothing + ElseIf iNumProperties = 1 Then + ' 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 piPropIndex < iNumProperties - 1 Then + ' 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. + Redim Preserve pvPropertyValuesArray(iNumProperties - 2) + EndIf + +End Sub ' _DeleteIndexedProperty V1.3.0 + +REM ======================================================================================================================= +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 +Dim cstLF As String + + cstLF = vbLf() + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + + sResult = cstHEADER & cstLF + For i = 0 To iNumProperties - 1 + vProp = pvPropertyValuesArray(i) + sName = vProp.Name + vValue = vProp.Value + iType = VarType(vValue) + Select Case iType + Case < vbArray ' Scalar + sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF + Case Else ' Vector or matrix + If uBound(vValue, 1) < 0 Then + sResult = sResult & sName & " = (0)" & cstLF + ' 1-dimension but vector of vectors must also be considered + ElseIf VarType(vValue(0)) >= vbArray Then + sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF + 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() = 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 = "(0)" Then ' Empty array + iRows = -1 + vValue = Array() + _SetPropertyValue(vResult, sName, vValue) + ElseIf sDim <> "" Then ' Vector with content + iCols = CInt(Mid(sDim, 2, Len(sDim) - 2)) + iRows = 0 + ReDim vValue(0 To iCols - 1) + iArray = 0 + Else ' Matrix with content + 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) + iArray = 0 + End If + 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 new file mode 100644 index 000000000..b5dee5214 --- /dev/null +++ b/wizards/source/access2base/Utils.xba @@ -0,0 +1,1306 @@ +<?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="Utils" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +Global _A2B_ As Variant + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As Variant +'Add the item at the end of the array + +Dim vArray() As Variant + If IsArray(pvArray) Then vArray = pvArray Else vArray = Array() + ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1) + vArray(UBound(vArray)) = pvItem + _AddArray() = vArray() + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant +'Return on top of argument the list of all numeric types +'Facilitates the entry of the list of allowed types in _CheckArgument calls + +Dim i As Integer, vNewList() As Variant, vNumeric() As Variant, iSize As Integer + If IsMissing(pvTypes) Then + vNewList = Array() + ElseIf IsArray(pvTypes) Then + vNewList = pvTypes + Else + vNewList = Array(pvTypes) + End If + + vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal, vbBoolean) + + iSize = UBound(vNewlist) + ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1) + For i = 0 To UBound(vNumeric) + vNewList(iSize + i + 1) = vNumeric(i) + Next i + + _AddNumeric = vNewList + +End Function ' _AddNumeric V0.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _BitShift(piValue As Integer, piConstant As Integer) As Boolean + + _BitShift = False + If piValue = 0 Then Exit Function + Select Case piConstant + Case 1 + Select Case piValue + Case 1, 3, 5, 7, 9, 11, 13, 15: _BitShift = True + Case Else + End Select + Case 2 + Select Case piValue + Case 2, 3, 6, 7, 10, 11, 14, 15: _BitShift = True + Case Else + End Select + Case 4 + Select Case piValue + Case 4, 5, 6, 7, 12, 13, 14, 15: _BitShift = True + Case Else + End Select + Case 8 + Select Case piValue + Case 8, 9, 10, 11, 12, 13, 14, 15: _BitShift = True + Case Else + End Select + End Select + +End Function ' BitShift + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CalledSub() As String + _CalledSub = Iif(_A2B_.CalledSub = "", "", _GetLabel("CALLTO") & " '" & _A2B_.CalledSub & "'") +End Function ' CalledSub V0.8.9 + + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CheckArgument(pvItem As Variant _ + , ByVal piArgNr As Integer _ + , Byval pvType As Variant _ + , ByVal Optional pvValid As Variant _ + , ByVal Optional pvError As Boolean _ + ) As Variant +' Called by public functions to check the validity of their arguments +' pvItem Argument to be checked +' piArgNr Argument sequence number +' pvType Single value or array of allowed variable types +' If of string type must contain one or more valid pseudo-object types +' pvValid Single value or array of allowed values - comparison for strings is case-insensitive +' pvError If True (default), error handling in this routine. False in _setProperty methods in class modules. + + _CheckArgument = False + +Dim iVarType As Integer + If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType) + If iVarType = vbString Then ' pvType is a pseudo-type string + _CheckArgument = Utils._IsPseudo(pvItem, pvType) + Else + If IsMissing(pvValid) Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid) + End If + + If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem) + +Exit_Function: + If Not _CheckArgument Then + If IsMissing(pvError) Then pvError = True + If pvError Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(piArgNr, pvItem)) + End If + End If + Exit Function +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 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 +Const cstByteLength = 25 + + If IsMissing(pbShort) Then pbShort = True + If IsArray(pvArg) Then + sArg = "" + If VarType(pvArg) = vbByte Or VarType(pvArg) = vbArray + vbByte Then + If pbShort And UBound(pvArg) > cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg) + For i = 0 To iMax + sArg = sArg & Right("00" & Hex(pvArg(i)), 2) + Next i + Else + If pbShort Then + sArg = "[ARRAY]" + Else ' One-dimension arrays only + For i = LBound(pvArg) To UBound(pvArg) + sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call + Next i + If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1) + End If + End If + Else + Select Case VarType(pvArg) + Case vbEmpty : sArg = "[EMPTY]" + Case vbNull : sArg = "[NULL]" + Case vbObject + If IsNull(pvArg) Then + sArg = "[NULL]" + Else + sObject = Utils._ImplementationName(pvArg) + If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _ + , OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _ + , OBJDIALOG _ + )) Then + Set oArg = pvArg ' To avoid "Object variable not set" error message + sArg = "[" & oArg._Type & "] " & oArg._Name + ElseIf sObject <> "" Then + sArg = "[" & sObject & "]" + Else + sArg = "[OBJECT]" + End If + End If + Case vbVariant : sArg = "[VARIANT]" + Case vbString + ' Replace CR + LF by \n and HT by \t + ' Replace semicolon by \; to allow semicolon separated rows + 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 + sArg = Format(pvArg) + If InStr(UCase(sArg), "E") = 0 Then sArg = Format(pvArg, "##0.0##") + sArg = Replace(sArg, ",", ".") + Case vbBigint : sArg = CStr(CLng(pvArg)) + Case vbDate : sArg = Year(pvArg) & "-" & Right("0" & Month(pvArg), 2) & "-" & Right("0" & Day(pvArg), 2) _ + & " " & Right("0" & Hour(pvArg), 2) & ":" & Right("0" & Minute(pvArg), 2) _ + & ":" & Right("0" & Second(pvArg), 2) + Case Else : sArg = CStr(pvArg) + End Select + End If + If pbShort And Len(sArg) > cstLength Then + sLength = "(" & Len(sArg) & ")" + sArg = Left(sArg, cstLength - 5 - Len(slength)) & " ... " & sLength + End If + _CStr = sArg + +End Function ' CStr V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant +' psArg is presumed an output of _CStr (stored in the meantime 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 + 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 + If IsMissing(pbStrDate) Then pbStrDate = False + 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), pbStrDate) + Next i + _CVar = vVars + Exit Function + End If + + ' Usual case + Select Case True + Case sArg = "[EMPTY]" : _CVar = EMPTY + Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null + Case sArg = "[OBJECT]" : _CVar = Nothing + Case sArg = "[TRUE]" : _CVar = True + Case sArg = "[FALSE]" : _CVar = False + 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]+(e[-+]?[0-9]+)?$") <> "" + _CVar = Val(sArg) ' Scientific notation + Case Else : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";") + End Select + +End Function ' CVar V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _DecimalPoint() As String +'Return locale decimal point + _DecimalPoint = Mid(Format(0, "0.0"), 2, 1) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _ExtensionLocation() As String +' Return the URL pointing to the location where OO installed the Access2Base extension +' Adapted from http://wiki.services.openoffice.org/wiki/Documentation/DevGuide/Extensions/Location_of_Installed_Extensions + +Dim oPip As Object, sLocation As String + Set oPip = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider") + _ExtensionLocation = oPip.getPackageLocation("Access2Base") + +End Function ' ExtensionLocation + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetDialogLib() As Object +' Return actual Access2Base dialogs library + +Dim oDialogLib As Object + + Set oDialogLib = DialogLibraries + If oDialogLib.hasByName("Access2BaseDev") Then + If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev") + Set _GetDialogLib = DialogLibraries.Access2BaseDev + ElseIf oDialogLib.hasByName("Access2Base") Then + If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") + Set _GetDialogLib = DialogLibraries.Access2Base + Else + Set _GetDialogLib = Nothing + EndIf + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +' Return the LO internal event name +' Corrects the typo on ErrorOccur(r?)ed + + _GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) & Right(psProperty, Len(psProperty) - 3), "errorOccurred", "errorOccured") + +End Function ' _GetEventName V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetEventScriptCode(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psName As String _ + , Optional ByVal pbExtendName As Boolean _ + ) As String +' Extract from the parent of poObject the macro linked to psEvent. +' psName is the name of the object + +Dim i As Integer, vEvents As Variant, sEvent As String, oParent As Object, iIndex As Integer, sName As String + + _GetEventScriptCode = "" + If Not Utils._hasUNOMethod(poObject, "getParent") Then Exit Function + + ' Find form index i.e. find control via getByIndex() + If IsMissing(pbExtendName) Then pbExtendName = False + Set oParent = poObject.getParent() + iIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then Exit Function + + ' Find script event + vEvents = oParent.getScriptEvents(iIndex) ' Returns an array + sEvent = Utils._GetEventName(psEvent) ' Targeted event method + For i = 0 To UBound(vEvents) + If vEvents(i).EventMethod = sEvent Then + _GetEventScriptCode = vEvents(i).ScriptCode + Exit For + End If + Next i + +End Function ' _GetEventScriptCode V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetResultSetColumnValue(poResultSet As Object _ + , ByVal piColIndex As Integer _ + , Optional ByVal pbReturnBinary As Boolean _ + ) As Variant +REM Modified from Roberto Benitez's BaseTools +REM get the data for the column specified by ColIndex +REM If pbReturnBinary = False (default) then return length of binary field +REM get type name from metadata + +Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object +Dim bNullable As Boolean, lSize As Long +Const cstMaxTextLength = 65535 +Const cstMaxBinlength = 2 * 65535 + + On Local Error Goto 0 ' Disable error handler + vValue = Null ' Default value if error + If IsMissing(pbReturnBinary) Then pbReturnBinary = False + With com.sun.star.sdbc.DataType + iType = poResultSet.MetaData.getColumnType(piColIndex) + bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + Select Case iType + Case .ARRAY : vValue = poResultSet.getArray(piColIndex) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oValue = poResultSet.getBinaryStream(piColIndex) + If bNullable Then + If Not poResultSet.wasNull() Then + If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset + lSize = cstMaxBinLength + Else + lSize = CLng(oValue.getLength()) + End If + If lSize <= cstMaxBinLength And pbReturnBinary Then + vValue = Array() + oValue.readBytes(vValue, lSize) + Else ' Return length of field, not content + vValue = lSize + End If + End If + End If + oValue.closeInput() + Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(piColIndex) + Case .DATE : vDateTime = poResultSet.getDate(piColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) + Case .DISTINCT, .OBJECT, .OTHER, .STRUCT + vValue = Null + Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(piColIndex) + Case .FLOAT : vValue = poResultSet.getFloat(piColIndex) + Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(piColIndex) + Case .BIGINT : vValue = poResultSet.getLong(piColIndex) + Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(piColIndex) + Case .SQLNULL : vValue = poResultSet.getNull(piColIndex) + Case .OBJECT, .OTHER, .STRUCT : vValue = Null + Case .REF : vValue = poResultSet.getRef(piColIndex) + Case .TINYINT : vValue = poResultSet.getShort(piColIndex) + Case .CHAR, .VARCHAR : vValue = poResultSet.getString(piColIndex) + Case .LONGVARCHAR, .CLOB + Set oValue = poResultSet.getCharacterStream(piColIndex) + If bNullable Then + If Not poResultSet.wasNull() Then + If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset + lSize = cstMaxTextLength + Else + lSize = CLng(oValue.getLength()) + End If + oValue.closeInput() + vValue = poResultSet.getString(piColIndex) + End If + Else + oValue.closeInput() + End If + Case .TIME : vDateTime = poResultSet.getTime(piColIndex) + If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case .TIMESTAMP : vDateTime = poResultSet.getTimeStamp(piColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _ + + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case Else + vValue = poResultSet.getString(piColIndex) 'GIVE STRING A TRY + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + If bNullable Then + If poResultSet.wasNull() Then vValue = Null + End If + End With + + _GetResultSetColumnValue = vValue + +End Function ' GetResultSetColumnValue V 1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _FinalProperty(psShortcut As String) As String +' Return the final property of a shortcut + +Const cstEXCLAMATION = "!" +Const cstDOT = "." + +Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String +Dim sComponents() As String, sSubComponents() As String + _FinalProperty = "" + sComponents = Split(Trim(psShortcut), cstEXCLAMATION) + If UBound(sComponents) = 0 Then Exit Function + sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT) + Select Case UBound(sSubComponents) + Case 1 + _FinalProperty = sSubComponents(1) + Case Else + Exit Function + End Select + +End Function ' FinalProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetProductName(ByVal Optional psFlag As String) as String +'Return OO product ("PRODUCT") and version numbers ("VERSION") +'Derived from Tools library + +Dim oProdNameAccess as Object +Dim sVersion as String +Dim sProdName as String + If IsMissing(psFlag) Then psFlag = "ALL" + oProdNameAccess = _GetRegistryKeyContent("org.openoffice.Setup/Product") + sProdName = oProdNameAccess.getByName("ooName") + sVersion = oProdNameAccess.getByName("ooSetupVersionAboutBox") + Select Case psFlag + Case "ALL" : _GetProductName = sProdName & " " & sVersion + Case "PRODUCT" : _GetProductName = sProdName + Case "VERSION" : _GetProductName = sVersion + End Select +End Function ' GetProductName V1.0.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetRandomFileName(ByVal psName As String) As String +' Return the full name of a random temporary file suffixed by psName + +Dim sRandom As String + sRandom = Right("000000" & Int(999999 * Rnd), 6) + _GetRandomFileName = Utils._getTempDirectoryURL() & "/" & "A2B_TEMP_" & psName & "_" & sRandom + +End Function ' GetRandomFileName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant +'Implement ConfigurationProvider service +'Derived from Tools library + +Dim oConfigProvider as Object +Dim aNodePath(0) as new com.sun.star.beans.PropertyValue + oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") + aNodePath(0).Name = "nodepath" + aNodePath(0).Value = sKeyName + If IsMissing(bForUpdate) Then bForUpdate = False + If bForUpdate Then + _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath()) + Else + _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath()) + End If +End Function ' GetRegistryKeyContent V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _getTempDirectoryURL() As String +' Return the temporary directory defined in the OO Options (Paths) +Dim sDirectory As String, oSettings As Object, oPathSettings As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + + _getTempDirectoryURL = "" + oPathSettings = createUnoService( "com.sun.star.util.PathSettings" ) + sDirectory = oPathSettings.GetPropertyValue( "Temp" ) + + _getTempDirectoryURL = sDirectory + +Exit_Function: + Exit Function +Error_Function: + TraceError("ERROR", Err, "_getTempDirectoryURL", Erl) + _getTempDirectoryURL = "" + Goto Exit_Function +End Function ' _getTempDirectoryURL V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _getUNOTypeName(pvObject As Variant) As String +' Return the symbolic name of the pvObject (UNO-object) type +' Code-snippet from XRAY + +Dim oService As Object, vClass as Variant + _getUNOTypeName = "" + On Local Error Resume Next + oService = CreateUnoService("com.sun.star.reflection.CoreReflection") + vClass = oService.getType(pvObject) + If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT Then + _getUNOTypeName = vClass.Name + End If + oService.Dispose() + +End Function ' getUNOTypeName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean +' Return true if pvObject has the (UNO) method psMethod +' Code-snippet found in Bernard Marcelly's XRAY + +Dim vInspect as Variant + _hasUNOMethod = False + If IsNull(pvObject) Then Exit Function + On Local Error Resume Next + vInspect = _A2B_.Introspection.Inspect(pvObject) + _hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL) + +End Function ' hasUNOMethod V0.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean +' Return true if pvObject has the (UNO) property psProperty +' Code-snippet found in Bernard Marcelly's XRAY + +Dim vInspect as Variant + _hasUNOProperty = False + If IsNull(pvObject) Then Exit Function + On Local Error Resume Next + vInspect = _A2B_.Introspection.Inspect(pvObject) + _hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL) + +End Function ' hasUNOProperty V0.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ImplementationName(pvObject As Variant) As String +' Use getImplementationName method or _getUNOTypeName function + +Dim sObjectType As String + On Local Error Resume Next + sObjectType = pvObject.getImplementationName() + If sObjectType = "" Then sObjectType = _getUNOTypeName(pvObject) + + _ImplementationName = sObjectType + +End Function ' ImplementationName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant +' Return True if pvItem is present in the pvList array (case insensitive comparison) +' Return the value in pvList if pvReturnValue = True + +Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer +Dim iTop As Integer, iBottom As Integer, iFound As Integer + iItemVarType = VarType(pvItem) + If IsMissing(pvReturnValue) Then pvReturnValue = False + If iItemVarType = vbNull Or IsNull(pvList) Then + _InList = False + ElseIf Not IsArray(pvList) Then + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList ) + If Not pvReturnValue Then + _InList = bFound + Else + If bFound Then _InList = pvList Else _InList = False + End If + ElseIf UBound(pvList) < LBound(pvList) Then ' Array not initialized + _InList = False + Else + bFound = False + _InList = False + iListVarType = VarType(pvList(LBound(pvList))) + If iListVarType = iItemVarType _ + Or ( (iListVarType = vbInteger Or iListVarType = vbLong Or iListVarType = vbSingle Or iListVarType = vbDouble _ + Or iListVarType = vbCurrency Or iListVarType = vbBigint Or iListVarType = vbDecimal) _ + And (iItemVarType = vbInteger Or iItemVarType = vbLong Or iItemVarType = vbSingle Or iItemVarType = vbDouble _ + Or iItemVarType = vbCurrency Or iItemVarType = vbBigint Or iItemVarType = vbDecimal) _ + ) Then + If IsMissing(pbBinarySearch) Then pbBinarySearch = False + If Not pbBinarySearch Then ' Linear search + For i = LBound(pvList) To UBound(pvList) + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) ) + If bFound Then + iFound = i + Exit For + End If + Next i + Else ' Binary search => array must be sorted + iTop = UBound(pvList) + iBottom = lBound(pvList) + Do + iFound = (iTop + iBottom) / 2 + If ( iItemVarType = vbString And UCase(pvItem) > UCase(pvList(iFound)) ) Or ( iItemVarType <> vbString And pvItem > pvList(iFound) ) Then + iBottom = iFound + 1 + Else + iTop = iFound - 1 + End If + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) ) + Loop Until ( bFound ) Or ( iBottom > iTop ) + End If + If bFound Then + If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound) + End If + End If + End If + + Exit Function + +End Function ' InList V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String +'Return type of property EVEN WHEN EMPTY ! (Used in date and time controls) + +Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object +' On Local Error Resume Next + _InspectPropertyType = "" + Set oInspect1 = CreateUnoService("com.sun.star.script.Invocation") + Set oInspect2 = oInspect1.createInstanceWithArguments(Array(poObject)).IntroSpection + If Not IsNull(oInspect2) Then + Set oInspect3 = oInspect2.getProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL) + If Not IsNull(oInspect3) Then _InspectPropertyType = oInspect3.Type.Name + End If + Set oInspect1 = Nothing : Set oInspect2 = Nothing : Set oInspect3 = Nothing + +End Function ' InspectPropertyType V1.0.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _IsLeft(psString As String, psLeft As String) As Boolean +' Return True if left part of psString = psLeft + +Dim iLength As Integer + iLength = Len(psLeft) + _IsLeft = False + If Len(psString) >= iLength Then + If Left(psString, iLength) = psLeft Then _IsLeft = True + End If + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _IsBinaryType(ByVal lType As Long) As Boolean + + With com.sun.star.sdbc.DataType + Select Case lType + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + _IsBinaryType = True + Case Else + _IsBinaryType = False + End Select + End With + +End Function ' IsBinaryType V1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean +' Test pvObject: does it exist ? +' is the _Type item = one of the proposed pvTypes ? +' does the pseudo-object refer to an existing object (e.g. does the form really exist in the db) ? + +Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant + + If _ErrorHandler() Then On Local Error Goto Exit_False + + _IsPseudo = False + bIsPseudo = False + vObject = pvObject ' To avoid "Object variable not set" error message + Select Case True + Case IsEmpty(vObject) + Case IsNull(vObject) + Case VarType(vObject) <> vbObject + Case Else + With vObject + Select Case True + Case IsEmpty(._Type) + Case IsNull(._Type) + Case ._Type = "" + Case Else + bIsPseudo = _InList(._Type, pvType) + If Not bIsPseudo Then ' If primary type did not succeed, give the subtype a chance + If ._Type = OBJCONTROL Then bIsPseudo = _InList(._SubType, pvType) + End If + End Select + End With + End Select + + If Not bIsPseudo Then Goto Exit_Function + +Dim oDoc As Object, oForms As Variant +Const cstSeparator = "\;" + + bPseudoExists = False + With vObject + Select Case ._Type + Case OBJFORM + If ._Name <> "" Then ' Check validity of form name + Set oDoc = _A2B_.CurrentDocument() + If oDoc.DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = _InList(._Name, Application._GetAllHierarchicalNames()) + End If + Case OBJDATABASE + If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection) + Case OBJDIALOG + If ._Name <> "" Then ' Check validity of dialog name + bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._Name) ) + End If + Case OBJCOLLECTION + bPseudoExists = True + Case OBJCONTROL + If Not IsNull(.ControlModel) And ._Name <> "" Then ' Check validity of control + Set oForms = .ControlModel.Parent + bPseudoExists = ( oForms.hasByName(._Name) ) + End If + Case OBJSUBFORM + If Not IsNull(.DatabaseForm) And ._Name <> "" Then ' Check validity of subform + If .DatabaseForm.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then + Set oForms = .DatabaseForm.Parent + bPseudoExists = ( oForms.hasByName(._Name) ) + End If + End If + Case OBJOPTIONGROUP + bPseudoExists = ( .Count > 0 ) + Case OBJCOMMANDBAR + bPseudoExists = ( Not IsNull(._Window) ) + Case OBJCOMMANDBARCONTROL + bPseudoExists = ( Not IsNull(._ParentCommandBar) ) + Case OBJEVENT + bPseudoExists = ( Not IsNull(._EventSource) ) + Case OBJPROPERTY + bPseudoExists = ( ._Name <> "" ) + Case OBJTABLEDEF + bPseudoExists = ( ._Name <> "" And Not IsNull(.Table) ) + Case OBJQUERYDEF + bPseudoExists = ( ._Name <> "" And Not IsNull(.Query) ) + Case OBJRECORDSET + bPseudoExists = ( Not IsNull(.RowSet) ) + Case OBJFIELD + bPseudoExists = ( ._Name <> "" And Not IsNull(.Column) ) + Case OBJTEMPVAR + If ._Name <> "" Then ' Check validity of tempvar name + bPseudoExists = ( _A2B_.hasItem(COLLTEMPVARS, ._Name) ) + End If + Case Else + End Select + End With + + _IsPseudo = ( bIsPseudo And bPseudoExists ) + +Exit_Function: + Exit Function +Exit_False: + _IsPseudo = False + Goto Exit_Function +End Function ' IsPseudo V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _IsScalar(ByVal pvArg As Variant, Byval pvType As Variant, ByVal Optional pvValid As Variant) As Boolean +' Check type of pvArg and value in allowed pvValid list + + _IsScalar = False + + If IsArray(pvType) Then + If Not _InList(VarType(pvArg), pvType) Then Exit Function + ElseIf VarType(pvArg) <> pvType Then + If pvType = vbBoolean And VarType(pvArg) = vbLong Then + If pvArg < -1 And pvArg > 0 Then Exit Function ' Special boolean processing because the Not function returns a Long + Else + Exit Function + End If + End If + If Not IsMissing(pvValid) Then + If Not _InList(pvArg, pvValid) Then Exit Function + End If + + _IsScalar = True + +Exit_Function: + Exit Function +End Function ' IsScalar V0.7.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _PCase(ByVal psString As String) As String +' Return the proper case representation of argument + +Dim vSubStrings() As Variant, i As Integer, iLen As Integer + vSubStrings = Split(psString, " ") + For i = 0 To UBound(vSubStrings) + iLen = Len(vSubStrings(i)) + If iLen > 1 Then + vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) & LCase(Right(vSubStrings(i), iLen - 1)) + ElseIf iLen = 1 Then + vSubStrings(i) = UCase(vSubStrings(i)) + End If + Next i + _PCase = Join(vSubStrings, " ") + +End Function ' PCase V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PercentEncode(ByVal psChar As String) As String +' Percent encoding of single psChar character +' https://en.wikipedia.org/wiki/UTF-8 + +Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String + lChar = Asc(psChar) + + Select Case lChar + Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z + _PercentEncode = psChar + Case Asc("-"), Asc("."), Asc("_"), Asc("~") + _PercentEncode = psChar + Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimiters in query strings + _PercentEncode = psChar + Case Asc(" "), Asc("%") + _PercentEncode = "%" & Right("00" & Hex(lChar), 2) + Case 0 To 127 + _PercentEncode = psChar + Case 128 To 2047 + sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2) + sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2) + _PercentEncode = sByte1 & sByte2 + Case 2048 To 65535 + sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2) + sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2) + sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2) + _PercentEncode = sByte1 & sByte2 & sByte3 + Case Else ' Not supported + _PercentEncode = psChar + End Select + + Exit Function + +End Function ' _PercentEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReadFileIntoArray(ByVal psFileName) As Variant +' Loads all lines of a text file into a variant array +' Any error reduces output to an empty array +' Input file name presumed in URL form + +Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As Integer, iCount2 As Integer +Const cstMaxLines = 16000 ' +/- the limit of array sizes in Basic + On Local Error GoTo Error_Function + vLines = Array() + _ReadFileIntoArray = Array() + If psFileName = "" Then Exit Function + + iFile = FreeFile() + Open psFileName For Input Access Read Shared As #iFile + iCount1 = 0 + Do While Not Eof(iFile) And iCount1 < cstMaxLines + Line Input #iFile, sLine + iCount1 = iCount1 + 1 + Loop + Close #iFile + + ReDim vLines(0 To iCount1 - 1) ' Reading file twice preferred to ReDim Preserve for performance reasons + iFile = FreeFile() + Open psFileName For Input Access Read Shared As #iFile + iCount2 = 0 + Do While Not Eof(iFile) And iCount2 < iCount1 + Line Input #iFile, vLines(iCount2) + iCount2 = iCount2 + 1 + Loop + Close #iFile + +Exit_Function: + _ReadFileIntoArray() = vLines() + Exit Function +Error_Function: + vLines = Array() + Resume Exit_Function +End Function ' _ReadFileIntoArray V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +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 +' plStart = start position of psString to search (starts at 1) +' In output plStart contains the first position of the matching string +' To search again the same or another pattern => plStart = plStart + Len(matching string) + +Dim oTextSearch As Object +Dim vOptions As Variant 'com.sun.star.util.SearchOptions +Dim lEnd As Long, vResult As Object + + _RegexSearch = "" + Set oTextSearch = _A2B_.TextSearch ' UNO XTextSearch service + vOptions = _A2B_.SearchOptions + vOptions.searchString = psRegex ' Pattern to be searched + oTextSearch.setOptions(vOptions) + If IsMissing(plStart) Then plStart = 1 + 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 + ' 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 + End If + End With + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RegisterDialogEventScript(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psListener As String _ + , ByVal psScriptCode As String _ + ) As Boolean +' Register a script event (psEvent) to poObject (Dialog or dialog Control) + +Dim oEvents As Object, sEvent As String, sEventName As String, oEvent As Object + + _RegisterDialogEventScript = False + If Not _hasUNOMethod(poObject, "getEvents") Then Exit Function + +' Remove existing event, if any, then store new script code + Set oEvents = poObject.getEvents() + sEvent = Utils._GetEventName(psEvent) + sEventName = "com.sun.star.awt." & psListener & "::" & sEvent + If oEvents.hasByName(sEventName) Then oEvents.removeByName(sEventName) + Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor") + With oEvent + .ListenerType = psListener + .EventMethod = sEvent + .ScriptType = "Script" ' Better than "Basic" + .ScriptCode = psScriptCode + End With + oEvents.insertByName(sEventName, oEvent) + + _RegisterDialogEventScript = True + +End Function ' _RegisterDialogEventScript V1.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RegisterEventScript(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psListener As String _ + , ByVal psScriptCode As String _ + , ByVal psName As String _ + , Optional ByVal pbExtendName As Boolean _ + ) As Boolean +' Register a script event (psEvent) to poObject (Form, SubForm or Control) + +Dim i As Integer, oEvent As Object, sEvent As String, oParent As Object, iIndex As Integer, sName As String + + _RegisterEventScript = False + If Not _hasUNOMethod(poObject, "getParent") Then Exit Function + + ' Find object internal index i.e. how to reach it via getByIndex() + If IsMissing(pbExtendName) Then pbExtendName = False + Set oParent = poObject.getParent() + iIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then Exit Function + + sEvent = Utils._GetEventName(psEvent) ' Targeted event method + If psScriptCode = "" Then + oParent.revokeScriptEvent(iIndex, psListener, sEvent, "") + Else + Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor") + With oEvent + .ListenerType = psListener + .EventMethod = sEvent + .ScriptType = "Script" ' Better than "Basic" + .ScriptCode = psScriptCode + End With + oParent.registerScriptEvent(iIndex, oEvent) + End If + _RegisterEventScript = True + +End Function ' _RegisterEventScript V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _ResetCalledSub(ByVal psSub As String) +' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling +' Used to trace routine in/outs and to clarify error messages + If IsEmpty(_A2B_) Then Call Application._RootInit() ' Only when Utils module recompiled + With _A2B_ + If .CalledSub = psSub Then .CalledSub = "" + If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False) + End With +End Sub ' ResetCalledSub + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean +' Execute a given script with pvArgs() array of arguments + + On Local Error Goto Error_Function + _RunScript = False + If IsNull(ThisComponent) Then Goto Exit_Function + +Dim oSCriptProvider As Object, oScript As Object, vResult As Variant + + Set oScriptProvider = ThisComponent.ScriptProvider() + Set oScript = oScriptProvider.getScript(psScript) + If IsMissing(pvArgs()) Then pvArgs() = Array() + vResult = oScript.Invoke(pvArgs(), Array(), Array()) + _RunScript = True + +Exit_Function: + Exit Function +Error_Function: + _RunScript = False + Goto Exit_Function +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _SetCalledSub(ByVal psSub As String) +' Called in top of each public function. +' Used to trace routine in/outs and to clarify error messages + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session + With _A2B_ + If .CalledSub = "" Then + .CalledSub = psSub + .LastErrorCode = 0 + .LastErrorLevel = "" + .ErrorText = "" + .ErrorLongText = "" + End If + If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False) + End With +End Sub ' SetCalledSub + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Surround(ByVal psName As String) As String +' Return [Name] if Name contains spaces +' Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots + +Const cstSquareOpen = "[" +Const cstSquareClose = "]" +Const cstDot = "." +Dim sName As String + + If InStr(psName, ".") > 0 Then + sName = Join(Split(psName, cstDot), cstSquareClose & cstDot & cstSquareOpen) + _Surround = cstSquareOpen & sName & cstSquareClose + ElseIf InStr(psName, " ") > 0 Then + _Surround = cstSquareOpen & psName & cstSquareClose + Else + _Surround = psName + End If + +End Function ' Surround + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Trim(ByVal psString As String) As String +' Remove leading and trailing spaces, remove surrounding square brackets, replace tabs by spaces +Const cstSquareOpen = "[" +Const cstSquareClose = "]" +Dim sTrim As String + + sTrim = Trim(Replace(psString, vbTab, " ")) + _Trim = sTrim + If Len(sTrim) <= 2 Then Exit Function + + If Left(sTrim, 1) = cstSquareOpen Then + If Right(sTrim, 1) = cstSquareClose Then + _Trim = Mid(sTrim, 2, Len(sTrim) - 2) + End If + End If +End Function ' Trim V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _TrimArray(pvArray As Variant) As Variant +' Remove empty strings from strings array + +Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer + vTrim = Null + If Not IsArray(pvArray) Then + If Len(Trim(pvArray)) > 0 Then vTrim = Array(pvArray) Else vTrim = Array() + ElseIf UBound(pvArray) < LBound(pvArray) Then ' Array empty + vTrim = Array() + Else + iCount = 0 + For i = LBound(pvArray) To UBound(pvArray) + If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1 + Next i + If iCount = 0 Then + vTrim() = pvArray() + ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then ' Array empty or all blanks + vTrim() = Array() + Else + ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount) + j = 0 + For i = LBound(pvArray) To UBound(pvArray) + If Len(Trim(pvArray(i))) > 0 Then + vTrim(j) = pvArray(i) + j = j + 1 + End If + Next i + End If + End If + + _TrimArray() = vTrim() + +End Function ' TrimArray V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _ + , poResultSet As Object _ + , ByVal piColIndex As Integer _ + , ByVal pvValue As Variant _ + ) As Boolean +REM store the pvValue for the column specified by ColIndex +REM get type name from metadata + +Dim iType As Integer, vDateTime As Variant, oValue As Object +Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName As String +Const cstMaxTextLength = 65535 +Const cstMaxBinlength = 2 * 65535 + + On Local Error Goto 0 ' Disable error handler + _UpdateResultSetColumnValue = False + With com.sun.star.sdbc.DataType + iType = poResultSet.MetaData.getColumnType(piColIndex) + iValueType = VarType(pvValue) + sValueTypeName = UCase(poResultSet.MetaData.getColumnTypeName(piColIndex)) + bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + + If bNullable And IsNull(pvValue) Then + poResultSet.updateNull(piColIndex) + Else + Select Case iType + Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF, .SQLNULL, .STRUCT + poResultSet.updateNull(piColIndex) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + poResultSet.updateBytes(piColIndex, pvValue) + Case .BIT, .BOOLEAN : poResultSet.updateBoolean(piColIndex, pvValue) + Case .DATE : vDateTime = CreateUnoStruct("com.sun.star.util.Date") + vDateTime.Year = Year(pvValue) + vDateTime.Month = Month(pvValue) + vDateTime.Day = Day(pvValue) + poResultSet.updateDate(piColIndex, vDateTime) + Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue) + Case .DOUBLE, .REAL : poResultSet.updateDouble(piColIndex, pvValue) + Case .FLOAT : poResultSet.updateFloat(piColIndex, pvValue) + Case .INTEGER, .SMALLINT : poResultSet.updateInt(piColIndex, pvValue) + Case .BIGINT : poResultSet.updateLong(piColIndex, pvValue) + Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue) + Case .TINYINT : poResultSet.updateShort(piColIndex, pvValue) + Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB + If piRDBMS = DBMS_SQLITE And InStr(sValueTypeName, "BINARY") > 0 Then ' Sqlite exception ... ! + poResultSet.updateBytes(piColIndex, pvValue) + Else + poResultSet.updateString(piColIndex, pvValue) + End If + Case .TIME : vDateTime = CreateUnoStruct("com.sun.star.util.Time") + vDateTime.Hours = Hour(pvValue) + vDateTime.Minutes = Minute(pvValue) + vDateTime.Seconds = Second(pvValue) + 'vDateTime.HundredthSeconds = 0 + poResultSet.updateTime(piColIndex, vDateTime) + Case .TIMESTAMP : vDateTime = CreateUnoStruct("com.sun.star.util.DateTime") + vDateTime.Year = Year(pvValue) + vDateTime.Month = Month(pvValue) + vDateTime.Day = Day(pvValue) + vDateTime.Hours = Hour(pvValue) + vDateTime.Minutes = Minute(pvValue) + vDateTime.Seconds = Second(pvValue) + 'vDateTime.HundredthSeconds = 0 + poResultSet.updateTimestamp(piColIndex, vDateTime) + Case Else + If bNullable Then poResultSet.updateNull(piColIndex) + End Select + End If + + End With + + _UpdateResultSetColumnValue = True + +End Function ' UpdateResultSetColumnValue V 1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _URLEncode(ByVal psToEncode As String) As String +' http://www.w3schools.com/tags/ref_urlencode.asp +' http://xkr.us/articles/javascript/encode-compare/ +' http://tools.ietf.org/html/rfc3986 + +Dim sEncoded As String, sChar As String +Dim lCurrentChar As Long, bQuestionMark As Boolean + + sEncoded = "" + bQuestionMark = False + For lCurrentChar = 1 To Len(psToEncode) + sChar = Mid(psToEncode, lCurrentChar, 1) + Select Case sChar + Case " ", "%" + sEncoded = sEncoded & _PercentEncode(sChar) + Case "?" ' Is it the first "?" ? + If bQuestionMark Then ' "?" introduces in a URL the arguments part + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & sChar + bQuestionMark = True + End If + Case "\" + If bQuestionMark Then + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & "/" ' If Windows file naming ... + End If + Case Else + If bQuestionMark Then + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & _UTF8Encode(sChar) ' Because IE does not support %encoding in first part of URL + End If + End Select + Next lCurrentChar + + _URLEncode = sEncoded + +End Function ' _URLEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _UTF8Encode(ByVal psChar As String) As String +' &-encoding of single psChar character (e.g. "é" becomes "&eacute;" or numeric equivalent +' http://www.w3schools.com/charsets/ref_html_utf8.asp + + Select Case psChar + Case """" : _UTF8Encode = "&quot;" + Case "&" : _UTF8Encode = "&amp;" + Case "<" : _UTF8Encode = "&lt;" + Case ">" : _UTF8Encode = "&gt;" + Case "'" : _UTF8Encode = "&apos;" + Case ":", "/", "?", "#", "[", "]", "@" ' Reserved characters + _UTF8Encode = psChar + Case Chr(13) : _UTF8Encode = "" ' Carriage return + Case Chr(10) : _UTF8Encode = "<br>" ' Line Feed + Case < Chr(126) : _UTF8Encode = psChar + Case "€" : _UTF8Encode = "&euro;" + Case Else : _UTF8Encode = "&#" & Asc(psChar) & ";" + End Select + + Exit Function + +End Function ' _UTF8Encode V1.4.0 + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/_License.xba b/wizards/source/access2base/_License.xba new file mode 100644 index 000000000..fa8a5743b --- /dev/null +++ b/wizards/source/access2base/_License.xba @@ -0,0 +1,25 @@ +<?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="_License" script:language="StarBasic"> +' Copyright 2012-2017 Jean-Pierre LEDURE + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +' Access2Base is distributed in the hope that it will be useful, +' but WITHOUT ANY WARRANTY; without even the implied warranty of +' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +' Access2Base is free software; you can redistribute it and/or modify it under the terms of either (at your option): +' +' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . +' +' 2) The GNU Lesser General Public License as published by +' the Free Software Foundation, either version 3 of the License, or +' (at your option) any later version. If a copy of the LGPL was not +' distributed with this file, see http://www.gnu.org/licenses/ . + +</script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/acConstants.xba b/wizards/source/access2base/acConstants.xba new file mode 100644 index 000000000..9678a5b20 --- /dev/null +++ b/wizards/source/access2base/acConstants.xba @@ -0,0 +1,394 @@ +<?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="acConstants" script:language="StarBasic"> +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM Access2Base ----------------------------------------------------- +Global Const Access2Base_Version = "7.0.0" ' Alignment on LibreOffice versions + +REM AcCloseSave +REM ----------------------------------------------------------------- +Global Const acSaveNo = 2 +Global Const acSavePrompt = 0 +Global Const acSaveYes = 1 + +REM AcFormView +REM ----------------------------------------------------------------- +Global Const acDesign = 1 +Global Const acNormal = 0 +Global Const acPreview = 2 + +REM AcFormOpenDataMode +REM ----------------------------------------------------------------- +Global Const acFormAdd = 0 +Global Const acFormEdit = 1 +Global Const acFormPropertySettings = -1 +Global Const acFormReadOnly = 2 + +REM acView +REM ----------------------------------------------------------------- +Global Const acViewDesign = 1 +Global Const acViewNormal = 0 +Global Const acViewPreview = 2 + +REM acOpenDataMode +REM ----------------------------------------------------------------- +Global Const acAdd = 0 +Global Const acEdit = 1 +Global Const acReadOnly = 2 + +REM AcObjectType +REM ----------------------------------------------------------------- +Global Const acDefault = -1 +Global Const acDiagram = 8 +Global Const acForm = 2 +Global Const acQuery = 1 +Global Const acReport = 3 +Global Const acTable = 0 +' Unexisting in MS/Access +Global Const acBasicIDE = 101 +Global Const acDatabaseWindow = 102 +Global Const acDocument = 111 +Global Const acWelcome = 112 +' Subtype if acDocument +Global Const docWriter = "Writer" +Global Const docCalc = "Calc" +Global Const docImpress = "Impress" +Global Const docDraw = "Draw" +Global Const docMath = "Math" + +REM AcWindowMode +REM ----------------------------------------------------------------- +Global Const acDialog = 3 +Global Const acHidden = 1 +Global Const acIcon = 2 +Global Const acWindowNormal = 0 + +REM VarType constants +REM ----------------------------------------------------------------- +Global Const vbEmpty = 0 +Global Const vbNull = 1 +Global Const vbInteger = 2 +Global Const vbLong = 3 +Global Const vbSingle = 4 +Global Const vbDouble = 5 +Global Const vbCurrency = 6 +Global Const vbDate = 7 +Global Const vbString = 8 +Global Const vbObject = 9 +Global Const vbBoolean = 11 +Global Const vbVariant = 12 +Global Const vbByte = 17 +Global Const vbUShort = 18 +Global Const vbULong = 19 +Global Const vbBigint = 35 +Global Const vbDecimal = 37 +Global Const vbArray = 8192 + +REM MsgBox constants +REM ----------------------------------------------------------------- +Global Const vbOKOnly = 0 ' OK button only (default) +Global Const vbOKCancel = 1 ' OK and Cancel buttons +Global Const vbAbortRetryIgnore = 2 ' Abort, Retry, and Ignore buttons +Global Const vbYesNoCancel = 3 ' Yes, No, and Cancel buttons +Global Const vbYesNo = 4 ' Yes and No buttons +Global Const vbRetryCancel = 5 ' Retry and Cancel buttons +Global Const vbCritical = 16 ' Critical message +Global Const vbQuestion = 32 ' Warning query +Global Const vbExclamation = 48 ' Warning message +Global Const vbInformation = 64 ' Information message +Global Const vbDefaultButton1 = 128 ' First button is default (default) (VBA: 0) +Global Const vbDefaultButton2 = 256 ' Second button is default +Global Const vbDefaultButton3 = 512 ' Third button is default +Global Const vbApplicationModal = 0 ' Application modal message box (default) +REM MsgBox Return Values +REM ----------------------------------------------------------------- +Global Const vbOK = 1 ' OK button pressed +Global Const vbCancel = 2 ' Cancel button pressed +Global Const vbAbort = 3 ' Abort button pressed +Global Const vbRetry = 4 ' Retry button pressed +Global Const vbIgnore = 5 ' Ignore button pressed +Global Const vbYes = 6 ' Yes button pressed +Global Const vbNo = 7 ' No button pressed + +REM Dialogs Return Values +REM ------------------------------------------------------------------ +Global Const dlgOK = 1 ' OK button pressed +Global Const dlgCancel = 0 ' Cancel button pressed + +REM Control Types +REM ----------------------------------------------------------------- +Global Const acCheckBox = 5 +Global Const acComboBox = 7 +Global Const acCommandButton = 2 : Global Const acToggleButton = 122 +Global Const acCurrencyField = 18 +Global Const acDateField = 15 +Global Const acFileControl = 12 +Global Const acFixedLine = 24 ' FREE ENTRY (USEFUL IN DIALOGS) +Global Const acFixedText = 10 : Global Const acLabel = 10 +Global Const acFormattedField = 1 ' FREE ENTRY TAKEN TO NOT CONFUSE WITH acTextField +Global Const acGridControl = 11 +Global Const acGroupBox = 8 : Global Const acOptionGroup = 8 +Global Const acHiddenControl = 13 +Global Const acImageButton = 4 +Global Const acImageControl = 14 : Global Const acImage = 14 +Global Const acListBox = 6 +Global Const acNavigationBar = 22 +Global Const acNumericField = 17 +Global Const acPatternField = 19 +Global Const acProgressBar = 23 ' FREE ENTRY (USEFUL IN DIALOGS) +Global Const acRadioButton = 3 : Global Const acOptionButton = 3 +Global Const acScrollBar = 20 +Global Const acSpinButton = 21 +Global Const acSubform = 112 +Global Const acTextField = 9 : Global Const acTextBox = 9 +Global Const acTimeField = 16 + +REM AcRecord +REM ----------------------------------------------------------------- +Global Const acFirst = 2 +Global Const acGoTo = 4 +Global Const acLast = 3 +Global Const acNewRec = 5 +Global Const acNext = 1 +Global Const acPrevious = 0 + +REM FindRecord +REM ----------------------------------------------------------------- +Global Const acAnywhere = 0 +Global Const acEntire = 1 +Global Const acStart = 2 +Global Const acDown = 1 +Global Const acSearchAll = 2 +Global Const acUp = 0 +Global Const acAll = 0 +Global Const acCurrent = -1 + +REM AcDataObjectType +REM ----------------------------------------------------------------- +Global Const acActiveDataObject = -1 +Global Const acDataForm = 2 +Global Const acDataQuery = 1 +Global Const acDataServerView = 7 +Global Const acDataStoredProcedure = 9 +Global Const acDataTable = 0 + +REM AcQuitOption +REM ----------------------------------------------------------------- +Global Const acQuitPrompt = 0 +Global Const acQuitSaveAll = 1 +Global Const acQuitSaveNone = 2 + +REM AcCommand +REM ----------------------------------------------------------------- +Global Const acCmdAboutMicrosoftAccess = 35 +Global Const acCmdAboutOpenOffice = 35 +Global Const acCmdAboutLibreOffice = 35 +Global Const acCmdVisualBasicEditor = 525 +Global Const acCmdBringToFront = 52 +Global Const acCmdClose = 58 +Global Const acCmdToolbarsCustomize = 165 +Global Const acCmdChangeToCommandButton = 501 +Global Const acCmdChangeToCheckBox = 231 +Global Const acCmdChangeToComboBox = 230 +Global Const acCmdChangeToTextBox = 227 +Global Const acCmdChangeToLabel = 228 +Global Const acCmdChangeToImage = 234 +Global Const acCmdChangeToListBox = 229 +Global Const acCmdChangeToOptionButton = 233 +Global Const acCmdCopy = 190 +Global Const acCmdCut = 189 +Global Const acCmdCreateRelationship = 150 +Global Const acCmdDelete = 337 +Global Const acCmdDatabaseProperties = 256 +Global Const acCmdSQLView = 184 +Global Const acCmdRemove = 366 +Global Const acCmdDesignView = 183 +Global Const acCmdFormView = 281 +Global Const acCmdNewObjectForm = 136 +Global Const acCmdNewObjectTable = 134 +Global Const acCmdNewObjectView = 350 +Global Const acCmdOpenDatabase = 25 +Global Const acCmdNewObjectQuery = 135 +Global Const acCmdShowAllRelationships = 149 +Global Const acCmdNewObjectReport = 137 +Global Const acCmdSelectAll = 333 +Global Const acCmdRemoveTable = 84 +Global Const acCmdOpenTable = 221 +Global Const acCmdRename = 143 +Global Const acCmdDeleteRecord = 223 +Global Const acCmdApplyFilterSort = 93 +Global Const acCmdSnapToGrid = 62 +Global Const acCmdViewGrid = 63 +Global Const acCmdInsertHyperlink = 259 +Global Const acCmdMaximumRecords = 508 +Global Const acCmdObjectBrowser = 200 +Global Const acCmdPaste = 191 +Global Const acCmdPasteSpecial = 64 +Global Const acCmdPrint = 340 +Global Const acCmdPrintPreview = 54 +Global Const acCmdSaveRecord = 97 +Global Const acCmdFind = 30 +Global Const acCmdUndo = 292 +Global Const acCmdRefresh = 18 +Global Const acCmdRemoveFilterSort = 144 +Global Const acCmdRunMacro = 31 +Global Const acCmdSave = 20 +Global Const acCmdSaveAs = 21 +Global Const acCmdSelectAllRecords = 109 +Global Const acCmdSendToBack = 53 +Global Const acCmdSortDescending = 164 +Global Const acCmdSortAscending = 163 +Global Const acCmdTabOrder = 41 +Global Const acCmdDatasheetView = 282 +Global Const acCmdZoomSelection = 371 + +REM AcSendObjectType +REM ----------------------------------------------------------------- +Global Const acSendForm = 2 +Global Const acSendNoObject = -1 +Global Const acSendQuery = 1 +Global Const acSendReport = 3 +Global Const acSendTable = 0 + +REM AcOutputObjectType +REM ----------------------------------------------------------------- +Global Const acOutputTable = 0 +Global Const acOutputQuery = 1 +Global Const acOutputForm = 2 +Global Const acOutputArray = -1 + +REM AcEncoding +REM ----------------------------------------------------------------- +Global Const acUTF8Encoding = 76 + +REM AcFormat +REM ----------------------------------------------------------------- +Global Const acFormatPDF = "writer_pdf_Export" +Global Const acFormatODT = "writer8" +Global Const acFormatDOC = "MS Word 97" +Global Const acFormatHTML = "HTML" +Global Const acFormatODS = "calc8" +Global Const acFormatXLS = "MS Excel 97" +Global Const acFormatXLSX = "Calc MS Excel 2007 XML" +Global Const acFormatTXT = "Text - txt - csv (StarCalc)" + +REM AcExportQuality +REM ----------------------------------------------------------------- +Global Const acExportQualityPrint = 0 +Global Const acExportQualityScreen = 1 + +REM AcSysCmdAction +REM ----------------------------------------------------------------- +Global Const acSysCmdAccessDir = 9 +Global Const acSysCmdAccessVer = 7 +Global Const acSysCmdClearHelpTopic = 11 +Global Const acSysCmdClearStatus = 5 +Global Const acSysCmdGetObjectState = 10 +Global Const acSysCmdGetWorkgroupFile = 13 +Global Const acSysCmdIniFile = 8 +Global Const acSysCmdInitMeter = 1 +Global Const acSysCmdProfile = 12 +Global Const acSysCmdRemoveMeter = 3 +Global Const acSysCmdRuntime = 6 +Global Const acSysCmdSetStatus = 4 +Global Const acSysCmdUpdateMeter = 2 + +REM Type property +REM ----------------------------------------------------------------- +Global Const dbBigInt = 16 +Global Const dbBinary = 9 +Global Const dbBoolean = 1 +Global Const dbByte = 2 +Global Const dbChar = 18 +Global Const dbCurrency = 5 +Global Const dbDate = 8 +Global Const dbDecimal = 20 +Global Const dbDouble = 7 +Global Const dbFloat = 21 +Global Const dbGUID = 15 +Global Const dbInteger = 3 +Global Const dbLong = 4 +Global Const dbLongBinary = 11 ' (OLE Object) +Global Const dbMemo= 12 +Global Const dbNumeric = 19 +Global Const dbSingle = 6 +Global Const dbText = 10 +Global Const dbTime = 22 +Global Const dbTimeStamp = 23 +Global Const dbVarBinary = 17 +Global Const dbUndefined = -1 + +REM Attributes property +REM ----------------------------------------------------------------- +Global Const dbAutoIncrField = 16 +Global Const dbDescending = 1 +Global Const dbFixedField = 1 +Global Const dbHyperlinkField = 32768 +Global Const dbSystemField = 8192 +Global Const dbUpdatableField = 32 +Global Const dbVariableField = 2 + +REM OpenRecordset +REM ----------------------------------------------------------------- +Global Const dbOpenForwardOnly = 8 +Global Const dbSQLPassThrough = 64 +Global Const dbReadOnly = 4 + +REM Query types +REM ----------------------------------------------------------------- +Global Const dbQAction = 240 +Global Const dbQAppend = 64 +Global Const dbQDDL = 4 '96 +Global Const dbQDelete = 32 +Global Const dbQMakeTable = 128 '80 +Global Const dbQSelect = 0 +Global Const dbQSetOperation = 8 '128 +Global Const dbQSQLPassThrough = 1 '112 +Global Const dbQUpdate = 16 '48 + +REM Edit mode +REM ----------------------------------------------------------------- +Global Const dbEditNone = 0 +Global Const dbEditInProgress = 1 +Global Const dbEditAdd = 2 + +REM Toolbars +REM ----------------------------------------------------------------- +Global Const msoBarTypeNormal = 0 ' Usual toolbar +Global Const msoBarTypeMenuBar = 1 ' Menu bar +Global Const msoBarTypePopup = 2 ' Shortcut menu +Global Const msoBarTypeStatusBar = 11 ' Status bar +Global Const msoBarTypeFloater = 12 ' Floating window + +Global Const msoControlButton = 1 ' Command button +Global Const msoControlPopup = 10 ' Popup, submenu + +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 = 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/access2base.py b/wizards/source/access2base/access2base.py new file mode 100644 index 000000000..d68cd87aa --- /dev/null +++ b/wizards/source/access2base/access2base.py @@ -0,0 +1,1474 @@ +# -*- coding: utf-8 -*- + +# Copyright 2012-2020 Jean-Pierre LEDURE + +# ===================================================================================================================== +# === The Access2Base library is a part of the LibreOffice project. === +# === Full documentation is available on http://www.access2base.com === +# ===================================================================================================================== + +# Access2Base is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# Access2Base is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +# 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +# distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +# 2) The GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. If a copy of the LGPL was not +# distributed with this file, see http://www.gnu.org/licenses/ . + +""" +The access2base.py module implements an interface between Python (user) scripts and the Access2Base Basic library. + +Usage: + from access2base import * +Additionally, if Python and LibreOffice are started in separate processes: + If LibreOffice started from console ... (example for Linux) + ./soffice --accept='socket,host=localhost,port=2019;urp;' + then insert next statement + A2BConnect(hostname = 'localhost', port = 2019) + +Specific documentation about Access2Base and Python: + http://www.access2base.com/access2base.html#%5B%5BAccess2Base%20and%20Python%5D%5D +""" + +import uno +XSCRIPTCONTEXT = uno + +from platform import system as _opsys +import datetime, os, sys, traceback + +_LIBRARY = '' # Should be 'Access2Base' or 'Access2BaseDev' +_VERSION = '6.4' # Actual version number +_WRAPPERMODULE = 'Python' # Module name in the Access2Base library containing Python interfaces + +# CallByName types +_vbGet, _vbLet, _vbMethod, _vbSet, _vbUNO = 2, 4, 1, 8, 16 + + +class _Singleton(type): + """ + A Singleton design pattern + Credits: « Python in a Nutshell » by Alex Martelli, O'Reilly + """ + instances = {} + def __call__(cls, *args, **kwargs): + if cls not in cls.instances: + cls.instances[cls] = super(_Singleton, cls).__call__(*args, **kwargs) + return cls.instances[cls] + + +class acConstants(object, metaclass = _Singleton): + """ + VBA constants used in the Access2Base API. + Values derived from MSAccess, except when conflicts + """ + # Python special constants (used in the protocol between Python and Basic) + # ----------------------------------------------------------------- + Empty = '+++EMPTY+++' + Null = '+++NULL+++' + Missing = '+++MISSING+++' + FromIsoFormat = '%Y-%m-%d %H:%M:%S' # To be used with datetime.datetime.strptime() + + # AcCloseSave + # ----------------------------------------------------------------- + acSaveNo = 2 + acSavePrompt = 0 + acSaveYes = 1 + + # AcFormView + # ----------------------------------------------------------------- + acDesign = 1 + acNormal = 0 + acPreview = 2 + + # AcFormOpenDataMode + # ----------------------------------------------------------------- + acFormAdd = 0 + acFormEdit = 1 + acFormPropertySettings = -1 + acFormReadOnly = 2 + + # acView + # ----------------------------------------------------------------- + acViewDesign = 1 + acViewNormal = 0 + acViewPreview = 2 + + # acOpenDataMode + # ----------------------------------------------------------------- + acAdd = 0 + acEdit = 1 + acReadOnly = 2 + + # AcObjectType + # ----------------------------------------------------------------- + acDefault = -1 + acDiagram = 8 + acForm = 2 + acQuery = 1 + acReport = 3 + acTable = 0 + # Unexisting in MS/Access + acBasicIDE = 101 + acDatabaseWindow = 102 + acDocument = 111 + acWelcome = 112 + # Subtype if acDocument + docWriter = "Writer" + docCalc = "Calc" + docImpress = "Impress" + docDraw = "Draw" + docMath = "Math" + + # AcWindowMode + # ----------------------------------------------------------------- + acDialog = 3 + acHidden = 1 + acIcon = 2 + acWindowNormal = 0 + + # VarType constants + # ----------------------------------------------------------------- + vbEmpty = 0 + vbNull = 1 + vbInteger = 2 + vbLong = 3 + vbSingle = 4 + vbDouble = 5 + vbCurrency = 6 + vbDate = 7 + vbString = 8 + vbObject = 9 + vbBoolean = 11 + vbVariant = 12 + vbByte = 17 + vbUShort = 18 + vbULong = 19 + vbBigint = 35 + vbDecimal = 37 + vbArray = 8192 + + # MsgBox constants + # ----------------------------------------------------------------- + vbOKOnly = 0 # OK button only (default) + vbOKCancel = 1 # OK and Cancel buttons + vbAbortRetryIgnore = 2 # Abort, Retry, and Ignore buttons + vbYesNoCancel = 3 # Yes, No, and Cancel buttons + vbYesNo = 4 # Yes and No buttons + vbRetryCancel = 5 # Retry and Cancel buttons + vbCritical = 16 # Critical message + vbQuestion = 32 # Warning query + vbExclamation = 48 # Warning message + vbInformation = 64 # Information message + vbDefaultButton1 = 128 # First button is default (default) (VBA: 0) + vbDefaultButton2 = 256 # Second button is default + vbDefaultButton3 = 512 # Third button is default + vbApplicationModal = 0 # Application modal message box (default) + # MsgBox Return Values + # ----------------------------------------------------------------- + vbOK = 1 # OK button pressed + vbCancel = 2 # Cancel button pressed + vbAbort = 3 # Abort button pressed + vbRetry = 4 # Retry button pressed + vbIgnore = 5 # Ignore button pressed + vbYes = 6 # Yes button pressed + vbNo = 7 # No button pressed + + # Dialogs Return Values + # ------------------------------------------------------------------ + dlgOK = 1 # OK button pressed + dlgCancel = 0 # Cancel button pressed + + # Control Types + # ----------------------------------------------------------------- + acCheckBox = 5 + acComboBox = 7 + acCommandButton = 2 + acToggleButton = 122 + acCurrencyField = 18 + acDateField = 15 + acFileControl = 12 + acFixedLine = 24 # FREE ENTRY (USEFUL IN DIALOGS) + acFixedText = 10 + acLabel = 10 + acFormattedField = 1 # FREE ENTRY TAKEN TO NOT CONFUSE WITH acTextField + acGridControl = 11 + acGroupBox = 8 + acOptionGroup = 8 + acHiddenControl = 13 + acImageButton = 4 + acImageControl = 14 + acImage = 14 + acListBox = 6 + acNavigationBar = 22 + acNumericField = 17 + acPatternField = 19 + acProgressBar = 23 # FREE ENTRY (USEFUL IN DIALOGS) + acRadioButton = 3 + acOptionButton = 3 + acScrollBar = 20 + acSpinButton = 21 + acSubform = 112 + acTextField = 9 + acTextBox = 9 + acTimeField = 16 + + # AcRecord + # ----------------------------------------------------------------- + acFirst = 2 + acGoTo = 4 + acLast = 3 + acNewRec = 5 + acNext = 1 + acPrevious = 0 + + # FindRecord + # ----------------------------------------------------------------- + acAnywhere = 0 + acEntire = 1 + acStart = 2 + acDown = 1 + acSearchAll = 2 + acUp = 0 + acAll = 0 + acCurrent = -1 + + # AcDataObjectType + # ----------------------------------------------------------------- + acActiveDataObject = -1 + acDataForm = 2 + acDataQuery = 1 + acDataServerView = 7 + acDataStoredProcedure = 9 + acDataTable = 0 + + # AcQuitOption + # ----------------------------------------------------------------- + acQuitPrompt = 0 + acQuitSaveAll = 1 + acQuitSaveNone = 2 + + # AcCommand + # ----------------------------------------------------------------- + acCmdAboutMicrosoftAccess = 35 + acCmdAboutOpenOffice = 35 + acCmdAboutLibreOffice = 35 + acCmdVisualBasicEditor = 525 + acCmdBringToFront = 52 + acCmdClose = 58 + acCmdToolbarsCustomize = 165 + acCmdChangeToCommandButton = 501 + acCmdChangeToCheckBox = 231 + acCmdChangeToComboBox = 230 + acCmdChangeToTextBox = 227 + acCmdChangeToLabel = 228 + acCmdChangeToImage = 234 + acCmdChangeToListBox = 229 + acCmdChangeToOptionButton = 233 + acCmdCopy = 190 + acCmdCut = 189 + acCmdCreateRelationship = 150 + acCmdDelete = 337 + acCmdDatabaseProperties = 256 + acCmdSQLView = 184 + acCmdRemove = 366 + acCmdDesignView = 183 + acCmdFormView = 281 + acCmdNewObjectForm = 136 + acCmdNewObjectTable = 134 + acCmdNewObjectView = 350 + acCmdOpenDatabase = 25 + acCmdNewObjectQuery = 135 + acCmdShowAllRelationships = 149 + acCmdNewObjectReport = 137 + acCmdSelectAll = 333 + acCmdRemoveTable = 84 + acCmdOpenTable = 221 + acCmdRename = 143 + acCmdDeleteRecord = 223 + acCmdApplyFilterSort = 93 + acCmdSnapToGrid = 62 + acCmdViewGrid = 63 + acCmdInsertHyperlink = 259 + acCmdMaximumRecords = 508 + acCmdObjectBrowser = 200 + acCmdPaste = 191 + acCmdPasteSpecial = 64 + acCmdPrint = 340 + acCmdPrintPreview = 54 + acCmdSaveRecord = 97 + acCmdFind = 30 + acCmdUndo = 292 + acCmdRefresh = 18 + acCmdRemoveFilterSort = 144 + acCmdRunMacro = 31 + acCmdSave = 20 + acCmdSaveAs = 21 + acCmdSelectAllRecords = 109 + acCmdSendToBack = 53 + acCmdSortDescending = 164 + acCmdSortAscending = 163 + acCmdTabOrder = 41 + acCmdDatasheetView = 282 + acCmdZoomSelection = 371 + + # AcSendObjectType + # ----------------------------------------------------------------- + acSendForm = 2 + acSendNoObject = -1 + acSendQuery = 1 + acSendReport = 3 + acSendTable = 0 + + # AcOutputObjectType + # ----------------------------------------------------------------- + acOutputTable = 0 + acOutputQuery = 1 + acOutputForm = 2 + acOutputArray = -1 + + # AcEncoding + # ----------------------------------------------------------------- + acUTF8Encoding = 76 + + # AcFormat + # ----------------------------------------------------------------- + acFormatPDF = "writer_pdf_Export" + acFormatODT = "writer8" + acFormatDOC = "MS Word 97" + acFormatHTML = "HTML" + acFormatODS = "calc8" + acFormatXLS = "MS Excel 97" + acFormatXLSX = "Calc MS Excel 2007 XML" + acFormatTXT = "Text - txt - csv (StarCalc)" + + # AcExportQuality + # ----------------------------------------------------------------- + acExportQualityPrint = 0 + acExportQualityScreen = 1 + + # AcSysCmdAction + # ----------------------------------------------------------------- + acSysCmdAccessDir = 9 + acSysCmdAccessVer = 7 + acSysCmdClearHelpTopic = 11 + acSysCmdClearStatus = 5 + acSysCmdGetObjectState = 10 + acSysCmdGetWorkgroupFile = 13 + acSysCmdIniFile = 8 + acSysCmdInitMeter = 1 + acSysCmdProfile = 12 + acSysCmdRemoveMeter = 3 + acSysCmdRuntime = 6 + acSysCmdSetStatus = 4 + acSysCmdUpdateMeter = 2 + + # Type property + # ----------------------------------------------------------------- + dbBigInt = 16 + dbBinary = 9 + dbBoolean = 1 + dbByte = 2 + dbChar = 18 + dbCurrency = 5 + dbDate = 8 + dbDecimal = 20 + dbDouble = 7 + dbFloat = 21 + dbGUID = 15 + dbInteger = 3 + dbLong = 4 + dbLongBinary = 11 # (OLE Object) + dbMemo = 12 + dbNumeric = 19 + dbSingle = 6 + dbText = 10 + dbTime = 22 + dbTimeStamp = 23 + dbVarBinary = 17 + dbUndefined = -1 + + # Attributes property + # ----------------------------------------------------------------- + dbAutoIncrField = 16 + dbDescending = 1 + dbFixedField = 1 + dbHyperlinkField = 32768 + dbSystemField = 8192 + dbUpdatableField = 32 + dbVariableField = 2 + + # OpenRecordset + # ----------------------------------------------------------------- + dbOpenForwardOnly = 8 + dbSQLPassThrough = 64 + dbReadOnly = 4 + + # Query types + # ----------------------------------------------------------------- + dbQAction = 240 + dbQAppend = 64 + dbQDDL = 4 # 96 + dbQDelete = 32 + dbQMakeTable = 128 # 80 + dbQSelect = 0 + dbQSetOperation = 8 # 128 + dbQSQLPassThrough = 1 # 112 + dbQUpdate = 16 # 48 + + # Edit mode + # ----------------------------------------------------------------- + dbEditNone = 0 + dbEditInProgress = 1 + dbEditAdd = 2 + + # Toolbars + # ----------------------------------------------------------------- + msoBarTypeNormal = 0 # Usual toolbar + msoBarTypeMenuBar = 1 # Menu bar + msoBarTypePopup = 2 # Shortcut menu + msoBarTypeStatusBar = 11 # Status bar + msoBarTypeFloater = 12 # Floating window + + msoControlButton = 1 # Command button + msoControlPopup = 10 # Popup, submenu + + # New Lines + # ----------------------------------------------------------------- + vbCr = chr(13) + vbLf = chr(10) + + def _NewLine(): + if _opsys == 'Windows': return chr(13) + chr(10) + return chr(10) + + vbNewLine = _NewLine() + vbTab = chr(9) + + # Module types + # ----------------------------------------------------------------- + acClassModule = 1 + acStandardModule = 0 + + # (Module) procedure types + # ----------------------------------------------------------------- + vbext_pk_Get = 1 # A Property Get procedure + vbext_pk_Let = 2 # A Property Let procedure + vbext_pk_Proc = 0 # A Sub or Function procedure + vbext_pk_Set = 3 # A Property Set procedure + + +COMPONENTCONTEXT, DESKTOP, SCRIPTPROVIDER, THISDATABASEDOCUMENT = None, None, None, None + +def _ErrorHandler(type, value, tb): + ''' + Is the function to be set as new sys.excepthook to bypass the standard error handler + Derived from https://stackoverflow.com/questions/31949760/how-to-limit-python-traceback-to-specific-files + Handler removes traces pointing to methods located in access2base.py when error is due to a user programming error + sys.excepthook = _ErrorHandler + NOT APPLIED YET + ''' + + def check_file(name): + return 'access2base.py' not in name + + show = (fs for fs in traceback.extract_tb(tb) if check_file(fs.filename)) + fmt = traceback.format_list(show) + traceback.format_exception_only(type, value) + print(''.join(fmt), end = '', file = sys.stderr) + # Reset to standard handler + sys.excepthook = sys.__excepthook__ + + +def A2BConnect(hostname = '', port = 0): + """ + To be called explicitly by user scripts when Python process runs outside the LibreOffice process. + LibreOffice started as (Linux): + ./soffice --accept='socket,host=localhost,port=xxxx;urp;' + Otherwise called implicitly by the current module without arguments + Initializes COMPONENTCONTEXT, SCRIPTPROVIDER and DESKTOP + :param hostname: probably 'localhost' or '' + :param port: port number or 0 + :return: None + """ + global XSCRIPTCONTEXT, COMPONENTCONTEXT, DESKTOP, SCRIPTPROVIDER + # Determine COMPONENTCONTEXT, via socket or inside LibreOffice + if len(hostname) > 0 and port > 0: # Explicit connection request via socket + # Code derived from Bridge.py by Alain H. Romedenne + local_context = XSCRIPTCONTEXT.getComponentContext() + resolver = local_context.ServiceManager.createInstanceWithContext( + 'com.sun.star.bridge.UnoUrlResolver', local_context) + try: + conn = 'socket,host=%s,port=%d' % (hostname, port) + connection_url = 'uno:%s;urp;StarOffice.ComponentContext' % conn + established_context = resolver.resolve(connection_url) + except Exception: # thrown when LibreOffice specified instance isn't started + raise ConnectionError('Connection to LibreOffice failed (host = ' + hostname + ', port = ' + str(port) + ')') + COMPONENTCONTEXT = established_context + DESKTOP = None + elif len(hostname) == 0 and port == 0: # Usual interactive mode + COMPONENTCONTEXT = XSCRIPTCONTEXT.getComponentContext() + DESKTOP = COMPONENTCONTEXT.ServiceManager.createInstanceWithContext( 'com.sun.star.frame.Desktop', COMPONENTCONTEXT) + else: + raise SystemExit('The invocation of A2BConnect() has invalid arguments') + # Determine SCRIPTPROVIDER + servicemanager = COMPONENTCONTEXT.ServiceManager + masterscript = servicemanager.createInstanceWithContext("com.sun.star.script.provider.MasterScriptProviderFactory", COMPONENTCONTEXT) + SCRIPTPROVIDER = masterscript.createScriptProvider("") + Script = _A2B.xScript('TraceLog', 'Trace') # Don't use invokeMethod() to force reset of error stack + Script.invoke(('===>', 'Python wrapper loaded V.' + _VERSION, False), (), ()) + return None + + +class _A2B(object, metaclass = _Singleton): + """ + Collection of helper functions implementing the protocol between Python and Basic + Read comments in PythonWrapper Basic function + """ + + @classmethod + def BasicObject(cls, objectname): + objs = {'COLLECTION': _Collection + , 'COMMANDBAR': _CommandBar + , 'COMMANDBARCONTROL': _CommandBarControl + , 'CONTROL': _Control + , 'DATABASE': _Database + , 'DIALOG': _Dialog + , 'EVENT': _Event + , 'FIELD': _Field + , 'FORM': _Form + , 'MODULE': _Module + , 'OPTIONGROUP': _OptionGroup + , 'PROPERTY': _Property + , 'QUERYDEF': _QueryDef + , 'RECORDSET': _Recordset + , 'SUBFORM': _SubForm + , 'TABLEDEF': _TableDef + , 'TEMPVAR': _TempVar + } + return objs[objectname] + + @classmethod + def xScript(cls, script, module): + """ + At first call checks the existence of the Access2Base library + Initializes _LIBRARY with the found library name + First and next calls execute the given script in the given module of the _LIBRARY library + The script and module are presumed to exist + :param script: name of script + :param module: name of module + :return: the script object. NB: the execution is done with the invoke() method applied on the returned object + """ + global _LIBRARY + Script = None + def sScript(lib): + return 'vnd.sun.star.script:' + lib + '.' + module + '.' + script + '?language=Basic&location=application' + if _LIBRARY == '': + # Check the availability of the Access2Base library + for lib in ('Access2BaseDev', 'Access2Base'): + try: + if Script == None: + Script = SCRIPTPROVIDER.getScript(sScript(lib)) + _LIBRARY = lib + except Exception: + pass + if Script == None: + raise SystemExit('Access2Base basic library not found') + else: + Script = SCRIPTPROVIDER.getScript(sScript(_LIBRARY)) + return Script + + @classmethod + def A2BErrorCode(cls): + """ + Return the Access2Base error stack as a tuple + 0 => error code + 1 => severity level + 2 => short error message + 3 => long error message + """ + Script = cls.xScript('TraceErrorCode', 'Trace') + return Script.invoke((), (), ())[0] + + @classmethod + def invokeMethod(cls, script, module, *args): + """ + Direct call to a named script/module pair with their arguments + If the arguments do not match their definition at the Basic side, a TypeError is raised + :param script: name of script + :param module: name of module + :param args: list of arguments to be passed to the script + :return: the value returned by the script execution + """ + if COMPONENTCONTEXT == None: A2BConnect() # Connection from inside LibreOffice is done at first API invocation + Script = cls.xScript(script, module) + try: + Returned = Script.invoke((args), (), ())[0] + except: + raise TypeError("Access2Base error: method '" + script + "' in Basic module '" + module + "' call error. Check its arguments.") + else: + if Returned == None: + if cls.VerifyNoError(): return None + return Returned + + @classmethod + def invokeWrapper(cls, action, basic, script, *args): + """ + Call the Basic wrapper to invite it to execute the proposed action on a Basic object + If the arguments do not match their definition at the Basic side, a TypeError is raised + After execution, a check is done if the execution has raised an error within Basic + If yes, a TypeError is raised + :param action: Property Get, Property Let, Property Set, invoke Method or return UNO object + :param basic: the reference of the Basic object, i.e. the index in the array caching the addresses of the objects + conventionally Application = -1 and DoCmd = -2 + :param script: the property or method name + :param args: the arguments of the method, if any + :return: the value returned by the execution of the Basic routine + """ + if COMPONENTCONTEXT == None: A2BConnect() # Connection from inside LibreOffice is done at first API invocation + # Intercept special call to Application.Events() + if basic == Application.basicmodule and script == 'Events': + Script = cls.xScript('PythonEventsWrapper', _WRAPPERMODULE) + Returned = Script.invoke((args[0],), (), ()) + else: + Script = cls.xScript('PythonWrapper', _WRAPPERMODULE) + NoArgs = '+++NOARGS+++' # Conventional notation for properties/methods without arguments + if len(args) == 0: + args = (action,) + (basic,) + (script,) + (NoArgs,) + else: + args = (action,) + (basic,) + (script,) + args + try: + Returned = Script.invoke((args), (), ()) + except: + raise TypeError("Access2Base error: method '" + script + "' call error. Check its arguments.") + + if isinstance(Returned[0], tuple): + # Is returned value a reference to a basic object, a scalar or a UNO object ? + if len(Returned[0]) in (3, 4): + if Returned[0][0] == 0: # scalar + return Returned[0][1] + elif Returned[0][0] == 1: # reference to objects cache + basicobject = cls.BasicObject(Returned[0][2]) + if len(Returned[0]) == 3: + return basicobject(Returned[0][1], Returned[0][2]) + else: + return basicobject(Returned[0][1], Returned[0][2], Returned[0][3]) + elif Returned[0][0] == 2: # Null value + return None + else: # Should not happen + return None + else: # UNO object + return Returned[0] + elif Returned[0] == None: + if cls.VerifyNoError(): return None + else: # Should not happen + return Returned[0] + + @classmethod + def VerifyNoError(cls): + # has Access2Base generated an error ? + errorstack = cls.A2BErrorCode() # 0 = code, 1 = severity, 2 = short text, 3 = long text + if errorstack[1] in ('ERROR', 'FATAL', 'ABORT'): + raise TypeError('Access2Base error: ' + errorstack[3]) + return True + + +class Application(object, metaclass = _Singleton): + """ Collection of methods located in the Application (Basic) module """ + W = _A2B.invokeWrapper + basicmodule = -1 + + @classmethod + def AllDialogs(cls, dialog = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'AllDialogs', dialog) + @classmethod + def AllForms(cls, form = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'AllForms', form) + @classmethod + def AllModules(cls, module = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'AllModules', module) + @classmethod + def CloseConnection(cls): + return cls.W(_vbMethod, cls.basicmodule, 'CloseConnection') + @classmethod + def CommandBars(cls, bar = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'CommandBars', bar) + @classmethod + def CurrentDb(cls): + return cls.W(_vbMethod, cls.basicmodule, 'CurrentDb') + @classmethod + def CurrentUser(cls): + return cls.W(_vbMethod, cls.basicmodule, 'CurrentUser') + @classmethod + def DAvg(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DAvg', expression, domain, criteria) + @classmethod + def DCount(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DCount', expression, domain, criteria) + @classmethod + def DLookup(cls, expression, domain, criteria = '', orderclause = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DLookup', expression, domain, criteria, orderclause) + @classmethod + def DMax(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DMax', expression, domain, criteria) + @classmethod + def DMin(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DMin', expression, domain, criteria) + @classmethod + def DStDev(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DStDev', expression, domain, criteria) + @classmethod + def DStDevP(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DStDevP', expression, domain, criteria) + @classmethod + def DSum(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DSum', expression, domain, criteria) + @classmethod + def DVar(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DVar', expression, domain, criteria) + @classmethod + def DVarP(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DVarP', expression, domain, criteria) + @classmethod + def Events(cls, event): + return cls.W(_vbMethod, cls.basicmodule, 'Events', event) + @classmethod + def Forms(cls, form = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'Forms', form) + @classmethod + def getObject(cls, shortcut): + return cls.W(_vbMethod, cls.basicmodule, 'getObject', shortcut) + GetObject = getObject + @classmethod + def getValue(cls, shortcut): + return cls.W(_vbMethod, cls.basicmodule, 'getValue', shortcut) + GetValue = getValue + @classmethod + def HtmlEncode(cls, string, length = 0): + return cls.W(_vbMethod, cls.basicmodule, 'HtmlEncode', string, length) + @classmethod + def OpenConnection(cls, thisdatabasedocument = acConstants.Missing): + global THISDATABASEDOCUMENT + if COMPONENTCONTEXT == None: A2BConnect() # Connection from inside LibreOffice is done at first API invocation + if DESKTOP != None: + THISDATABASEDOCUMENT = DESKTOP.getCurrentComponent() + return _A2B.invokeMethod('OpenConnection', 'Application', THISDATABASEDOCUMENT) + @classmethod + def OpenDatabase(cls, connectionstring, username = '', password = '', readonly = False): + return cls.W(_vbMethod, cls.basicmodule, 'OpenDatabase', connectionstring, username + , password, readonly) + @classmethod + def ProductCode(cls): + return cls.W(_vbMethod, cls.basicmodule, 'ProductCode') + @classmethod + def setValue(cls, shortcut, value): + return cls.W(_vbMethod, cls.basicmodule, 'setValue', shortcut, value) + SetValue = setValue + @classmethod + def SysCmd(cls, action, text = '', value = -1): + return cls.W(_vbMethod, cls.basicmodule, 'SysCmd', action, text, value) + @classmethod + def TempVars(cls, var = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'TempVars', var) + @classmethod + def Version(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Version') + + +class DoCmd(object, metaclass = _Singleton): + """ Collection of methods located in the DoCmd (Basic) module """ + W = _A2B.invokeWrapper + basicmodule = -2 + + @classmethod + def ApplyFilter(cls, filter = '', sqlwhere = '', controlname = ''): + return cls.W(_vbMethod, cls.basicmodule, 'ApplyFilter', filter, sqlwhere, controlname) + @classmethod + def Close(cls, objecttype, objectname, save = acConstants.acSavePrompt): + return cls.W(_vbMethod, cls.basicmodule, 'Close', objecttype, objectname, save) + @classmethod + def CopyObject(cls, sourcedatabase, newname, sourceobjecttype, sourceobjectname): # 1st argument must be set + return cls.W(_vbMethod, cls.basicmodule, 'CopyObject', sourcedatabase, newname, sourceobjecttype + , sourceobjectname) + @classmethod + def FindNext(cls): + return cls.W(_vbMethod, cls.basicmodule, 'FindNext') + @classmethod + def FindRecord(cls, findwhat, match = acConstants.acEntire, matchcase = False, search = acConstants.acSearchAll + , searchasformatted = False, onlycurrentfield = acConstants.acCurrent, findfirst = True): + return cls.W(_vbMethod, cls.basicmodule, 'FindRecord', findwhat, match, matchcase, search + , searchasformatted, onlycurrentfield, findfirst) + @classmethod + def GetHiddenAttribute(cls, objecttype, objectname = ''): + return cls.W(_vbMethod, cls.basicmodule, 'GetHiddenAttribute', objecttype, objectname) + @classmethod + def GoToControl(cls, controlname): + return cls.W(_vbMethod, cls.basicmodule, 'GoToControl', controlname) + @classmethod + def GoToRecord(cls, objecttype = acConstants.acActiveDataObject, objectname = '', record = acConstants.acNext + , offset = 1): + return cls.W(_vbMethod, cls.basicmodule, 'GoToRecord', objecttype, objectname, record, offset) + @classmethod + def Maximize(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Maximize') + @classmethod + def Minimize(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Minimize') + @classmethod + def MoveSize(cls, left = -1, top = -1, width = -1, height = -1): + return cls.W(_vbMethod, cls.basicmodule, 'MoveSize', left, top, width, height) + @classmethod + def OpenForm(cls, formname, view = acConstants.acNormal, filter = '', wherecondition = '' + , datamode = acConstants.acFormEdit, windowmode = acConstants.acWindowNormal, openargs = ''): + return cls.W(_vbMethod, cls.basicmodule, 'OpenForm', formname, view, filter, wherecondition + , datamode, windowmode, openargs) + @classmethod + def OpenQuery(cls, queryname, view = acConstants.acNormal, datamode = acConstants.acEdit): + return cls.W(_vbMethod, cls.basicmodule, 'OpenQuery', queryname, view, datamode) + @classmethod + def OpenReport(cls, queryname, view = acConstants.acNormal): + return cls.W(_vbMethod, cls.basicmodule, 'OpenReport', queryname, view) + @classmethod + def OpenSQL(cls, sql, option = -1): + return cls.W(_vbMethod, cls.basicmodule, 'OpenSQL', sql, option) + @classmethod + def OpenTable(cls, tablename, view = acConstants.acNormal, datamode = acConstants.acEdit): + return cls.W(_vbMethod, cls.basicmodule, 'OpenTable', tablename, view, datamode) + @classmethod + def OutputTo(cls, objecttype, objectname = '', outputformat = '', outputfile = '', autostart = False, templatefile = '' + , encoding = acConstants.acUTF8Encoding, quality = acConstants.acExportQualityPrint): + if objecttype == acConstants.acOutputForm: encoding = 0 + return cls.W(_vbMethod, cls.basicmodule, 'OutputTo', objecttype, objectname, outputformat + , outputfile, autostart, templatefile, encoding, quality) + @classmethod + def Quit(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Quit') + @classmethod + def RunApp(cls, commandline): + return cls.W(_vbMethod, cls.basicmodule, 'RunApp', commandline) + @classmethod + def RunCommand(cls, command): + return cls.W(_vbMethod, cls.basicmodule, 'RunCommand', command) + @classmethod + def RunSQL(cls, SQL, option = -1): + return cls.W(_vbMethod, cls.basicmodule, 'RunSQL', SQL, option) + @classmethod + def SelectObject(cls, objecttype, objectname = '', indatabasewindow = False): + return cls.W(_vbMethod, cls.basicmodule, 'SelectObject', objecttype, objectname, indatabasewindow) + @classmethod + def SendObject(cls, objecttype = acConstants.acSendNoObject, objectname = '', outputformat = '', to = '', cc = '' + , bcc = '', subject = '', messagetext = '', editmessage = True, templatefile = ''): + return cls.W(_vbMethod, cls.basicmodule, 'SendObject', objecttype, objectname, outputformat, to, cc + , bcc, subject, messagetext, editmessage, templatefile) + @classmethod + def SetHiddenAttribute(cls, objecttype, objectname = '', hidden = True): + return cls.W(_vbMethod, cls.basicmodule, 'SetHiddenAttribute', objecttype, objectname, hidden) + @classmethod + def SetOrderBy(cls, orderby = '', controlname = ''): + return cls.W(_vbMethod, cls.basicmodule, 'SetOrderBy', orderby, controlname) + @classmethod + def ShowAllRecords(cls): + return cls.W(_vbMethod, cls.basicmodule, 'ShowAllRecords') + + +class Basic(object, metaclass = _Singleton): + """ Collection of helper functions having the same behaviour as their Basic counterparts """ + M = _A2B.invokeMethod + + @classmethod + def ConvertFromUrl(cls, url): + return cls.M('PyConvertFromUrl', _WRAPPERMODULE, url) + + @classmethod + def ConvertToUrl(cls, file): + return cls.M('PyConvertToUrl', _WRAPPERMODULE, file) + + @classmethod + def CreateUnoService(cls, servicename): + return cls.M('PyCreateUnoService', _WRAPPERMODULE, servicename) + + @classmethod + def DateAdd(cls, add, count, datearg): + if isinstance(datearg, datetime.datetime): datearg = datearg.isoformat() + dateadd = cls.M('PyDateAdd', _WRAPPERMODULE, add, count, datearg) + return datetime.datetime.strptime(dateadd, acConstants.FromIsoFormat) + + @classmethod + def DateDiff(cls, add, date1, date2, weekstart = 1, yearstart = 1): + if isinstance(date1, datetime.datetime): date1 = date1.isoformat() + if isinstance(date2, datetime.datetime): date2 = date2.isoformat() + return cls.M('PyDateDiff', _WRAPPERMODULE, add, date1, date2, weekstart, yearstart) + + @classmethod + def DatePart(cls, add, datearg, weekstart = 1, yearstart = 1): + if isinstance(datearg, datetime.datetime): datearg = datearg.isoformat() + return cls.M('PyDatePart', _WRAPPERMODULE, add, datearg, weekstart, yearstart) + + @classmethod + def DateValue(cls, datestring): + datevalue = cls.M('PyDateValue', _WRAPPERMODULE, datestring) + return datetime.datetime.strptime(datevalue, acConstants.FromIsoFormat) + + @classmethod + def Format(cls, value, format = None): + if isinstance(value, (datetime.datetime, datetime.date, datetime.time, )): + value = value.isoformat() + return cls.M('PyFormat', _WRAPPERMODULE, value, format) + + @classmethod + def GetGUIType(cls): + return cls.M('PyGetGUIType', _WRAPPERMODULE) + + @staticmethod + def GetPathSeparator(): + return os.sep + + @classmethod + def GetSystemTicks(cls): + return cls.M('PyGetSystemTicks', _WRAPPERMODULE) + + @classmethod + def MsgBox(cls, text, type = None, dialogtitle = None): + return cls.M('PyMsgBox', _WRAPPERMODULE, text, type, dialogtitle) + + class GlobalScope(object, metaclass = _Singleton): + @classmethod + def BasicLibraries(cls): + return Basic.M('PyGlobalScope', _WRAPPERMODULE, 'Basic') + @classmethod + def DialogLibraries(self): + return Basic.M('PyGlobalScope', _WRAPPERMODULE, 'Dialog') + + @classmethod + def InputBox(cls, text, title = None, default = None, xpos = None, ypos = None): + return cls.M('PyInputBox', _WRAPPERMODULE, text, title, default, xpos, ypos) + + @staticmethod + def Now(): + return datetime.datetime.now() + + @staticmethod + def RGB(red, green, blue): + return int('%02x%02x%02x' % (red, green, blue), 16) + + @classmethod + def Timer(cls): + return cls.M('PyTimer', _WRAPPERMODULE) + + @staticmethod + def Xray(myObject): + xrayscript = 'vnd.sun.star.script:XrayTool._Main.Xray?language=Basic&location=application' + xScript = SCRIPTPROVIDER.getScript(xrayscript) + xScript.invoke((myObject,), (), ()) + return + + +class _BasicObject(object): + """ + Parent class of Basic objects + Each subclass is identified by its classProperties: + dictionary with keys = allowed properties, value = True if editable or False + Each instance is identified by its + - reference in the cache managed by Basic + - type ('DATABASE', 'COLLECTION', ...) + - name (form, control, ... name) - may be blank + Properties are got and set following next strategy: + 1. Property names are controlled strictly ('Value' and not 'value') + 2. Getting a property value for the first time is always done via a Basic call + 3. Next occurrences are fetched from the Python dictionary of the instance if the property is read-only, otherwise via a Basic call + 4. Methods output might force the deletion of a property from the dictionary ('MoveNext' changes 'BOF' and 'EOF' properties) + 5. Setting a property value is done via a Basic call, except if self.internal == True + """ + W = _A2B.invokeWrapper + internal_attributes = ('objectreference', 'objecttype', 'name', 'internal') + + def __init__(self, reference = -1, objtype = None, name = ''): + self.objectreference = reference # reference in the cache managed by Basic + self.objecttype = objtype # ('DATABASE', 'COLLECTION', ...) + self.name = name # '' when no name + self.internal = False # True to exceptionally allow assigning a new value to a read-only property + self.localProperties = () + + def __getattr__(self, name): + if name in ('classProperties', 'localProperties'): + pass + elif name in self.classProperties: + # Get Property from Basic + return self.W(_vbGet, self.objectreference, name) + # Usual attributes getter + return super(_BasicObject, self).__getattribute__(name) + + def __setattr__(self, name, value): + if name in ('classProperties', 'localProperties'): + pass + elif name in self.classProperties: + if self.internal: # internal = True forces property setting even if property is read-only + pass + elif self.classProperties[name] == True: # True == Editable + self.W(_vbLet, self.objectreference, name, value) + else: + raise AttributeError("type object '" + self.objecttype + "' has no editable attribute '" + name + "'") + elif name[0:2] == '__' or name in self.internal_attributes or name in self.localProperties: + pass + else: + raise AttributeError("type object '" + self.objecttype + "' has no attribute '" + name + "'") + object.__setattr__(self, name, value) + return + + def __repr__(self): + repr = "Basic object (type='" + self.objecttype + "', index=" + str(self.objectreference) + if len(self.name) > 0: repr += ", name='" + self.name + "'" + return repr + ")" + + def _Reset(self, propertyname, basicreturn = None): + """ force new value or erase properties from dictionary (done to optimize calls to Basic scripts) """ + if propertyname in ('BOF', 'EOF'): + # After a Move method invocation on a Recordset object, BOF or EOF likely to be got soon + if isinstance(basicreturn, int): + self.internal = True + # f.i. basicreturn = 0b10 means: BOF = True, EOF = False + self.BOF = basicreturn in (2, 3, -2, -3) + self.EOF = basicreturn in (1, 3, -1, -3) + self.internal = False + return ( basicreturn >= 0 ) + else: + # Suppress possibly invalid property values: e.g. RecordCount after Delete applied on Recordset object + if property in self.__dict__: + del(self.propertyname) + return basicreturn + + @property + def Name(self): return self.name + @property + def ObjectType(self): return self.objecttype + + def Dispose(self): + return self.W(_vbMethod, self.objectreference, 'Dispose') + def getProperty(self, propertyname, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'getProperty', propertyname, index) + GetProperty = getProperty + def hasProperty(self, propertyname): + return propertyname in tuple(self.classProperties.keys()) + HasProperty = hasProperty + def Properties(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Properties', index) + def setProperty(self, propertyname, value, index = acConstants.Missing): + if self.hasProperty(propertyname): + if self.W(_vbMethod, self.objectreference, 'setProperty', propertyname, value, index): + return self.__setattr__(propertyname, value) + raise AttributeError("type object '" + self.objecttype + "' has no editable attribute '" + propertyname + "'") + SetProperty = setProperty + + +class _Collection(_BasicObject): + """ Collection object built as a Python iterator """ + classProperties = dict(Count = False) + def __init__(self, reference = -1, objtype = None): + super().__init__(reference, objtype) + self.localProperties = ('count', 'index') + self.count = self.Count + self.index = 0 + def __iter__(self): + self.index = 0 + return self + def __next__(self): + if self.index >= self.count: + raise StopIteration + next = self.Item(self.index) + self.index = self.index + 1 + return next + def __len__(self): + return self.count + + def Add(self, table, value = acConstants.Missing): + if isinstance(table, _BasicObject): # Add method applied to a TABLEDEFS collection + return self.W(_vbMethod, self.objectreference, 'Add', table.objectreference) + else: # Add method applied to a TEMPVARS collection + add = self.W(_vbMethod, self.objectreference, 'Add', table, value) + self.count = self.Count + return add + def Delete(self, name): + return self.W(_vbMethod, self.objectreference, 'Delete', name) + def Item(self, index): + return self.W(_vbMethod, self.objectreference, 'Item', index) + def Remove(self, tempvarname): + remove = self.W(_vbMethod, self.objectreference, 'Remove', tempvarname) + self.count = self.Count + return remove + def RemoveAll(self): + remove = self.W(_vbMethod, self.objectreference, 'RemoveAll') + self.count = self.Count + return remove + + +class _CommandBar(_BasicObject): + classProperties = dict(BuiltIn = False, Parent = False, Visible = True) + + def CommandBarControls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'CommandBarControls', index) + def Reset(self): + return self.W(_vbMethod, self.objectreference, 'Reset') + + +class _CommandBarControl(_BasicObject): + classProperties = dict(BeginGroup = False, BuiltIn = False, Caption = True, Index = False, OnAction = True + , Parent = False, TooltipText = True, Type = False, Visible = True) + + def Execute(self): + return self.W(_vbMethod, self.objectreference, 'Execute') + + +class _Control(_BasicObject): + classProperties = dict(BackColor = True, BorderColor = True, BorderStyle = True, Cancel = True, Caption = True + , ControlSource = False, ControlTipText = True, ControlType = False, Default = True + , DefaultValue = True, Enabled = True, FontBold = True, FontItalic = True, FontName = True + , FontSize = True, FontUnderline = True, FontWeight = True, ForeColor = True, Form = False + , Format = True, ItemData = False, ListCount = False, ListIndex = True, Locked = True, MultiSelect = True + , OnActionPerformed = True, OnAdjustmentValueChanged = True, OnApproveAction = True + , OnApproveReset = True, OnApproveUpdate = True, OnChanged = True, OnErrorOccurred = True + , OnFocusGained = True, OnFocusLost = True, OnItemStateChanged = True, OnKeyPressed = True + , OnKeyReleased = True, OnMouseDragged = True, OnMouseEntered = True, OnMouseExited = True + , OnMouseMoved = True, OnMousePressed = True, OnMouseReleased = True, OnResetted = True, OnTextChanged = True + , OnUpdated = True, OptionValue = False, Page = False, Parent = False, Picture = True, Required = True + , RowSource = True, RowSourceType = True, Selected = True, SelLength = True, SelStart = True, SelText = True + , SubType = False, TabIndex = True, TabStop = True, Tag = True, Text = False, TextAlign = True + , TripleState = True, Value = True, Visible = True + ) + + @property + def BoundField(self): return self.W(_vbUNO, self.objectreference, 'BoundField') + @property + def ControlModel(self): return self.W(_vbUNO, self.objectreference, 'ControlModel') + @property + def ControlView(self): return self.W(_vbUNO, self.objectreference, 'ControlView') + @property + def LabelControl(self): return self.W(_vbUNO, self.objectreference, 'LabelControl') + + def AddItem(self, value, index = -1): + basicreturn = self.W(_vbMethod, self.objectreference, 'AddItem', value, index) + self._Reset('ItemData') + self._Reset('ListCount') + return basicreturn + def Controls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Controls', index) + # Overrides method in parent class: list of properties is strongly control type dependent + def hasProperty(self, propertyname): + return self.W(_vbMethod, self.objectreference, 'hasProperty', propertyname) + HasProperty = hasProperty + def RemoveItem(self, index): + basicreturn = self.W(_vbMethod, self.objectreference, 'RemoveItem', index) + self._Reset('ItemData') + self._Reset('ListCount') + return basicreturn + def Requery(self): + return self.W(_vbMethod, self.objectreference, 'Requery') + def SetSelected(self, value, index): + return self.W(_vbMethod, self.objectreference, 'SetSelected', value, index) + def SetFocus(self): + return self.W(_vbMethod, self.objectreference, 'SetFocus') + + +class _Database(_BasicObject): + classProperties = dict(Connect = False, OnCreate = True + , OnFocus = True, OnLoad = True, OnLoadFinished = True, OnModifyChanged = True, OnNew = True + , OnPrepareUnload = True, OnPrepareViewClosing = True, OnSave = True, OnSaveAs = True + , OnSaveAsDone = True, OnSaveAsFailed = True, OnSaveDone = True, OnSaveFailed = True + , OnSubComponentClosed = True, OnSubComponentOpened = True, OnTitleChanged = True, OnUnfocus = True + , OnUnload = True, OnViewClosed = True, OnViewCreated = True, Version = False + ) + + @property + def Connection(self): return self.W(_vbUNO, self.objectreference, 'Connection') + @property + def Document(self): return self.W(_vbUNO, self.objectreference, 'Document') + @property + def MetaData(self): return self.W(_vbUNO, self.objectreference, 'MetaData') + + def Close(self): + return self.W(_vbMethod, self.objectreference, 'Close') + def CloseAllRecordsets(self): + return self.W(_vbMethod, self.objectreference, 'CloseAllRecordsets') + def CreateQueryDef(self, name, sqltext, option = -1): + return self.W(_vbMethod, self.objectreference, 'CreateQueryDef', name, sqltext, option) + def CreateTableDef(self, name): + return self.W(_vbMethod, self.objectreference, 'CreateTableDef', name) + def DAvg(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DAvg', expression, domain, criteria) + def DCount(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DCount', expression, domain, criteria) + def DLookup(self, expression, domain, criteria = '', orderclause = ''): + return self.W(_vbMethod, self.objectreference, 'DLookup', expression, domain, criteria, orderclause) + def DMax(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DMax', expression, domain, criteria) + def DMin(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DMin', expression, domain, criteria) + def DStDev(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DStDev', expression, domain, criteria) + def DStDevP(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DStDevP', expression, domain, criteria) + def DVar(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DVar', expression, domain, criteria) + def DVarP(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DVarP', expression, domain, criteria) + def OpenRecordset(self, source, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', source, type, option, lockedit) + def OpenSQL(self, SQL, option = -1): + return self.W(_vbMethod, self.objectreference, 'OpenSQL', SQL, option) + def OutputTo(self, objecttype, objectname = '', outputformat = '', outputfile = '', autostart = False, templatefile = '' + , encoding = acConstants.acUTF8Encoding, quality = acConstants.acExportQualityPrint): + if objecttype == acConstants.acOutputForm: encoding = 0 + return self.W(_vbMethod, self.objectreference, 'OutputTo', objecttype, objectname, outputformat, outputfile + , autostart, templatefile, encoding, quality) + def QueryDefs(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'QueryDefs', index) + def Recordsets(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Recordsets', index) + def RunSQL(self, SQL, option = -1): + return self.W(_vbMethod, self.objectreference, 'RunSQL', SQL, option) + def TableDefs(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'TableDefs', index) + + +class _Dialog(_BasicObject): + classProperties = dict(Caption = True, Height = True, IsLoaded = False, OnFocusGained = True + , OnFocusLost = True, OnKeyPressed = True, OnKeyReleased = True, OnMouseDragged = True + , OnMouseEntered = True, OnMouseExited = True, OnMouseMoved = True, OnMousePressed = True + , OnMouseReleased = True, Page = True, Parent = False, Visible = True, Width = True + ) + + @property + def UnoDialog(self): return self.W(_vbUNO, self.objectreference, 'UnoDialog') + + def EndExecute(self, returnvalue): + return self.W(_vbMethod, self.objectreference, 'EndExecute', returnvalue) + def Execute(self): + return self.W(_vbMethod, self.objectreference, 'Execute') + def Move(self, left = -1, top = -1, width = -1, height = -1): + return self.W(_vbMethod, self.objectreference, 'Move', left, top, width, height) + def OptionGroup(self, groupname): + return self.W(_vbMethod, self.objectreference, 'OptionGroup', groupname) + def Start(self): + return self.W(_vbMethod, self.objectreference, 'Start') + def Terminate(self): + return self.W(_vbMethod, self.objectreference, 'Terminate') + +class _Event(_BasicObject): + classProperties = dict(ButtonLeft = False, ButtonMiddle = False, ButtonRight = False, ClickCount = False + , ContextShortcut = False, EventName = False, EventType = False, FocusChangeTemporary = False + , KeyAlt = False, KeyChar = False, KeyCode = False, KeyCtrl = False, KeyFunction = False, KeyShift = False + , Recommendation = False, RowChangeAction = False, Source = False, SubComponentName = False + , SubComponentType = False, XPos = False, YPos = False + ) + + +class _Field(_BasicObject): + classProperties = dict(DataType = False, DataUpdatable = False, DbType = False, DefaultValue = True + , Description = True, FieldSize = False, Size = False, Source = False + , SourceField = False, SourceTable = False, TypeName = False, Value = True + ) + + @property + def Column(self): return self.W(_vbUNO, self.objectreference, 'Column') + + def AppendChunk(self, value): + return self.W(_vbMethod, self.objectreference, 'AppendChunk', value) + def GetChunk(self, offset, numbytes): + return self.W(_vbMethod, self.objectreference, 'GetChunk', offset, numbytes) + def ReadAllBytes(self, file): + return self.W(_vbMethod, self.objectreference, 'ReadAllBytes', file) + def ReadAllText(self, file): + return self.W(_vbMethod, self.objectreference, 'ReadAllText', file) + def WriteAllBytes(self, file): + return self.W(_vbMethod, self.objectreference, 'WriteAllBytes', file) + def WriteAllText(self, file): + return self.W(_vbMethod, self.objectreference, 'WriteAllText', file) + + +class _Form(_BasicObject): + classProperties = dict(AllowAdditions = True, AllowDeletions = True, AllowEdits = True, Bookmark = True + , Caption = True, CurrentRecord = True, Filter = True, FilterOn = True, Height = True + , IsLoaded = False, OnApproveCursorMove = True, OnApproveParameter = True, OnApproveReset = True + , OnApproveRowChange = True, OnApproveSubmit = True, OnConfirmDelete = True, OnCursorMoved = True + , OnErrorOccurred = True, OnLoaded = True, OnReloaded = True, OnReloading = True, OnResetted = True + , OnRowChanged = True, OnUnloaded = True, OnUnloading = True, OpenArgs = False, OrderBy = True + , OrderByOn = True, Parent = False, Recordset = False, RecordSource = True, Visible = True + , Width = True + ) + + @property + def Component(self): return self.W(_vbUNO, self.objectreference, 'Component') + @property + def ContainerWindow(self): return self.W(_vbUNO, self.objectreference, 'ContainerWindow') + @property + def DatabaseForm(self): return self.W(_vbUNO, self.objectreference, 'DatabaseForm') + + def Close(self): + return self.W(_vbMethod, self.objectreference, 'Close') + def Controls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Controls', index) + def Move(self, left = -1, top = -1, width = -1, height = -1): + return self.W(_vbMethod, self.objectreference, 'Move', left, top, width, height) + def OptionGroup(self, groupname): + return self.W(_vbMethod, self.objectreference, 'OptionGroup', groupname) + def Refresh(self): + return self.W(_vbMethod, self.objectreference, 'Refresh') + def Requery(self): + return self.W(_vbMethod, self.objectreference, 'Requery') + def SetFocus(self): + return self.W(_vbMethod, self.objectreference, 'SetFocus') + + +class _Module(_BasicObject): + classProperties = dict(CountOfDeclarationLines = False, CountOfLines = False + , ProcStartLine = False, Type = False + ) + def __init__(self, reference = -1, objtype = None, name = ''): + super().__init__(reference, objtype, name) + self.localProperties = ('startline', 'startcolumn', 'endline', 'endcolumn', 'prockind') + + def Find(self, target, startline, startcolumn, endline, endcolumn, wholeword = False + , matchcase = False, patternsearch = False): + Returned = self.W(_vbMethod, self.objectreference, 'Find', target, startline, startcolumn, endline + , endcolumn, wholeword, matchcase, patternsearch) + if isinstance(Returned, tuple): + if Returned[0] == True and len(Returned) == 5: + self.startline = Returned[1] + self.startcolumn = Returned[2] + self.endline = Returned[3] + self.endcolumn = Returned[4] + return Returned[0] + return Returned + def Lines(self, line, numlines): + return self.W(_vbMethod, self.objectreference, 'Lines', line, numlines) + def ProcBodyLine(self, procname, prockind): + return self.W(_vbMethod, self.objectreference, 'ProcBodyLine', procname, prockind) + def ProcCountLines(self, procname, prockind): + return self.W(_vbMethod, self.objectreference, 'ProcCountLines', procname, prockind) + def ProcOfLine(self, line, prockind): + Returned = self.W(_vbMethod, self.objectreference, 'ProcOfLine', line, prockind) + if isinstance(Returned, tuple): + if len(Returned) == 2: + self.prockind = Returned[1] + return Returned[0] + return Returned + def ProcStartLine(self, procname, prockind): + return self.W(_vbMethod, self.objectreference, 'ProcStartLine', procname, prockind) + + +class _OptionGroup(_BasicObject): + classProperties = dict(Count = False, Value = True) + + def Controls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Controls', index) + + +class _Property(_BasicObject): + classProperties = dict(Value = True) + + +class _QueryDef(_BasicObject): + classProperties = dict(SQL = True, Type = False) + + @property + def Query(self): return self.W(_vbUNO, self.objectreference, 'Query') + + def Execute(self, options = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Execute', options) + def Fields(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Fields', index) + def OpenRecordset(self, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', type, option, lockedit) + + +class _Recordset(_BasicObject): + classProperties = dict(AbsolutePosition = True, BOF = False, Bookmark = True, Bookmarkable = False + , EditMode = False, EOF = False, Filter = True, RecordCount = False + ) + + @property + def RowSet(self): return self.W(_vbUNO, self.objectreference, 'RowSet') + + def AddNew(self): + return self.W(_vbMethod, self.objectreference, 'AddNew') + def CancelUpdate(self): + return self.W(_vbMethod, self.objectreference, 'CancelUpdate') + def Clone(self): + return self.W(_vbMethod, self.objectreference, 'Clone') + def Close(self): + return self.W(_vbMethod, self.objectreference, 'Close') + def Delete(self): + return self._Reset('RecordCount',self.W(_vbMethod, self.objectreference, 'Delete')) + def Edit(self): + return self.W(_vbMethod, self.objectreference, 'Edit') + def Fields(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Fields', index) + def GetRows(self, numrows): + return self.W(_vbMethod, self.objectreference, 'GetRows', numrows) + def Move(self, rows, startbookmark = acConstants.Missing): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'Move', rows, startbookmark)) + def MoveFirst(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MoveFirst')) + def MoveLast(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MoveLast')) + def MoveNext(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MoveNext')) + def MovePrevious(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MovePrevious')) + def OpenRecordset(self, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', type, option, lockedit) + def Update(self): + return self._Reset('RecordCount',self.W(_vbMethod, self.objectreference, 'Update')) + + +class _SubForm(_Form): + classProperties = dict(AllowAdditions = True, AllowDeletions = True, AllowEdits = True, CurrentRecord = True + , Filter = True, FilterOn = True, LinkChildFields = False, LinkMasterFields = False + , OnApproveCursorMove = True, OnApproveParameter = True, OnApproveReset = True + , OnApproveRowChange = True, OnApproveSubmit = True, OnConfirmDelete = True, OnCursorMoved = True + , OnErrorOccurred = True, OnLoaded = True, OnReloaded = True, OnReloading = True, OnResetted = True + , OnRowChanged = True, OnUnloaded = True, OnUnloading = True, OrderBy = True + , OrderByOn = True, Parent = False, Recordset = False, RecordSource = True, Visible = True + ) + + def SetFocus(self): + raise AttributeError("type object 'SubForm' has no method 'SetFocus'") + + +class _TableDef(_BasicObject): + classProperties = dict() + + @property + def Table(self): return self.W(_vbUNO, self.objectreference, 'Table') + + def CreateField(self, name, type, size = 0, attributes = 0): + return self.W(_vbMethod, self.objectreference, 'CreateField', name, type, size, attributes) + def Fields(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Fields', index) + def OpenRecordset(self, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', type, option, lockedit) + + +class _TempVar(_BasicObject): + classProperties = dict(Value = True) + +""" +Set of directly callable error handling methods +""" +def DebugPrint(*args): + dargs = () + for arg in args: + if isinstance(arg, _BasicObject): + arg = ('[' + arg.objecttype + '] ' + arg.name).rstrip() + dargs = dargs + (arg,) + return _A2B.invokeMethod('DebugPrint', _WRAPPERMODULE, *dargs) +def TraceConsole(): return _A2B.invokeMethod('TraceConsole', 'Trace') +def TraceError(tracelevel, errorcode, errorprocedure, errorline): + return _A2B.invokeMethod('TraceError', 'Trace', tracelevel, errorcode, errorprocedure, errorline) +def TraceLevel(newtracelevel = 'ERROR'): return _A2B.invokeMethod('TraceLevel', 'Trace', newtracelevel) +def TraceLog(tracelevel, text, messagebox = True): + return _A2B.invokeMethod('TraceLog', 'Trace', tracelevel, text, messagebox) + diff --git a/wizards/source/access2base/dialog.xlb b/wizards/source/access2base/dialog.xlb new file mode 100644 index 000000000..dc06162b7 --- /dev/null +++ b/wizards/source/access2base/dialog.xlb @@ -0,0 +1,6 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd"> +<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Access2Base" library:readonly="false" library:passwordprotected="false"> + <library:element library:name="dlgTrace"/> + <library:element library:name="dlgFormat"/> +</library:library> diff --git a/wizards/source/access2base/dlgFormat.xdl b/wizards/source/access2base/dlgFormat.xdl new file mode 100644 index 000000000..4b93fd720 --- /dev/null +++ b/wizards/source/access2base/dlgFormat.xdl @@ -0,0 +1,19 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE dlg:window PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "dialog.dtd"> +<dlg:window xmlns:dlg="http://openoffice.org/2000/dialog" xmlns:script="http://openoffice.org/2000/script" dlg:id="dlgFormat" dlg:left="246" dlg:top="119" dlg:width="153" dlg:height="40" dlg:help-text="Export the form" dlg:closeable="true" dlg:moveable="true" dlg:title="OutputTo"> + <dlg:bulletinboard> + <dlg:combobox dlg:id="cboFormat" dlg:tab-index="0" dlg:left="4" dlg:top="18" dlg:width="71" dlg:height="8" dlg:help-text="Format in which the form should be exported" dlg:value="PDF" dlg:spin="true"> + <dlg:menupopup> + <dlg:menuitem dlg:value="PDF"/> + <dlg:menuitem dlg:value="ODT"/> + <dlg:menuitem dlg:value="DOC"/> + <dlg:menuitem dlg:value="HTML"/> + </dlg:menupopup> + </dlg:combobox> + <dlg:text dlg:id="lblFormat" dlg:tab-index="1" dlg:left="4" dlg:top="7" dlg:width="100" dlg:height="9" dlg:help-text="Format in which the form should be exported" dlg:value="Select the output format"/> + <dlg:button dlg:id="cmdOK" dlg:tab-index="2" dlg:left="111" dlg:top="5" dlg:width="35" dlg:height="12" dlg:help-text="Validate your choice" dlg:default="true" dlg:value="OK" dlg:button-type="ok"> + <script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Access2Base.Trace._TraceOK?language=Basic&location=application" script:language="Script"/> + </dlg:button> + <dlg:button dlg:id="cmdCancel" dlg:tab-index="3" dlg:left="111" dlg:top="20" dlg:width="35" dlg:height="12" dlg:help-text="Cancel and close the dialog" dlg:value="Cancel" dlg:button-type="cancel"/> + </dlg:bulletinboard> +</dlg:window>
\ No newline at end of file diff --git a/wizards/source/access2base/dlgTrace.xdl b/wizards/source/access2base/dlgTrace.xdl new file mode 100644 index 000000000..08324e47c --- /dev/null +++ b/wizards/source/access2base/dlgTrace.xdl @@ -0,0 +1,33 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE dlg:window PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "dialog.dtd"> +<dlg:window xmlns:dlg="http://openoffice.org/2000/dialog" xmlns:script="http://openoffice.org/2000/script" dlg:id="dlgTrace" dlg:left="81" dlg:top="63" dlg:width="438" dlg:height="154" dlg:help-text="Manage the console file and its entries" dlg:closeable="true" dlg:moveable="true" dlg:title="Console"> + <dlg:styles> + <dlg:style dlg:style-id="0" dlg:font-name="Courier New" dlg:font-stylename="Regular" dlg:font-family="modern"/> + <dlg:style dlg:style-id="1" dlg:look="simple"/> + <dlg:style dlg:style-id="2" dlg:background-color="0xe6e6e6" dlg:border="none"/> + </dlg:styles> + <dlg:bulletinboard> + <dlg:text dlg:id="lblEntries" dlg:tab-index="3" dlg:left="265" dlg:top="134" dlg:width="130" dlg:height="9" dlg:help-text="Clear the list and resize the circular buffer" dlg:value="Set max number of entries" dlg:align="right"/> + <dlg:numericfield dlg:id="numEntries" dlg:tab-index="4" dlg:left="399" dlg:top="129" dlg:width="28" dlg:height="16" dlg:help-text="Clear the list and resize the circular buffer" dlg:decimal-accuracy="0" dlg:value="20" dlg:value-min="5" dlg:value-max="999" dlg:spin="true"/> + <dlg:textfield dlg:style-id="0" dlg:id="txtTraceLog" dlg:tab-index="0" dlg:left="9" dlg:top="20" dlg:width="360" dlg:height="105" dlg:help-text="Text can be selected, copied, ..." dlg:hscroll="true" dlg:vscroll="true" dlg:multiline="true" dlg:readonly="true" dlg:value="--- Log file is empty ---"/> + <dlg:checkbox dlg:style-id="1" dlg:id="chkClear" dlg:tab-index="5" dlg:left="58" dlg:top="133" dlg:width="6" dlg:height="9" dlg:help-text="Clear the list" dlg:value="Clear" dlg:checked="false"/> + <dlg:button dlg:id="cmdCancel" dlg:tab-index="6" dlg:left="381" dlg:top="38" dlg:width="40" dlg:height="12" dlg:help-text="Cancel and close the dialog" dlg:value="Cancel" dlg:button-type="cancel"/> + <dlg:text dlg:id="lblClear" dlg:tab-index="7" dlg:left="9" dlg:top="133" dlg:width="46" dlg:height="9" dlg:help-text="Clear the list" dlg:value="Clear the list" dlg:align="right"/> + <dlg:text dlg:id="lblMinLevel" dlg:tab-index="8" dlg:left="74" dlg:top="133" dlg:width="130" dlg:height="9" dlg:help-text="Register only logging requests above given level" dlg:value="Set minimal trace level" dlg:align="right"/> + <dlg:combobox dlg:id="cboMinLevel" dlg:tab-index="9" dlg:left="209" dlg:top="133" dlg:width="50" dlg:height="9" dlg:help-text="Register only logging requests above given level" dlg:spin="true"> + <dlg:menupopup> + <dlg:menuitem dlg:value="DEBUG"/> + <dlg:menuitem dlg:value="INFO"/> + <dlg:menuitem dlg:value="WARNING"/> + <dlg:menuitem dlg:value="ERROR"/> + <dlg:menuitem dlg:value="ABORT"/> + </dlg:menupopup> + </dlg:combobox> + <dlg:button dlg:id="cmdOK" dlg:tab-index="1" dlg:left="381" dlg:top="20" dlg:width="40" dlg:height="12" dlg:help-text="Validate" dlg:default="true" dlg:value="OK" dlg:button-type="ok"/> + <dlg:button dlg:id="cmdDump" dlg:tab-index="2" dlg:left="381" dlg:top="68" dlg:width="40" dlg:height="31" dlg:help-text="Choose a file and dump the actual list content in it" dlg:value="Dump to file" dlg:multiline="true"> + <script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Access2Base.Trace._DumpToFile?language=Basic&location=application" script:language="Script"/> + </dlg:button> + <dlg:text dlg:id="lblNbEntries" dlg:tab-index="10" dlg:left="9" dlg:top="10" dlg:width="105" dlg:height="7" dlg:help-text="Actual size of list" dlg:value="Actual number of entries:"/> + <dlg:numericfield dlg:style-id="2" dlg:id="numNbEntries" dlg:tab-index="11" dlg:left="123" dlg:top="9" dlg:width="17" dlg:height="9" dlg:help-text="Actual size of list" dlg:readonly="true" dlg:decimal-accuracy="0" dlg:value="0"/> + </dlg:bulletinboard> +</dlg:window>
\ No newline at end of file diff --git a/wizards/source/access2base/script.xlb b/wizards/source/access2base/script.xlb new file mode 100644 index 000000000..478a061e8 --- /dev/null +++ b/wizards/source/access2base/script.xlb @@ -0,0 +1,34 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd"> +<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Access2Base" library:readonly="false" library:passwordprotected="false"> + <library:element library:name="Application"/> + <library:element library:name="Methods"/> + <library:element library:name="acConstants"/> + <library:element library:name="Test"/> + <library:element library:name="Trace"/> + <library:element library:name="DoCmd"/> + <library:element library:name="Utils"/> + <library:element library:name="Database"/> + <library:element library:name="PropertiesSet"/> + <library:element library:name="Collect"/> + <library:element library:name="PropertiesGet"/> + <library:element library:name="Form"/> + <library:element library:name="Python"/> + <library:element library:name="_License"/> + <library:element library:name="SubForm"/> + <library:element library:name="L10N"/> + <library:element library:name="OptionGroup"/> + <library:element library:name="Event"/> + <library:element library:name="Property"/> + <library:element library:name="Control"/> + <library:element library:name="Dialog"/> + <library:element library:name="Field"/> + <library:element library:name="DataDef"/> + <library:element library:name="Recordset"/> + <library:element library:name="TempVar"/> + <library:element library:name="Root_"/> + <library:element library:name="UtilProperty"/> + <library:element library:name="CommandBar"/> + <library:element library:name="CommandBarControl"/> + <library:element library:name="Module"/> +</library:library> |