123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869 |
- <?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 Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function
- If pvDatabaseURL = "" Then Call _TraceArguments()
- 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>
|