1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662 |
- <?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.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#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.URIS_ONLY)
- End Sub ' _ShellExecute V0.8.5
- </script:module>
|