diff options
Diffstat (limited to 'wizards/source/sfdocuments')
| -rw-r--r-- | wizards/source/sfdocuments/SF_Base.xba | 993 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_Calc.xba | 4501 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_Chart.xba | 814 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_Document.xba | 1504 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_DocumentListener.xba | 114 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_Form.xba | 1535 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_FormControl.xba | 1888 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_Register.xba | 546 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/SF_Writer.xba | 635 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/__License.xba | 26 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/dialog.xlb | 3 | ||||
| -rw-r--r-- | wizards/source/sfdocuments/script.xlb | 14 |
12 files changed, 12573 insertions, 0 deletions
diff --git a/wizards/source/sfdocuments/SF_Base.xba b/wizards/source/sfdocuments/SF_Base.xba new file mode 100644 index 000000000..1e6395dbf --- /dev/null +++ b/wizards/source/sfdocuments/SF_Base.xba @@ -0,0 +1,993 @@ +<?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="SF_Base" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Base +''' ======= +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' the management and several manipulations of LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the SF_Document module. +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Writer, ... +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties. +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The SF_Base module is provided mainly to block parent properties that are NOT applicable to Base documents +''' In addition, it provides methods to identify form documents and access their internal forms +''' (read more elsewhere (the "SFDocuments.Form" service) about this subject) +''' +''' The current module is closely related to the "UI" service of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.CreateBaseDocument("C:\Me\MyFile.odb", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.odb") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Base", "MyFile.odb") +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_base.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DBCONNECTERROR = "DBCONNECTERROR" +Private Const FORMDEADERROR = "FORMDEADERROR" +Private Const BASEFORMNOTFOUNDERROR = "BASEFORMNOTFOUNDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private [_Super] As Object ' Document superclass, which the current instance is a subclass of +Private ObjectType As String ' Must be BASE +Private ServiceName As String + +' UNO references +Private _Component As Object ' com.sun.star.comp.dba.ODatabaseDocument +Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource +Private _Database As Object ' SFDatabases.Database service instance +Private _FormDocuments As Object + +REM ============================================================ MODULE CONSTANTS + +Const ISBASEFORM = 3 ' Form is stored in a Base document +Const cstToken = "//" ' Form names accept special characters but not slashes + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + Set [_Super] = Nothing + ObjectType = "BASE" + ServiceName = "SFDocuments.Base" + Set _Component = Nothing + Set _DataSource = Nothing + Set _Database = Nothing + Set _FormDocuments = Nothing +End Sub ' SFDocuments.SF_Base Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Base Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Base Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean +''' The closure of a Base document requires the closures of +''' 1) the connection => done in the CloseDatabase() method +''' 2) the data source +''' 3) the document itself => done in the superclass + +Const cstThisSub = "SFDocuments.Base.CloseDocument" +Const cstSubArgs = "[SaveAsk=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(SaveAsk) Or IsEmpty(SaveAsk) Then SaveAsk = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SaveAsk, "SaveAsk", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + If Not IsNull(_Database) Then _Database.CloseDatabase() + If Not IsNull(_DataSource) Then _DataSource.dispose() + CloseDocument = [_Super].CloseDocument(SaveAsk) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CloseFormDocument(Optional ByVal FormDocument As Variant) As Boolean +''' Close the given form document +''' Nothing happens if the form document is not open +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Returns: +''' True if closure is successful +''' Example: +''' oDoc.CloseFormDocument("Folder1/myFormDocument") + +Dim bClose As Boolean ' Return value +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Dim vFormNames As Variant ' Array of all document form names present in the document + +Const cstThisSub = "SFDocuments.Base.CloseFormDocument" +Const cstSubArgs = "FormDocument" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo Finally + +Try: + Set oMainForm = _FormDocuments.getByHierarchicalName(FormDocument) + bClose = oMainForm.close() + +Finally: + CloseFormDocument = bClose + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.CloseFormDocument + +REM ----------------------------------------------------------------------------- +Public Function FormDocuments() As Variant +''' Return the list of the FormDocuments contained in the Base document +''' Args: +''' Returns: +''' A zero-base array of strings +''' Each entry is the full path name of a form document. The path separator is the slash ("/") +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.FormDocuments() + +Dim vFormNames As Variant ' Array of all form names present in the document +Const cstThisSub = "SFDocuments.Base.FormDocuments" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If + +Try: + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + +Finally: + FormDocuments = vFormNames + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.FormDocuments + +REM ----------------------------------------------------------------------------- +Public Function Forms(Optional ByVal FormDocument As Variant _ + , Optional ByVal Form As Variant _ + ) As Variant +''' Return either +''' - the list of the Forms contained in the form document +''' - a SFDocuments.Form object based on its name or its index +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Form: a form stored in the Base document given by its name or its index +''' When absent, the list of available forms is returned +''' To get the first (unique ?) form stored in the form document, set Form = 0 +''' Returns: +''' A zero-based array of strings if Form is absent +''' An instance of the SF_Form class if Form exists +''' Exceptions: +''' FORMDEADERROR The form is not open +''' BASEFORMNOTFOUNDERROR FormDocument OK but Form not found +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.Forms("Folder1/myFormDocument") +''' Set myForm = oDoc.Forms("Folder1/myFormDocument", 0) + +Dim oForm As Object ' The new Form class instance +Dim oFormDocument As Object ' com.sun.star.comp.sdb.Content +Dim oXForm As Object ' com.sun.star.form.XForm +Dim vFormDocuments As Variant ' Array of form documents +Dim vFormNames As Variant ' Array of form names +Dim oForms As Object ' Forms collection +Const cstDrawPage = 0 ' Only 1 drawpage in a Base document + +Const cstThisSub = "SFDocuments.Base.Forms" +Const cstSubArgs = "FormDocument, [Form=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Form) Or IsEmpty(Form) Then Form = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormDocuments = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormDocuments) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo CatchClosed + +Try: + ' Start from the form document and go down to forms + Set oFormDocument = _FormDocuments.getByHierarchicalName(FormDocument) + Set oForms = oFormDocument.Component.DrawPages(cstDrawPage).Forms + vFormNames = oForms.getElementNames() + + If Len(Form) = 0 Then ' Return the list of valid form names + Forms = vFormNames + Else + If VarType(Form) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Utils._Validate(Form, "Form", V_STRING, vFormNames) Then GoTo Finally + Set oXForm = oForms.getByName(Form) + Else ' Find the form by index + If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound + Set oXForm = oForms.getByIndex(Form) + End If + ' Create the new Form class instance + Set oForm = New SF_Form + With oForm + ._Name = oXForm.Name + Set .[Me] = oForm + Set .[_Parent] = [Me] + Set ._Component = _Component + ._FormDocumentName = FormDocument + Set ._FormDocument = oFormDocument + ._FormType = ISBASEFORM + Set ._Form = oXForm + ._Initialize() + End With + Set Forms = oForm + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchClosed: + ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, FormDocument, _FileIdent()) +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(BASEFORMNOTFOUNDERROR, Form, FormDocument, _FileIdent()) +End Function ' SFDocuments.SF_Base.Forms + +REM ----------------------------------------------------------------------------- +Public Function GetDatabase(Optional ByVal User As Variant _ + , Optional ByVal Password As Variant _ + ) As Object +''' Returns a Database instance (service = SFDatabases.Database) giving access +''' to the execution of SQL commands on the database defined and/or stored in +''' the actual Base document +''' Args: +''' User, Password: the login parameters as strings. Defaults = "" +''' Returns: +''' A SFDatabases.Database instance or Nothing +''' Example: +''' Dim myDb As Object +''' Set myDb = oDoc.GetDatabase() + +Const cstThisSub = "SFDocuments.Base.GetDatabase" +Const cstSubArgs = "[User=""""], [Password=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set GetDatabase = Nothing + +Check: + If IsMissing(User) Or IsEmpty(User) Then User = "" + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(User, "User", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + End If + +Try: + If IsNull(_Database) Then ' 1st connection from the current document instance + If IsNull(_DataSource) Then GoTo CatchConnect + Set _Database = ScriptForge.SF_Services.CreateScriptService("SFDatabases.DatabaseFromDocument" _ + , _DataSource, User, Password) + If IsNull(_Database) Then GoTo CatchConnect + _Database._Location = [_Super]._WindowFileName + EndIf + +Finally: + Set GetDatabase = _Database + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchConnect: + ScriptForge.SF_Exception.RaiseFatal(DBCONNECTERROR, "User", User, "Password", Password, [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Base.GetDatabase + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Base.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + ' Superclass or subclass property ? + If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then + GetProperty = [_Super].GetProperty(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function IsLoaded(Optional ByVal FormDocument As Variant) As Boolean +''' Return True if the given FormDocument is open for the user +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Returns: +''' True if the form document is currently open, otherwise False +''' Exceptions: +''' Form name is invalid +''' Example: +''' MsgBox oDoc.IsLoaded("Folder1/myFormDocument") + +Dim bLoaded As Boolean ' Return value +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Const cstThisSub = "SFDocuments.Base.IsLoaded" +Const cstSubArgs = "FormDocument" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bLoaded = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + End If + +Try: + Set oMainForm = _FormDocuments.getByHierarchicalName(FormDocument) + ' A document form that has never been opened has no component + ' If ever opened and closed afterwards, it keeps the Component but loses its Controller + bLoaded = Not IsNull(oMainForm.Component) + If bLoaded Then bLoaded = Not IsNull(oMainForm.Component.CurrentController) + +Finally: + IsLoaded = bLoaded + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.IsLoaded + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Base class as an array + + Methods = Array( _ + "CloseFormDocument" _ + , "FormDocuments" _ + , "Forms" _ + , "GetDatabase" _ + , "IsLoaded" _ + , "OpenFormDocument" _ + , "PrintOut" _ + , "SetPrinter" _ + ) + +End Function ' SFDocuments.SF_Base.Methods + +REM ----------------------------------------------------------------------------- +Public Function OpenFormDocument(Optional ByVal FormDocument As Variant _ + , Optional ByVal DesignMode As Variant _ + ) As Boolean +''' Open the FormDocument given by its hierarchical name either in normal or in design mode +''' If the form document is already open, the form document is made active without changing its mode +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' DesignMode: when True the form document is opened in design mode (Default = False) +''' Returns: +''' True if the form document could be opened, otherwise False +''' Exceptions: +''' Form name is invalid +''' Example: +''' oDoc.OpenFormDocument("Folder1/myFormDocument") + +Dim bOpen As Boolean ' Return value +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim oContainer As Object ' com.sun.star.awt.XWindow +Dim oNewForm As Object ' Output of loadComponent() +Const cstThisSub = "SFDocuments.Base.OpenFormDocument" +Const cstSubArgs = "FormDocument, [DesignMode=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bOpen = False + +Check: + If IsMissing(DesignMode) Or IsEmpty(DesignMode) Then DesignMode = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DesignMode, "DesignMode", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + With _Component.CurrentController + If Not .IsConnected Then .connect() + ' loadComponent activates the form when already loaded + Set oNewForm = .loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, FormDocument, DesignMode) + ' When user opened manually the form in design mode and closed it, the next execution in normal mode needs to be confirmed as below + With oNewForm.CurrentController + If .isFormDesignMode() <> DesignMode Then .setFormDesignMode(DesignMode) + End With + End With + bOpen = True + +Finally: + OpenFormDocument = bOpen + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.OpenFormDocument + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal FormDocument As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + ) As Boolean +''' Send the content of the given form document to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' The given form document must be open. It is activated by the method. +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' Exceptions: +''' FORMDEADERROR The form is not open +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("myForm", "1-4;10;15-18", Copies := 2) + +Dim bPrint As Boolean ' Return value +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim oFormDocument As Object ' com.sun.star.comp.sdb.Content + +Const cstThisSub = "SFDocuments.Base.PrintOut" +Const cstSubArgs = "FormDocument, [Pages=""""], [Copies=1]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo CatchClosed + +Try: + Set oFormDocument = _FormDocuments.getByHierarchicalName(FormDocument) + bPrint = [_Super].PrintOut(Pages, Copies, oFormDocument.Component) + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchClosed: + ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, FormDocument, _FileIdent()) +End Function ' SFDocuments.SF_Base.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Base class as an array + + Properties = Array( _ + "DocumentType" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw " _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "XComponent" _ + ) + +End Function ' SFDocuments.SF_Base.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal FormDocument As Variant _ + , Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + ) As Boolean +''' Define the printer options for a form document. The form document must be open. +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Printer: the name of the printer queue where to print to +''' When absent or space, the default printer is set +''' Orientation: either "PORTRAIT" or "LANDSCAPE". Left unchanged when absent +''' PaperFormat: one of next values +''' "A3", "A4", "A5", "B4", "B5", "LETTER", "LEGAL", "TABLOID" +''' Left unchanged when absent +''' Returns: +''' True when successful +''' Examples: +''' oDoc.SetPrinter("myForm", Orientation := "PORTRAIT") + +Dim bPrinter As Boolean ' Return value +Dim vFormDocuments As Variant ' Array of form documents +Dim oFormDocument As Object ' com.sun.star.comp.sdb.Content + +Const cstThisSub = "SFDocuments.Base.SetPrinter" +Const cstSubArgs = "FormDocument, [Printer=""""], [Orientation=""PORTRAIT""|""LANDSCAPE""]" _ + & ", [PaperFormat=""A3""|""A4""|""A5""|""B4""|""B5""|""LETTER""|""LEGAL""|""TABLOID""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrinter = False + +Check: + If IsMissing(Printer) Or IsEmpty(Printer) Then Printer = "" + If IsMissing(Orientation) Or IsEmpty(Orientation) Then Orientation = "" + If IsMissing(PaperFormat) Or IsEmpty(PaperFormat) Then PaperFormat = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormDocuments = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormDocuments) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo CatchClosed + +Try: + Set oFormDocument = _FormDocuments.getByHierarchicalName(FormDocument) + bPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat, oFormDocument.Component) + +Finally: + SetPrinter = bPrinter + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchClosed: + ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, FormDocument, _FileIdent()) +End Function ' SFDocuments.SF_Base.SetPrinter + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Base.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.SetProperty + +REM ======================================================= SUPERCLASS PROPERTIES + +REM ----------------------------------------------------------------------------- +'Property Get CustomProperties() As Variant +' CustomProperties = [_Super].GetProperty("CustomProperties") +'End Property ' SFDocuments.SF_Base.CustomProperties + +REM ----------------------------------------------------------------------------- +'Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) +' [_Super].CustomProperties = pvCustomProperties +'End Property ' SFDocuments.SF_Base.CustomProperties + +REM ----------------------------------------------------------------------------- +'Property Get Description() As Variant +' Description = [_Super].GetProperty("Description") +'End Property ' SFDocuments.SF_Base.Description + +REM ----------------------------------------------------------------------------- +'Property Let Description(Optional ByVal pvDescription As Variant) +' [_Super].Description = pvDescription +'End Property ' SFDocuments.SF_Base.Description + +REM ----------------------------------------------------------------------------- +'Property Get DocumentProperties() As Variant +' DocumentProperties = [_Super].GetProperty("DocumentProperties") +'End Property ' SFDocuments.SF_Base.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String + DocumentType = [_Super].GetProperty("DocumentType") +End Property ' SFDocuments.SF_Base.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = [_Super].GetProperty("IsBase") +End Property ' SFDocuments.SF_Base.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = [_Super].GetProperty("IsCalc") +End Property ' SFDocuments.SF_Base.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = [_Super].GetProperty("IsDraw") +End Property ' SFDocuments.SF_Base.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = [_Super].GetProperty("IsImpress") +End Property ' SFDocuments.SF_Base.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = [_Super].GetProperty("IsMath") +End Property ' SFDocuments.SF_Base.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = [_Super].GetProperty("IsWriter") +End Property ' SFDocuments.SF_Base.IsWriter + +REM ----------------------------------------------------------------------------- +'Property Get Keywords() As Variant +' Keywords = [_Super].GetProperty("Keywords") +'End Property ' SFDocuments.SF_Base.Keywords + +REM ----------------------------------------------------------------------------- +'Property Let Keywords(Optional ByVal pvKeywords As Variant) +' [_Super].Keywords = pvKeywords +'End Property ' SFDocuments.SF_Base.Keywords + +REM ----------------------------------------------------------------------------- +'Property Get Readonly() As Variant +' Readonly = [_Super].GetProperty("Readonly") +'End Property ' SFDocuments.SF_Base.Readonly + +REM ----------------------------------------------------------------------------- +'Property Get Subject() As Variant +' Subject = [_Super].GetProperty("Subject") +'End Property ' SFDocuments.SF_Base.Subject + +REM ----------------------------------------------------------------------------- +'Property Let Subject(Optional ByVal pvSubject As Variant) +' [_Super].Subject = pvSubject +'End Property ' SFDocuments.SF_Base.Subject + +REM ----------------------------------------------------------------------------- +'Property Get Title() As Variant +' Title = [_Super].GetProperty("Title") +'End Property ' SFDocuments.SF_Base.Title + +REM ----------------------------------------------------------------------------- +'Property Let Title(Optional ByVal pvTitle As Variant) +' [_Super].Title = pvTitle +'End Property ' SFDocuments.SF_Base.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant + XComponent = [_Super].GetProperty("XComponent") +End Property ' SFDocuments.SF_Base.XComponent + +REM ========================================================== SUPERCLASS METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean + Activate = [_Super].Activate() +End Function ' SFDocuments.SF_Base.Activate + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object + Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) +End Function ' SFDocuments.SF_Base.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean + RemoveMenu = [_Super].RemoveMenu(MenuHeader) +End Function ' SFDocuments.SF_Base.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) + [_Super].RunCommand(Command, Args) +End Sub ' SFDocuments.SF_Base.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean + Save = [_Super].Save() +End Function ' SFDocuments.SF_Base.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Base.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Base.SaveCopyAs + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _CollectFormDocuments(ByRef poContainer As Object) As String +''' Returns a token-separated string of all hierarchical formdocument names +''' depending on the formdocuments container in argument +''' The function traverses recursively the whole tree below the container +''' The initial call starts from the container _Component.getFormDocuments +''' The list contains closed and open forms + +Dim sCollectNames As String ' Return value +Dim oSubItem As Object ' com.sun.star.container.XNameAccess (folder) or com.sun.star.ucb.XContent (form) +Dim i As Long +Const cstFormType = "application/vnd.oasis.opendocument.text" + ' Identifies forms. Folders have a zero-length content type + + On Local Error GoTo Finally + +Try: + sCollectNames = "" + With poContainer + For i = 0 To .Count - 1 + Set oSubItem = .getByIndex(i) + If oSubItem.ContentType = cstFormType Then ' Add the form to the list + sCollectNames = sCollectNames & cstToken & oSubItem.HierarchicalName + Else + sCollectNames = sCollectNames & cstToken & _CollectFormDocuments(oSubItem) + End If + Next i + End With + +Finally: + _CollectFormDocuments = Mid(sCollectNames, Len(cstToken) + 1) ' Skip the initial token + Exit Function +End Function ' SFDocuments.SF_Base._CollectFormDocuments + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Base._FileIdent + +REM ----------------------------------------------------------------------------- +Private Function _FindByPersistentName(ByRef poContainer As Object _ + , psPersistent As String _ + ) As Object +''' The FormDocuments property of a Base component has strangely +''' a getByHierarchical() method but no access to the same com.sun.star.comp.sdb.Content +''' object via its persistent/ODF name +''' This method returns the object having the given persistent name +''' The function traverses recursively the whole tree below the container until found +''' The initial call starts from the container _Component.getFormDocuments +''' The list contains closed and open forms +''' Args: +''' poContainer: the actual top of the free, initially _FormDocuments +''' psPersistent: a name like "Obj..." +''' Returns: +''' A com.sun.star.comp.sdb.Content object (object found, the process stops) +''' or Nothing (object not found, the process continues) + +Dim oMainForm As Object ' Return value +Dim oSubItem As Object ' com.sun.star.container.XNameAccess (folder) or com.sun.star.ucb.XContent (form) +Dim i As Long +Const cstFormType = "application/vnd.oasis.opendocument.text" + ' Identifies forms. Folders have a zero-length content type + + On Local Error GoTo Finally + +Try: + Set oMainForm = Nothing + With poContainer + For i = 0 To .Count - 1 + Set oSubItem = .getByIndex(i) + If oSubItem.ContentType = cstFormType Then ' Examine its persistent name + If oSubItem.PersistentName = psPersistent Then + Set oMainForm = oSubItem + Exit For + End If + Else + Set oMainForm = _FindByPersistentName(oSubItem, psPersistent) + End If + Next i + End With + +Finally: + Set _FindByPersistentName = oMainForm + Exit Function +End Function ' SFDocuments.SF_Base.FindByPersistentName + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) + +Finally: + _IsStillAlive = bAlive + Exit Function +End Function ' SFDocuments.SF_Base._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvArg As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim oProperties As Object ' Document or Custom properties +Dim vLastCell As Variant ' Coordinates of last used cell in a sheet +Dim oSelect As Object ' Current selection +Dim vRanges As Variant ' List of selected ranges +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + cstThisSub = "SFDocuments.SF_Base.get" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case psProperty + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Base._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Base instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Base]: Type/File" + + _Repr = "[Base]: " & [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Base._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_BASE +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Calc.xba b/wizards/source/sfdocuments/SF_Calc.xba new file mode 100644 index 000000000..0b7b88ae8 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Calc.xba @@ -0,0 +1,4501 @@ +<?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="SF_Calc" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Calc +''' ======= +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' managing and manipulating LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the SF_Document module. +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ... +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties. +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The SF_Calc module is focused on : +''' - management (copy, insert, move, ...) of sheets within a Calc document +''' - exchange of data between Basic data structures and Calc ranges of values +''' +''' The current module is closely related to the "UI" service of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.CreateDocument("Calc", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.ods") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Default = ActiveWindow +''' ' or Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Untitled 1 is presumed a Calc document +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Definitions: +''' Many methods require a "Sheet" or a "Range" as argument. (NB: a single cell is considered as a special case of a Range) +''' Usually, within a specific Calc instance, sheets and ranges are given as a string: "SheetX" and "D2:F6" +''' Multiple ranges are not supported in this context. +''' Additionally, the .Sheet and .Range methods return a reference that may be used +''' as argument of a method called from another instance of the Calc service +''' Example: +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\FileB.ods") +''' oDocB.CopyToRange(oDocA.Range("SheetX.D4:F8"), "D2:F6") ' CopyToRange(source, target) +''' +''' Sheet: the sheet name as a string or an object produced by .Sheet() +''' "~" = current sheet +''' Range: a string designating a set of contiguous cells located in a sheet of the current instance +''' "~" = current selection (if multiple selections, its 1st component) +''' or an object produced by .Range() +''' The sheet name is optional (default = active sheet). Surrounding quotes and $ signs are optional +''' ~.~, ~ The current selection in the active sheet +''' '$SheetX'.D2 or $D$2 A single cell +''' '$SheetX'.D2:F6, D2:D10 Multiple cells +''' '$SheetX'.A:A or 3:5 All cells in the same column or row up to the last active cell +''' SheetX.* All cells up to the last active cell +''' myRange A range name at spreadsheet level +''' ~.yourRange, SheetX.someRange A range name at sheet level +''' myDoc.Range("SheetX.D2:F6") +''' A range within the sheet SheetX in file associated with the myDoc Calc instance +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_calc.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" +Private Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR" +Private Const CALCADDRESSERROR = "CALCADDRESSERROR" +Private Const DUPLICATESHEETERROR = "DUPLICATESHEETERROR" +Private Const OFFSETADDRESSERROR = "OFFSETADDRESSERROR" +Private Const CALCFORMNOTFOUNDERROR = "CALCFORMNOTFOUNDERROR" +Private Const DUPLICATECHARTERROR = "DUPLICATECHARTERROR" +Private Const RANGEEXPORTERROR = "RANGEEXPORTERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Super] As Object ' Document superclass, which the current instance is a subclass of +Private ObjectType As String ' Must be CALC +Private ServiceName As String + +' Window component +Private _Component As Object ' com.sun.star.lang.XComponent + +Type _Address + ObjectType As String ' Must be "SF_CalcReference" + ServiceName As String ' Must be "SFDocuments.CalcReference" + RawAddress As String + Component As Object ' com.sun.star.lang.XComponent + SheetName As String + SheetIndex As Integer + RangeName As String + Height As Long + Width As Long + XSpreadSheet As Object ' com.sun.star.sheet.XSpreadsheet + XCellRange As Object ' com.sun.star.table.XCellRange +End Type + +Private _LastParsedAddress As Object ' _Address type - parsed ranges are cached + +REM ============================================================ MODULE CONSTANTS + +Private Const cstSHEET = 1 +Private Const cstRANGE = 2 + +Private Const MAXCOLS = 2^10 ' Max number of columns in a sheet +Private Const MAXROWS = 2^20 ' Max number of rows in a sheet + +Private Const CALCREFERENCE = "SF_CalcReference" ' Object type of _Address +Private Const SERVICEREFERENCE = "SFDocuments.CalcReference" + ' Service name of _Address (used in Python) + +Private Const ISCALCFORM = 2 ' Form is stored in a Calc document + +Private Const cstSPECIALCHARS = " `~!@#$%^&()-_=+{}|;:,<.>""" + ' Presence of a special character forces surrounding the sheet name with single quotes in absolute addresses + + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Super] = Nothing + ObjectType = "CALC" + ServiceName = "SFDocuments.Calc" + Set _Component = Nothing + Set _LastParsedAddress = Nothing +End Sub ' SFDocuments.SF_Calc Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Calc Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Calc Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CurrentSelection() As Variant +''' Returns as a string the currently selected range or as an array the list of the currently selected ranges + CurrentSelection = _PropertyGet("CurrentSelection") +End Property ' SFDocuments.SF_Calc.CurrentSelection (get) + +REM ----------------------------------------------------------------------------- +Property Let CurrentSelection(Optional ByVal pvSelection As Variant) +''' Set the selection to a single or a multiple range +''' The argument is a string or an array of strings + +Dim sRange As String ' A single selection +Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges +Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress +Dim i As Long +Const cstThisSub = "SFDocuments.Calc.setCurrentSelection" +Const cstSubArgs = "Selection" + + On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If IsArray(pvSelection) Then + If Not ScriptForge.SF_Utils._ValidateArray(pvSelection, "pvSelection", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(pvSelection, "pvSelection", V_STRING) Then GoTo Finally + End If + End If + +Try: + If IsArray(pvSelection) Then + Set oCellRanges = _Component.createInstance("com.sun.star.sheet.SheetCellRanges") + vRangeAddresses = Array() + ReDim vRangeAddresses(0 To UBound(pvSelection)) + For i = 0 To UBound(pvSelection) + vRangeAddresses(i) = Range(pvSelection(i)).XCellRange.RangeAddress + Next i + oCellRanges.addRangeAddresses(vRangeAddresses, False) + _Component.CurrentController.select(oCellRanges) + Else + _Component.CurrentController.select(_ParseAddress(pvSelection).XCellRange) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +Catch: + GoTo Finally +End Property ' SFDocuments.SF_Calc.CurrentSelection (let) + +REM ----------------------------------------------------------------------------- +Property Get FirstCell(Optional ByVal RangeName As Variant) As String +''' Returns the First used cell in a given range or sheet +''' When the argument is a sheet it will always return the "sheet.$A$1" cell + FirstCell = _PropertyGet("FirstCell", RangeName) +End Property ' SFDocuments.SF_Calc.FirstCell + +REM ----------------------------------------------------------------------------- +Property Get FirstColumn(Optional ByVal RangeName As Variant) As Long +''' Returns the leftmost column in a given sheet or range +''' When the argument is a sheet it will always return 1 + FirstColumn = _PropertyGet("FirstColumn", RangeName) +End Property ' SFDocuments.SF_Calc.FirstColumn + +REM ----------------------------------------------------------------------------- +Property Get FirstRow(Optional ByVal RangeName As Variant) As Long +''' Returns the First used column in a given range +''' When the argument is a sheet it will always return 1 + FirstRow = _PropertyGet("FirstRow", RangeName) +End Property ' SFDocuments.SF_Calc.FirstRow + +REM ----------------------------------------------------------------------------- +Property Get Height(Optional ByVal RangeName As Variant) As Long +''' Returns the height in # of rows of the given range + Height = _PropertyGet("Height", RangeName) +End Property ' SFDocuments.SF_Calc.Height + +REM ----------------------------------------------------------------------------- +Property Get LastCell(Optional ByVal RangeName As Variant) As String +''' Returns the last used cell in a given sheet or range + LastCell = _PropertyGet("LastCell", RangeName) +End Property ' SFDocuments.SF_Calc.LastCell + +REM ----------------------------------------------------------------------------- +Property Get LastColumn(Optional ByVal RangeName As Variant) As Long +''' Returns the last used column in a given sheet + LastColumn = _PropertyGet("LastColumn", RangeName) +End Property ' SFDocuments.SF_Calc.LastColumn + +REM ----------------------------------------------------------------------------- +Property Get LastRow(Optional ByVal RangeName As Variant) As Long +''' Returns the last used column in a given sheet + LastRow = _PropertyGet("LastRow", RangeName) +End Property ' SFDocuments.SF_Calc.LastRow + +REM ----------------------------------------------------------------------------- +Property Get Range(Optional ByVal RangeName As Variant) As Variant +''' Returns a (internal) range object + Range = _PropertyGet("Range", RangeName) +End Property ' SFDocuments.SF_Calc.Range + +REM ----------------------------------------------------------------------------- +Property Get Region(Optional ByVal RangeName As Variant) As String +''' Returns the smallest area as a range string that contains the given range +''' and which is completely surrounded with empty cells + Region = _PropertyGet("Region", RangeName) +End Property ' SFDocuments.SF_Calc.Region + +REM ----------------------------------------------------------------------------- +Property Get Sheet(Optional ByVal SheetName As Variant) As Variant +''' Returns a (internal) sheet object + Sheet = _PropertyGet("Sheet", SheetName) +End Property ' SFDocuments.SF_Calc.Sheet + +REM ----------------------------------------------------------------------------- +Property Get SheetName(Optional ByVal RangeName As Variant) As String +''' Returns the sheet name part of a range + SheetName = _PropertyGet("SheetName", RangeName) +End Property ' SFDocuments.SF_Calc.SheetName + +REM ----------------------------------------------------------------------------- +Property Get Sheets() As Variant +''' Returns an array listing the existing sheet names + Sheets = _PropertyGet("Sheets") +End Property ' SFDocuments.SF_Calc.Sheets + +REM ----------------------------------------------------------------------------- +Property Get Width(Optional ByVal RangeName As Variant) As Long +''' Returns the width in # of columns of the given range + Width = _PropertyGet("Width", RangeName) +End Property ' SFDocuments.SF_Calc.Width + +REM ----------------------------------------------------------------------------- +Property Get XCellRange(Optional ByVal RangeName As Variant) As Variant +''' Returns a UNO object of type com.sun.star.Table.CellRange + XCellRange = _PropertyGet("XCellRange", RangeName) +End Property ' SFDocuments.SF_Calc.XCellRange + +REM ----------------------------------------------------------------------------- +Property Get XSheetCellCursor(Optional ByVal RangeName As Variant) As Variant +''' Returns a UNO object of type com.sun.star.sheet.XSheetCellCursor +'' After having moved the cursor (gotoNext(), ...) the resulting range can be got +''' back as a string with the cursor.AbsoluteName UNO property. + XSheetCellCursor = _PropertyGet("XSheetCellCursor", RangeName) +End Property ' SFDocuments.SF_Calc.XSheetCellCursor + +REM ----------------------------------------------------------------------------- +Property Get XSpreadsheet(Optional ByVal SheetName As Variant) As Variant +''' Returns a UNO object of type com.sun.star.sheet.XSpreadsheet + XSpreadsheet = _PropertyGet("XSpreadsheet", SheetName) +End Property ' SFDocuments.SF_Calc.XSpreadsheet + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function A1Style(Optional ByVal Row1 As Variant _ + , Optional ByVal Column1 As Variant _ + , Optional ByVal Row2 As Variant _ + , Optional ByVal Column2 As Variant _ + , Optional ByVal SheetName As Variant _ + ) As String +''' Returns a range expressed in A1-style as defined by its coordinates +''' If only one pair of coordinates is given, the range will embrace only a single cell +''' Args: +''' Row1 : the row number of the first coordinate +''' Column1 : the column number of the first coordinates +''' Row2 : the row number of the second coordinate +''' Column2 : the column number of the second coordinates +''' SheetName: Default = the current sheet. If present, the sheet must exist. +''' Returns: +''' A range as a string +''' Exceptions: +''' Examples: +''' range = oDoc.A1Style(5, 2, 10, 4, "SheetX") ' "'$SheetX'.$E$2:$J$4" + +Dim sA1Style As String ' Return value +Dim vSheetName As Variant ' Alias of SheetName - necessary see [Bug 145279] +Dim lTemp As Long ' To switch 2 values +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.A1Style" +Const cstSubArgs = "Row1, Column1, [Row2], [Column2], [SheetName]=""""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sA1Style = "" + +Check: + If IsMissing(Row2) Or IsEmpty(Row2) Then Row2 = 0 + If IsMissing(Column2) Or IsEmpty(Column2) Then Column2 = 0 + If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "~" + vSheetName = SheetName + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Row1, "Row1", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Column1, "Column1", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Row2, "Row2", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Column2, "Column2", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not _ValidateSheet(vSheetName, "SheetName", , True, True, , , True) Then GoTo Finally + End If + + If Row1 > MAXROWS Then Row1 = MAXROWS + If Row2 > MAXROWS Then Row2 = MAXROWS + If Column1 > MAXCOLS Then Column1 = MAXCOLS + If Column2 > MAXCOLS Then Column2 = MAXCOLS + + If Row2 > 0 And Row2 < Row1 Then + lTemp = Row2 : Row2 = Row1 : Row1 = lTemp + End If + If Column2 > 0 And Column2 < Column1 Then + lTemp = Column2 : Column2 = Column1 : Column1 = lTemp + End If + +Try: + ' Surround the sheet name with single quotes when required by the presence of special characters + vSheetName = _QuoteSheetName(vSheetName) + ' Define the new range string + sA1Style = "$" & vSheetName & "." _ + & "$" & _GetColumnName(Column1) & "$" & CLng(Row1) _ + & Iif(Row2 > 0 And Column2 > 0, ":$" & _GetColumnName(Column2) & "$" & CLng(Row2), "") + +Finally: + A1Style = sA1Style + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.A1Style + +REM ----------------------------------------------------------------------------- +Public Function Activate(Optional ByVal SheetName As Variant) As Boolean +''' Make the current document or the given sheet active +''' Args: +''' SheetName: Default = the Calc document as a whole +''' Returns: +''' True if the document or the sheet could be made active +''' Otherwise, there is no change in the actual user interface +''' Examples: +''' oDoc.Activate("SheetX") + +Dim bActive As Boolean ' Return value +Dim oSheet As Object ' Reference to sheet +Const cstThisSub = "SFDocuments.Calc.Activate" +Const cstSubArgs = "[SheetName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActive = False + +Check: + If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , , True) Then GoTo Finally + End If + +Try: + ' Sheet activation, to do only when meaningful, precedes document activation + If Len(SheetName) > 0 Then + With _Component + Set oSheet = .getSheets.getByName(SheetName) + Set .CurrentController.ActiveSheet = oSheet + End With + End If + bActive = [_Super].Activate() + +Finally: + Activate = bActive + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.Activate + +REM ----------------------------------------------------------------------------- +Public Function Charts(Optional ByVal SheetName As Variant _ + , Optional ByVal ChartName As Variant _ + ) As Variant +''' Return either the list of charts present in the given sheet or a chart object +''' Args: +''' SheetName: The name of an existing sheet +''' ChartName: The user-defined name of the targeted chart or the zero-length string +''' Returns: +''' When ChartName = "", return the list of the charts present in the sheet, +''' otherwise, return a new chart service instance +''' Examples: +''' Dim oChart As Object +''' Set oChart = oDoc.Charts("SheetX", "myChart") + +Dim vCharts As Variant ' Return value when array of chart names +Dim oChart As Object ' Return value when new chart instance +Dim oSheet As Object ' Alias of SheetName as reference +Dim oDrawPage As Object ' com.sun.star.drawing.XDrawPage +Dim oNextShape As Object ' com.sun.star.drawing.XShape +Dim sChartName As String ' Some chart name +Dim lCount As Long ' Counter for charts among all drawing objects +Dim i As Long +Const cstChartShape = "com.sun.star.drawing.OLE2Shape" + +Const cstThisSub = "SFDocuments.Calc.Charts" +Const cstSubArgs = "SheetName, [ChartName=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vCharts = Array() + +Check: + If IsMissing(ChartName) Or IsEmpty(ChartName) Then ChartName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally + End If + +Try: + ' Because the user can change it constantly, the list of valid charts has to be rebuilt at each time + ' Explore charts starting from the draw page + Set oSheet = _Component.getSheets.getByName(SheetName) + Set oDrawPage = oSheet.getDrawPage() + vCharts = Array() + Set oChart = Nothing + lCount = -1 + For i = 0 To oDrawPage.Count - 1 + Set oNextShape = oDrawPage.getByIndex(i) + if oNextShape.supportsService(cstChartShape) Then ' Ignore other shapes + sChartName = oNextShape.Name ' User-defined name + If Len(sChartName) = 0 Then sChartName = oNextShape.PersistName ' Internal name + ' Is chart found ? + If Len(ChartName) > 0 Then + If ChartName = sChartName Then + Set oChart = New SF_Chart + With oChart + Set .[Me] = oChart + Set .[_Parent] = [Me] + ._SheetName = SheetName + ._DrawIndex = i + ._ChartName = ChartName + ._PersistentName = oNextShape.PersistName + Set ._Shape = oNextShape + Set ._Chart = oSheet.getCharts().getByName(._PersistentName) + Set ._ChartObject = ._Chart.EmbeddedObject + Set ._Diagram = ._ChartObject.Diagram + End With + Exit For + End If + End If + ' Build stack of chart names + lCount = lCount + 1 + If UBound(vCharts) < 0 Then + vCharts = Array(sChartName) + Else + ReDim Preserve vCharts(0 To UBound(vCharts) + 1) + vCharts(lCount) = sChartName + End If + End If + Next i + + ' Raise error when chart not found + If Len(ChartName) > 0 And IsNull(oChart) Then + If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING, vCharts) Then GoTo Finally + End If + +Finally: + If Len(ChartName) = 0 Then Charts = vCharts Else Set Charts = oChart + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.Charts + +REM ----------------------------------------------------------------------------- +Public Sub ClearAll(Optional ByVal Range As Variant) As String +''' Clear entirely the given range +''' Args: +''' Range : the cell or the range as a string that should be cleared +''' Examples: +''' oDoc.ClearAll("SheetX") ' Clears the used area of the sheet + +Dim lClear As Long ' The elements to clear +Dim oRange As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.ClearAll" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + With com.sun.star.sheet.CellFlags + lClear = 0 _ + + .VALUE _ + + .DATETIME _ + + .STRING _ + + .ANNOTATION _ + + .FORMULA _ + + .HARDATTR _ + + .STYLES _ + + .OBJECTS _ + + .EDITATTR _ + + .FORMATTED + Set oRange = _ParseAddress(Range) + oRange.XCellRange.clearContents(lClear) + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SF_Documents.SF_Calc.ClearAll + +REM ----------------------------------------------------------------------------- +Public Sub ClearFormats(Optional ByVal Range As Variant) As String +''' Clear all the formatting elements of the given range +''' Args: +''' Range : the cell or the range as a string that should be cleared +''' Examples: +''' oDoc.ClearFormats("SheetX:A1:E100") ' Clear the formats of the given range + +Dim lClear As Long ' The elements to clear +Dim oRange As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.ClearFormats" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + With com.sun.star.sheet.CellFlags + lClear = 0 _ + + .HARDATTR _ + + .STYLES _ + + .EDITATTR _ + + .FORMATTED + Set oRange = _ParseAddress(Range) + oRange.XCellRange.clearContents(lClear) + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SF_Documents.SF_Calc.ClearFormats + +REM ----------------------------------------------------------------------------- +Public Sub ClearValues(Optional ByVal Range As Variant) As String +''' Clear values and formulas in the given range +''' Args: +''' Range : the cell or the range as a string that should be cleared +''' Examples: +''' oDoc.ClearValues("SheetX:*") ' Clears the used area of the sheet + +Dim lClear As Long ' The elements to clear +Dim oRange As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.ClearValues" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + With com.sun.star.sheet.CellFlags + lClear = 0 _ + + .VALUE _ + + .DATETIME _ + + .STRING _ + + .FORMULA + Set oRange = _ParseAddress(Range) + oRange.XCellRange.clearContents(lClear) + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SF_Documents.SF_Calc.ClearValues + +REM ----------------------------------------------------------------------------- +Public Function CompactLeft(Optional ByVal Range As Variant _ + , Optional ByVal WholeColumn As Variant _ + , Optional ByVal FilterFormula As Variant _ + ) As String +''' Delete the columns of a specified range matching a filter expressed as a formula +''' applied on each column. +''' The deleted cells can span whole columns or be limited to the height of the range +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeColumn: when True (default = False), erase whole columns +''' FilterFormula: the formula to be applied on each column. +''' The column is erased when the formula results in True, +''' The formula shall probably involve one or more cells of the first column of the range.. +''' By default, a column is erased when all the cells of the column are empty, +''' i.e. suppose the range is "A1:J200" (height = 0) the default value becomes +''' "=(COUNTBLANK(A1:A200)=200)" +''' Returns: +''' A string representing the location of the initial range after compaction, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.CompactLeft("SheetX.G1:L10") ' All empty columns of the range are suppressed +''' newrange = oDoc.CompactLeft("SheetX.G1:L10", WholeColumn := True, FilterFormula := "=(G$7=""X"")") +''' ' The columns having a "X" in row 7 are completely suppressed + +Dim sCompact As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lLastRow As Long ' Last used row number in the sheet containing Range +Dim sFormulaRange As String ' Range, as a string, where the FilterFormula must be stored +Dim vCompact As Variant ' Array of Boolean values indicating which columns should be erased +Dim lCountDeleted As Long ' Count the deleted columns +Dim lCountToDelete As Long ' Count contiguous columns to be deleted at once +Dim sPartialRange As String ' Contiguous columns to be deleted +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.CompactLeft" +Const cstSubArgs = "Range, [WholeColumn=False], [FilterFormula=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCompact = "" + +Check: + If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False + If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Set the default formula => all cells are blank + If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C1%R2)-" & .Height & "=0)", Range) + ' Compute the range where to apply the formula + lLastRow = LastRow(.SheetName) + sFormulaRange = Offset(Range, lLastRow - .XCellRange.RangeAddress.StartColumn + 1, , 1) + SetFormula(sFormulaRange, FilterFormula) + ' Get the columns to compact: 0 = False, 1 = True + vCompact = GetValue(sFormulaRange) + If Not IsArray(vCompact) Then vCompact = Array(vCompact) + ClearAll(sFormulaRange) + + ' Iterates from the last to the first column of the range and remove the columns that match the filter + ' by groups of contiguous columns + lCountDeleted = 0 + lCountToDelete = 0 + For i = UBound(vCompact) To 0 Step -1 + If vCompact(i) = 1 Then lCountToDelete = lCountToDelete + 1 + If i > 0 And vCompact(i) = 1 Then + ' Do nothing + ElseIf lCountToDelete > 0 Then ' The current column must be kept but columns at the left must be removed + ' Do not forget when the 1st column must be removed + sPartialRange = Offset(Range, , Iif(i = 0 And vCompact(i) = 1, 0, i + 1), , lCountToDelete) + ShiftLeft(sPartialRange, WholeColumn) + lCountDeleted = lCountDeleted + lCountToDelete + lCountToDelete = 0 + End If + Next i + + ' Compute the final range position + If lCountDeleted < .Width Then sCompact = Offset(Range, 0, 0, , .Width - lCountDeleted) + + ' Push rightwards the cells that migrated leftwards irrelevantly + If Not WholeColumn Then + If Len(sCompact) > 0 Then + sPartialRange = Offset(sCompact, 0, .Width - lCountDeleted, , lCountDeleted) + Else + sPartialRange = .RangeName + End If + ShiftRight(sPartialRange, WholeColumn := False) + End If + + End With + +Finally: + CompactLeft = sCompact + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.CompactLeft + +REM ----------------------------------------------------------------------------- +Public Function CompactUp(Optional ByVal Range As Variant _ + , Optional ByVal WholeRow As Variant _ + , Optional ByVal FilterFormula As Variant _ + ) As String +''' Delete the rows of a specified range matching a filter expressed as a formula +''' applied on each row. +''' The deleted cells can span whole rows or be limited to the width of the range +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeRow: when True (default = False), erase whole rows +''' FilterFormula: the formula to be applied on each row. +''' The row is erased when the formula results in True, +''' The formula shall probably involve one or more cells of the first row of the range.. +''' By default, a row is erased when all the cells of the row are empty, +''' i.e. suppose the range is "A1:J200" (width = 10) the default value becomes +''' "=(COUNTBLANK(A1:J1)=10)" +''' Returns: +''' A string representing the location of the initial range after compaction, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.CompactUp("SheetX.G1:L10") ' All empty rows of the range are suppressed +''' newrange = oDoc.CompactUp("SheetX.G1:L10", WholeRow := True, FilterFormula := "=(G1=""X"")") +''' ' The rows having a "X" in column G are completely suppressed + +Dim sCompact As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lLastCol As Long ' Last used column number in the sheet containing Range +Dim sFormulaRange As String ' Range, as a string, where the FilterFormula must be stored +Dim vCompact As Variant ' Array of Boolean values indicating which rows should be erased +Dim lCountDeleted As Long ' Count the deleted rows +Dim lCountToDelete As Long ' Count contiguous rows to be deleted at once +Dim sPartialRange As String ' Contiguous rows to be deleted +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.CompactUp" +Const cstSubArgs = "Range, [WholeRow=False], [FilterFormula=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCompact = "" + +Check: + If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False + If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Set the default formula => all cells are blank + If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C2%R1)-" & .Width & "=0)", Range) + ' Compute the range where to apply the formula + lLastCol = LastColumn(.SheetName) + sFormulaRange = Offset(Range, , lLastCol - .XCellRange.RangeAddress.StartRow + 1, , 1) + SetFormula(sFormulaRange, FilterFormula) + ' Get the rows to compact: 0 = False, 1 = True + vCompact = GetValue(sFormulaRange) + If Not IsArray(vCompact) Then vCompact = Array(vCompact) + ClearAll(sFormulaRange) + + ' Iterates from the last to the first row of the range and remove the rows that match the filter + ' by groups of contiguous rows + lCountDeleted = 0 + lCountToDelete = 0 + For i = UBound(vCompact) To 0 Step -1 + If vCompact(i) = 1 Then lCountToDelete = lCountToDelete + 1 + If i > 0 And vCompact(i) = 1 Then + ' Do nothing + ElseIf lCountToDelete > 0 Then ' The current row must be kept but rows below must be removed + ' Do not forget when the 1st row must be removed + sPartialRange = Offset(Range, Iif(i = 0 And vCompact(i) = 1, 0, i + 1), , lCountToDelete) + ShiftUp(sPartialRange, WholeRow) + lCountDeleted = lCountDeleted + lCountToDelete + lCountToDelete = 0 + End If + Next i + + ' Compute the final range position + If lCountDeleted < .Height Then sCompact = Offset(Range, 0, 0, .Height - lCountDeleted) + + ' Push downwards the cells that migrated upwards irrelevantly + If Not WholeRow Then + If Len(sCompact) > 0 Then + sPartialRange = Offset(sCompact, .Height - lCountDeleted, 0, lCountDeleted) + Else + sPartialRange = .RangeName + End If + ShiftDown(sPartialRange, WholeRow := False) + End If + + End With + +Finally: + CompactUp = sCompact + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.CompactUp + +REM ----------------------------------------------------------------------------- +Public Function CopySheet(Optional ByVal SheetName As Variant _ + , Optional ByVal NewName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Copy a specified sheet before an existing sheet or at the end of the list of sheets +''' The sheet to copy may be inside any open Calc document +''' Args: +''' SheetName: The name of the sheet to copy or its reference +''' NewName: Must not exist +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert +''' Returns: +''' True if the sheet could be copied successfully +''' Exceptions: +''' DUPLICATESHEETERROR A sheet with the given name exists already +''' Examples: +''' oDoc.CopySheet("SheetX", "SheetY") +''' ' Copy within the same document +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods") +''' oDocB.CopySheet(oDocA.Sheet("SheetX"), "SheetY") +''' ' Copy from 1 file to another and put the new sheet at the end + +Dim bCopy As Boolean ' Return value +Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets +Dim vSheets As Variant ' List of existing sheets +Dim lSheetIndex As Long ' Index of a sheet +Dim oSheet As Object ' Alias of SheetName as reference +Dim lRandom As Long ' Output of random number generator +Dim sRandom ' Random sheet name +Const cstThisSub = "SFDocuments.Calc.CopySheet" +Const cstSubArgs = "SheetName, NewName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCopy = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True, , , True) Then GoTo Finally + If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + +Try: + ' Determine the index of the sheet before which to insert the copy + Set oSheets = _Component.getSheets + vSheets = oSheets.getElementNames() + If VarType(BeforeSheet) = V_STRING Then + lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet) + Else + lSheetIndex = BeforeSheet - 1 + If lSheetIndex < 0 Then lSheetIndex = 0 + If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1 + End If + + ' Copy sheet inside the same document OR import from another document + If VarType(SheetName) = V_STRING Then + _Component.getSheets.copyByName(SheetName, NewName, lSheetIndex) + Else + Set oSheet = SheetName + With oSheet + ' If a sheet with same name as input exists in the target sheet, rename it first with a random name + sRandom = "" + If ScriptForge.SF_Array.Contains(vSheets, .SheetName) Then + lRandom = ScriptForge.SF_Session.ExecuteCalcFunction("RANDBETWEEN", 1, 9999999) + sRandom = "SF_" & Right("0000000" & lRandom, 7) + oSheets.getByName(.SheetName).setName(sRandom) + End If + ' Import i.o. Copy + oSheets.importSheet(oSheet.Component, .SheetName, lSheetIndex) + ' Rename to new sheet name + oSheets.getByName(.SheetName).setName(NewName) + ' Reset random name + If Len(sRandom) > 0 Then oSheets.getByName(srandom).setName(.SheetName) + End With + End If + bCopy = True + +Finally: + CopySheet = bCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDuplicate: + ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, "NewName", NewName, "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopySheet + +REM ----------------------------------------------------------------------------- +Public Function CopySheetFromFile(Optional ByVal FileName As Variant _ + , Optional ByVal SheetName As Variant _ + , Optional ByVal NewName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Copy a specified sheet before an existing sheet or at the end of the list of sheets +''' The sheet to copy is located inside any closed Calc document +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' The file must not be protected with a password +''' SheetName: The name of the sheet to copy +''' NewName: Must not exist +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert +''' Returns: +''' True if the sheet could be created +''' The created sheet is blank when the input file is not a Calc file +''' The created sheet contains an error message when the input sheet was not found +''' Exceptions: +''' DUPLICATESHEETERROR A sheet with the given name exists already +''' UNKNOWNFILEERROR The input file is unknown +''' Examples: +''' oDoc.CopySheetFromFile("C:\MyFile.ods", "SheetX", "SheetY", 3) + +Dim bCopy As Boolean ' Return value +Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet +Dim sFileName As String ' URL alias of FileName +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Calc.CopySheetFromFile" +Const cstSubArgs = "FileName, SheetName, NewName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCopy = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SheetName, "SheetName", V_STRING) Then GoTo Finally + If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + +Try: + Set FSO = ScriptForge.SF_FileSystem + ' Does the input file exist ? + If Not FSO.FileExists(FileName) Then GoTo CatchNotExists + sFileName = FSO._ConvertToUrl(FileName) + + ' Insert a blank new sheet and import sheet from file via link setting and deletion + If Not InsertSheet(Newname, BeforeSheet) Then GoTo Finally + Set oSheet = _Component.getSheets.getByName(NewName) + With oSheet + .link(sFileName,SheetName, "", "", com.sun.star.sheet.SheetLinkMode.NORMAL) + .LinkMode = com.sun.star.sheet.SheetLinkMode.NONE + .LinkURL = "" + End With + bCopy = True + +Finally: + CopySheetFromFile = bCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + ScriptForge.SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopySheetFromFile + +REM ----------------------------------------------------------------------------- +Public Function CopyToCell(Optional ByVal SourceRange As Variant _ + , Optional ByVal DestinationCell As Variant _ + ) As String +''' Copy a specified source range to a destination range or cell +''' The source range may belong to another open document +''' The method imitates the behaviour of a Copy/Paste from a range to a single cell +''' Args: +''' SourceRange: the source range as a string if it belongs to the same document +''' or as a reference if it belongs to another open Calc document +''' DestinationCell: the destination of the copied range of cells, as a string +''' If given as a range of cells, the destination will be reduced to its top-left cell +''' Returns: +''' A string representing the modified range of cells +''' The modified area depends only on the size of the source area +''' Examples: +''' oDoc.CopyToCell("SheetX.A1:F10", "SheetY.C5") +''' ' Copy within the same document +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods") +''' oDocB.CopyToCell(oDocA.Range("SheetX.A1:F10"), "SheetY.C5") +''' ' Copy from 1 file to another + +Dim sCopy As String ' Return value +Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error +Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim oSelect As Object ' Current selection in source +Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable + +Const cstThisSub = "SFDocuments.Calc.CopyToCell" +Const cstSubArgs = "SourceRange, DestinationCell" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCopy = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + End If + +Try: + If VarType(SourceRange) = V_STRING Then ' Same document - Use UNO copyRange method + Set oSourceAddress = _ParseAddress(SourceRange).XCellRange.RangeAddress + Set oDestRange = _ParseAddress(DestinationCell) + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = New com.sun.star.table.CellAddress + With oDestAddress + oDestCell.Sheet = .Sheet + oDestCell.Column = .StartColumn + oDestCell.Row = .StartRow + End With + oDestRange.XSpreadsheet.copyRange(oDestCell, oSourceAddress) + Else ' Use clipboard to copy - current selection in Source should be preserved + Set oSource = SourceRange + With oSource + ' Keep current selection in source document + Set oSelect = .Component.CurrentController.getSelection() + ' Select, copy the source range and paste in the top-left cell of the destination + .Component.CurrentController.select(.XCellRange) + Set oClipboard = .Component.CurrentController.getTransferable() + _Component.CurrentController.select(_Offset(DestinationCell, 0, 0, 1, 1).XCellRange) + _Component.CurrentController.insertTransferable(oClipBoard) + ' Restore previous selection in Source + _RestoreSelections(.Component, oSelect) + Set oSourceAddress = .XCellRange.RangeAddress + End With + End If + + With oSourceAddress + sCopy = _Offset(DestinationCell, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName + End With + +Finally: + CopyToCell = sCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopyToCell + +REM ----------------------------------------------------------------------------- +Public Function CopyToRange(Optional ByVal SourceRange As Variant _ + , Optional ByVal DestinationRange As Variant _ + ) As String +''' Copy downwards and/or rightwards a specified source range to a destination range +''' The source range may belong to another open document +''' The method imitates the behaviour of a Copy/Paste from a range to a larger range +''' If the height (resp. width) of the destination area is > 1 row (resp. column) +''' then the height (resp. width) of the source must be <= the height (resp. width) +''' of the destination. Otherwise nothing happens +''' If the height (resp.width) of the destination is = 1 then the destination +''' is expanded downwards (resp. rightwards) up to the height (resp. width) +''' of the source range +''' Args: +''' SourceRange: the source range as a string if it belongs to the same document +''' or as a reference if it belongs to another open Calc document +''' DestinationRange: the destination of the copied range of cells, as a string +''' Returns: +''' A string representing the modified range of cells +''' Examples: +''' oDoc.CopyToRange("SheetX.A1:F10", "SheetY.C5:J5") +''' ' Copy within the same document +''' ' Returned range: $SheetY.$C$5:$J$14 +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods") +''' oDocB.CopyToRange(oDocA.Range("SheetX.A1:F10"), "SheetY.C5:J5") +''' ' Copy from 1 file to another + +Dim sCopy As String ' Return value +Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error +Dim oDestRange As Object ' Destination as a range +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim oSelect As Object ' Current selection in source +Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable +Dim bSameDocument As Boolean ' True when source in same document as destination +Dim lHeight As Long ' Height of destination +Dim lWidth As Long ' Width of destination + +Const cstThisSub = "SFDocuments.Calc.CopyToRange" +Const cstSubArgs = "SourceRange, DestinationRange" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCopy = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationRange, "DestinationRange", V_STRING) Then GoTo Finally + End If + +Try: + ' Copy done via clipboard + + ' Check Height/Width destination = 1 or > Height/Width of source + bSameDocument = ( VarType(SourceRange) = V_STRING ) + If bSameDocument Then Set oSource = _ParseAddress(SourceRange) Else Set oSource = SourceRange + Set oDestRange = _ParseAddress(DestinationRange) + With oDestRange + lHeight = .Height + lWidth = .Width + If lHeight = 1 Then + lHeight = oSource.Height ' Future height + ElseIf lHeight < oSource.Height Then + GoTo Finally + End If + If lWidth = 1 Then + lWidth = oSource.Width ' Future width + ElseIf lWidth < oSource.Width Then + GoTo Finally + End If + End With + + With oSource + ' Store actual selection in source + Set oSelect = .Component.CurrentController.getSelection() + ' Select, copy the source range and paste in the destination + .Component.CurrentController.select(.XCellRange) + Set oClipboard = .Component.CurrentController.getTransferable() + _Component.CurrentController.select(oDestRange.XCellRange) + _Component.CurrentController.insertTransferable(oClipBoard) + ' Restore selection in source + _RestoreSelections(.Component, oSelect) + End With + + sCopy = _Offset(oDestRange, 0, 0, lHeight, lWidth).RangeName + +Finally: + CopyToRange = sCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopyToRange + +REM ----------------------------------------------------------------------------- +Public Function CreateChart(Optional ByVal ChartName As Variant _ + , Optional ByVal SheetName As Variant _ + , Optional ByVal Range As Variant _ + , Optional ColumnHeader As Variant _ + , Optional RowHeader As Variant _ + ) As Variant +''' Return a new chart instance initialized with default values +''' Args: +''' ChartName: The user-defined name of the new chart +''' SheetName: The name of an existing sheet +''' Range: the cell or the range as a string that should be drawn +''' ColumnHeader: when True, the topmost row of the range will be used to set labels for the category axis or the legend. +''' Default = False +''' RowHeader: when True, the leftmost column of the range will be used to set labels for the category axis or the legend. +''' Default = False +''' Returns: +''' A new chart service instance +''' Exceptions: +''' DUPLICATECHARTERROR A chart with the same name exists already in the given sheet +''' Examples: +''' Dim oChart As Object +''' Set oChart = oDoc.CreateChart("myChart", "SheetX", "A1:C8", ColumnHeader := True) + +Dim oChart As Object ' Return value +Dim vCharts As Variant ' List of pre-existing charts +Dim oSheet As Object ' Alias of SheetName as reference +Dim oRange As Object ' Alias of Range +Dim oRectangle as new com.sun.star.awt.Rectangle ' Simple shape + +Const cstThisSub = "SFDocuments.Calc.CreateChart" +Const cstSubArgs = "ChartName, SheetName, Range, [ColumnHeader=False], [RowHeader=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oChart = Nothing + +Check: + If IsMissing(RowHeader) Or IsEmpty(RowHeader) Then Rowheader = False + If IsMissing(ColumnHeader) Or IsEmpty(ColumnHeader) Then ColumnHeader = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ColumnHeader, "ColumnHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(RowHeader, "RowHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + vCharts = Charts(SheetName) + If ScriptForge.SF_Array.Contains(vCharts, ChartName, CaseSensitive := True) Then GoTo CatchDuplicate + +Try: + ' The rectangular shape receives arbitrary values. User can Resize() it later + With oRectangle + .X = 0 : .Y = 0 + .Width = 8000 : .Height = 6000 + End With + ' Initialize sheet and range + Set oSheet = _Component.getSheets.getByName(SheetName) + Set oRange = _ParseAddress(Range) + ' Create the chart and get ihe corresponding chart instance + oSheet.getCharts.addNewByName(ChartName, oRectangle, Array(oRange.XCellRange.RangeAddress), ColumnHeader, RowHeader) + Set oChart = Charts(SheetName, ChartName) + oChart._Shape.Name = ChartName ' Both user-defined and internal names match ChartName + oChart._Diagram.Wall.FillColor = RGB(255, 255, 255) ' Align on background color set by the user interface by default + +Finally: + Set CreateChart = oChart + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDuplicate: + ScriptForge.SF_Exception.RaiseFatal(DUPLICATECHARTERROR, "ChartName", ChartName, "SheetName", SheetName, "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc.CreateChart + +REM ----------------------------------------------------------------------------- +Public Function CreatePivotTable(Optional ByVal PivotTableName As Variant _ + , Optional ByVal SourceRange As Variant _ + , Optional ByVal TargetCell As Variant _ + , Optional ByRef DataFields As Variant _ + , Optional ByRef RowFields As Variant _ + , Optional ByRef ColumnFields As Variant _ + , Optional ByVal FilterButton As Variant _ + , Optional ByVal RowTotals As Variant _ + , Optional ByVal ColumnTotals As Variant _ + ) As String +''' Create a new pivot table with the properties defined by the arguments. +''' If a pivot table with the same name exists already in the targeted sheet, it will be erased without warning. +''' Args: +''' PivotTableName: The user-defined name of the new pivottable +''' SourceRange: The range as a string containing the raw data. +''' The first row of the range is presumed to contain the field names of the new pivot table +''' TargetCell: the top left cell or the range as a string where to locate the pivot table. +''' Only the top left cell of the range will be considered. +''' DataFields: A single string or an array of field name + function to apply, formatted like: +''' Array("FieldName[;Function]", ...) +''' The allowed functions are: Sum, Count, Average, Max, Min, Product, CountNums, StDev, StDevP, Var, VarP and Median. +''' The default function is: When the values are all numerical, Sum is used, otherwise Count +''' RowFields: A single string or an array of the field names heading the pivot table rows +''' ColumnFields: A single string or an array of the field names heading the pivot table columns +''' FilterButton: When True (default), display a "Filter" button above the pivot table +''' RowTotals: When True (default), display a separate column for row totals +''' ColumnTotals: When True (default), display a separate row for column totals +''' Returns: +''' Return the range where the new pivot table is deployed. +''' Examples: +''' Dim vData As Variant, oDoc As Object, sTable As String, sPivot As String +''' vData = Array(Array("Item", "State", "Team", "2002", "2003", "2004"), _ +''' Array("Books", "Michigan", "Jean", 14788, 30222, 23490), _ +''' Array("Candy", "Michigan", "Jean", 26388, 15641, 32849), _ +''' Array("Pens", "Michigan", "Jean", 16569, 32675, 25396), _ +''' Array("Books", "Michigan", "Volker", 21961, 21242, 29009), _ +''' Array("Candy", "Michigan", "Volker", 26142, 22407, 32841)) +''' Set oDoc = ui.CreateDocument("Calc") +''' sTable = oDoc.SetArray("A1", vData) +''' sPivot = oDoc.CreatePivotTable("PT1", sTable, "H1", Array("2002", "2003;count", "2004;average"), "Item", Array("State", "Team"), False) + +Dim sPivotTable As String ' Return value +Dim vData As Variant ' Alias of DataFields +Dim vRows As Variant ' Alias of RowFields +Dim vColumns As Variant ' Alias of ColumnFields +Dim oSourceAddress As Object ' Source as an _Address +Dim oTargetAddress As Object ' Target as an _Address +Dim vHeaders As Variant ' Array of header fields in the source range +Dim oPivotTables As Object ' com.sun.star.sheet.XDataPilotTables +Dim oDescriptor As Object ' com.sun.star.sheet.DataPilotDescriptor +Dim oFields As Object ' ScDataPilotFieldsObj - Collection of fields +Dim oField As Object ' ScDataPilotFieldsObj - A single field +Dim sField As String ' A single field name +Dim sData As String ' A single data field name + function +Dim vDataField As Variant ' A single vData element, split on semicolon +Dim sFunction As String ' Function to apply on a data field (string) +Dim iFunction As Integer ' Equivalent of sFunction as com.sun.star.sheet.GeneralFunction2 constant +Dim oOutputRange As Object ' com.sun.star.table.CellRangeAddress +Dim i As Integer + +Const cstThisSub = "SFDocuments.Calc.CreatePivotTable" +Const cstSubArgs = "PivotTableName, SourceRange, TargetCell, DataFields, [RowFields], [ColumnFields]" _ + & ", [FilterButton=True], [RowTotals=True], [ColumnTotals=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sPivotTable = "" + +Check: + If IsMissing(RowFields) Or IsEmpty(RowFields) Then RowFields = Array() + If IsMissing(ColumnFields) Or IsEmpty(ColumnFields) Then ColumnFields = Array() + If IsMissing(FilterButton) Or IsEmpty(FilterButton) Then FilterButton = True + If IsMissing(RowTotals) Or IsEmpty(RowTotals) Then RowTotals = True + If IsMissing(ColumnTotals) Or IsEmpty(ColumnTotals) Then ColumnTotals = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PivotTableName, "PivotTableName", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally + If IsArray(DataFields) Then + If Not ScriptForge.SF_Utils._ValidateArray(DataFields, "DataFields", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(DataFields, "DataFields", V_STRING) Then GoTo Finally + End If + If IsArray(RowFields) Then + If Not ScriptForge.SF_Utils._ValidateArray(RowFields, "RowFields", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(RowFields, "RowFields", V_STRING) Then GoTo Finally + End If + If IsArray(ColumnFields) Then + If Not ScriptForge.SF_Utils._ValidateArray(ColumnFields, "ColumnFields", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(ColumnFields, "ColumnFields", V_STRING) Then GoTo Finally + End If + If Not ScriptForge.SF_Utils._Validate(FilterButton, "FilterButton", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(RowTotals, "RowTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ColumnTotals, "ColumnTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + ' Next statements must be outside previous If-block to force their execution even in case of internal call + If IsArray(DataFields) Then vData = DataFields Else vData = Array(DataFields) + If IsArray(RowFields) Then vRows = RowFields Else vRows = Array(RowFields) + If IsArray(ColumnFields) Then vColumns = ColumnFields Else vColumns = Array(ColumnFields) + +Try: + + Set oSourceAddress = _ParseAddress(SourceRange) + vHeaders = GetValue(Offset(SourceRange, 0, 0, 1)) ' Content of the first row of the source + Set oTargetAddress = _Offset(TargetCell, 0, 0, 1, 1) ' Retain the top left cell only + Set oPivotTables = oTargetAddress.XSpreadsheet.getDataPilotTables() + + ' Initialize new pivot table + Set oDescriptor = oPivotTables.createDataPilotDescriptor() + oDescriptor.setSourceRange(oSourceAddress.XCellRange.RangeAddress) + Set oFields = oDescriptor.getDataPilotFields() + + ' Set row fields + For i = 0 To UBound(vRows) + sField = vRows(i) + If Len(sField) > 0 Then + If Not ScriptForge.SF_Utils._Validate(sField, "RowFields", V_STRING, vHeaders) Then GoTo Finally + Set oField = oFields.getByName(sField) + oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.ROW + End If + Next i + + ' Set column fields + For i = 0 To UBound(vColumns) + sField = vColumns(i) + If Len(sField) > 0 Then + If Not ScriptForge.SF_Utils._Validate(sField, "ColumnFields", V_STRING, vHeaders) Then GoTo Finally + Set oField = oFields.getByName(sField) + oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.COLUMN + End If + Next i + + ' Set data fields + For i = 0 To UBound(vData) + sData = vData(i) + ' Minimal parsing + If Right(sData, 1) = ";" Then sData = Left(sData, Len(sData) - 1) + vDataField = Split(sData, ";") + sField = vDataField(0) + If UBound(vDataField) > 0 Then sFunction = vDataField(1) Else sFunction = "" + ' Define field properties + If Len(sField) > 0 Then + If Not ScriptForge.SF_Utils._Validate(sField, "DataFields", V_STRING, vHeaders) Then GoTo Finally + Set oField = oFields.getByName(sField) + oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.DATA + ' Associate the correct function + With com.sun.star.sheet.GeneralFunction2 + Select Case UCase(sFunction) + Case "" : iFunction = .AUTO + Case "SUM" : iFunction = .SUM + Case "COUNT" : iFunction = .COUNT + Case "AVERAGE" : iFunction = .AVERAGE + Case "MAX" : iFunction = .MAX + Case "MIN" : iFunction = .MIN + Case "PRODUCT" : iFunction = .PRODUCT + Case "COUNTNUMS": iFunction = .COUNTNUMS + Case "STDEV" : iFunction = .STDEV + Case "STDEVP" : iFunction = .STDEVP + Case "VAR" : iFunction = .VAR + Case "VARP" : iFunction = .VARP + Case "MEDIAN" : iFunction = .MEDIAN + Case Else + If Not ScriptForge.SF_Utils._Validate(sFunction, "DataFields/Function", V_STRING _ + , Array("Sum", "Count", "Average", "Max", "Min", "Product", "CountNums" _ + , "StDev", "StDevP", "Var", "VarP", "Median") _ + ) Then GoTo Finally + End Select + End With + oField.Function2 = iFunction + End If + Next i + + ' Remove any pivot table with same name + If oPivotTables.hasByName(PivotTableName) Then oPivotTables.removeByName(PivotTableName) + + ' Finalize the new pivot table + oDescriptor.ShowFilterButton = FilterButton + oDescriptor.RowGrand = RowTotals + oDescriptor.ColumnGrand = ColumnTotals + oPivotTables.insertNewByName(PivotTableName, oTargetAddress.XCellRange.getCellByPosition(0, 0).CellAddress, oDescriptor) + + ' Determine the range of the new pivot table + Set oOutputRange = oPivotTables.getByName(PivotTableName).OutputRange + With oOutputRange + sPivotTable = _Component.getSheets().getCellRangeByPosition(.StartColumn, .StartRow, .EndColumn, .EndRow, .Sheet).AbsoluteName + End With + +Finally: + CreatePivotTable = sPivotTable + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.CreatePivotTable + +REM ----------------------------------------------------------------------------- +Public Function DAvg(Optional ByVal Range As Variant) As Double +''' Get the average of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The average of the numeric values as a double +''' Examples: +''' Val = oDoc.DAvg("~.A1:A1000") + +Try: + DAvg = _DFunction("DAvg", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DAvg + +REM ----------------------------------------------------------------------------- +Public Function DCount(Optional ByVal Range As Variant) As Long +''' Get the number of numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The number of numeric values as a Long +''' Examples: +''' Val = oDoc.DCount("~.A1:A1000") + +Try: + DCount = _DFunction("DCount", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DCount + +REM ----------------------------------------------------------------------------- +Public Function DMax(Optional ByVal Range As Variant) As Double +''' Get the greatest of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The greatest of the numeric values as a double +''' Examples: +''' Val = oDoc.DMax("~.A1:A1000") + +Try: + DMax = _DFunction("DMax", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DMax + +REM ----------------------------------------------------------------------------- +Public Function DMin(Optional ByVal Range As Variant) As Double +''' Get the smallest of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The smallest of the numeric values as a double +''' Examples: +''' Val = oDoc.DMin("~.A1:A1000") + +Try: + DMin = _DFunction("DMin", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DMin + +REM ----------------------------------------------------------------------------- +Public Function DSum(Optional ByVal Range As Variant) As Double +''' Get sum of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The sum of the numeric values as a double +''' Examples: +''' Val = oDoc.DSum("~.A1:A1000") + +Try: + DSum = _DFunction("DSum", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DSum + +REM ----------------------------------------------------------------------------- +Public Function ExportRangeToFile(Optional ByVal Range As Variant _ + , Optional ByVal FileName As Variant _ + , Optional ByVal ImageType As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Store the given range as an image to the given file location +''' Actual selections are not impacted +''' Inspired by https://stackoverflow.com/questions/30509532/how-to-export-cell-range-to-pdf-file +''' Args: +''' Range: sheet name or cell range to be exported, as a string +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' ImageType: the name of the targeted media type +''' Allowed values: jpeg, pdf (default) and png +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' RANGEEXPORTERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.ExportRangeToFile('SheetX.B2:J15", "C:\Me\Range2.png", ImageType := "png", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vStoreArguments As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vFilterData As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Dim vImageTypes As Variant ' Array of permitted image types +Dim vFilters As Variant ' Array of corresponding filters in the same order as vImageTypes +Dim sFilter As String ' The filter to apply +Dim oSelect As Object ' Currently selected range(s) +Dim oAddress As Object ' Alias of Range + +Const cstImageTypes = "jpeg,pdf,png" +Const cstFilters = "calc_jpg_Export,calc_pdf_Export,calc_png_Export" + +Const cstThisSub = "SFDocuments.Calc.ExportRangeToFile" +Const cstSubArgs = "Range, FileName, [ImageType=""pdf""|""jpeg""|""png""], [Overwrite=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(ImageType) Or IsEmpty(ImageType) Then ImageType = "pdf" + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + + vImageTypes = Split(cstImageTypes, ",") + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ImageType, "ImageType", V_STRING, vImageTypes) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + vFilters = Split(cstFilters, ",") + sFilter = vFilters(ScriptForge.SF_Array.IndexOf(vImageTypes, ImageType, CaseSensitive := False)) + Set oAddress = _ParseAddress(Range) + + ' The filter arguments differ between + ' 1) pdf : store range in Selection property value + ' 2) png, jpeg : save current selection, select range, restore initial selection + If LCase(ImageType) = "pdf" Then + vFilterData = Array(ScriptForge.SF_Utils._MakePropertyValue("Selection", oAddress.XCellRange) ) + vStoreArguments = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterData", vFilterData) _ + ) + Else ' png, jpeg + ' Save the current selection(s) + Set oSelect = _Component.CurrentController.getSelection() + _Component.CurrentController.select(oAddress.XCellRange) + vStoreArguments = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ + , ScriptForge.SF_Utils._MakePropertyValue("SelectionOnly", True) _ + ) + End If + + ' Apply the filter and export + _Component.storeToUrl(sFile, vStoreArguments) + If LCase(ImageType) <> "pdf" Then _RestoreSelections(_Component, oSelect) + + bSaved = True + +Finally: + ExportRangeToFile = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(RANGEEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite) + GoTo Finally +End Function ' SFDocuments.SF_Chart.ExportRangeToFile + +REM ----------------------------------------------------------------------------- +Public Function Forms(Optional ByVal SheetName As Variant _ + , Optional ByVal Form As Variant _ + ) As Variant +''' Return either +''' - the list of the Forms contained in the given sheet +''' - a SFDocuments.Form object based on its name or its index +''' Args: +''' SheetName: the name of the sheet containing the requested form or forms +''' Form: a form stored in the document given by its name or its index +''' When absent, the list of available forms is returned +''' To get the first (unique ?) form stored in the form document, set Form = 0 +''' Exceptions: +''' CALCFORMNOTFOUNDERROR Form not found +''' Returns: +''' A zero-based array of strings if Form is absent +''' An instance of the SF_Form class if Form exists +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.Forms("ThisSheet") +''' Set myForm = oDoc.Forms("ThisSheet", 0) + +Dim oForm As Object ' The new Form class instance +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Dim oXForm As Object ' com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +Dim vFormNames As Variant ' Array of form names +Dim oForms As Object ' Forms collection +Const cstDrawPage = -1 ' There is no DrawPages collection in Calc sheets + +Const cstThisSub = "SFDocuments.Calc.Forms" +Const cstSubArgs = "SheetName, [Form=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Form) Or IsEmpty(Form) Then Form = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + +Try: + ' Start from the Calc sheet and go down to forms + Set oForms = _Component.getSheets.getByName(SheetName).DrawPage.Forms + vFormNames = oForms.getElementNames() + + If Len(Form) = 0 Then ' Return the list of valid form names + Forms = vFormNames + Else + If VarType(Form) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Utils._Validate(Form, "Form", V_STRING, vFormNames) Then GoTo Finally + Set oXForm = oForms.getByName(Form) + Else ' Find the form by index + If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound + Set oXForm = oForms.getByIndex(Form) + End If + ' Create the new Form class instance + Set oForm = SF_Register._NewForm(oXForm) + With oForm + Set .[_Parent] = [Me] + ._SheetName = SheetName + ._FormType = ISCALCFORM + Set ._Component = _Component + ._Initialize() + End With + Set Forms = oForm + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(CALCFORMNOTFOUNDERROR, Form, _FileIdent()) +End Function ' SFDocuments.SF_Calc.Forms + +REM ----------------------------------------------------------------------------- +Function GetColumnName(Optional ByVal ColumnNumber As Variant) As String +''' Convert a column number (range 1, 2,..1024) into its letter counterpart (range 'A', 'B',..'AMJ'). +''' Args: +''' ColumnNumber: the column number, must be in the interval 1 ... 1024 +''' Returns: +''' a string representation of the column name, in range 'A'..'AMJ' +''' If ColumnNumber is not in the allowed range, returns a zero-length string +''' Example: +''' MsgBox oDoc.GetColumnName(1022) ' "AMH" +''' Adapted from a Python function by sundar nataraj +''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter + +Dim sCol As String ' Return value +Const cstThisSub = "SFDocuments.Calc.GetColumnName" +Const cstSubArgs = "ColumnNumber" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCol = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(ColumnNumber, "ColumnNumber", V_NUMERIC) Then GoTo Finally + End If + +Try: + If (ColumnNumber > 0) And (ColumnNumber <= MAXCOLS) Then sCol = _GetColumnName(ColumnNumber) + +Finally: + GetColumnName = sCol + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.GetColumnName + +REM ----------------------------------------------------------------------------- +Public Function GetFormula(Optional ByVal Range As Variant) As Variant +''' Get the formula(e) stored in the given range of cells +''' Args: +''' Range : the range as a string where to get the formula from +''' Returns: +''' A scalar, a zero-based 1D array or a zero-based 2D array of strings +''' Examples: +''' Val = oDoc.GetFormula("~.A1:A1000") + +Dim vGet As Variant ' Return value +Dim oAddress As Object ' Alias of Range +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.GetFormula" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vGet = Empty + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + ' Get the data + Set oAddress = _ParseAddress(Range) + vDataArray = oAddress.XCellRange.getFormulaArray() + + ' Convert the data array to scalar, vector or array + vGet = _ConvertFromDataArray(vDataArray) + +Finally: + GetFormula = vGet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.GetFormula + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant _ + , Optional ObjectName As Variant _ + ) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' ObjectName: a sheet or range name +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Calc.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If IsMissing(ObjectName) Or IsEMpty(ObjectName) Then ObjectName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(ObjectName, "ObjectName", V_STRING) Then GoTo Catch + End If + +Try: + ' Superclass or subclass property ? + If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then + GetProperty = [_Super].GetProperty(PropertyName) + ElseIf Len(ObjectName) = 0 Then + GetProperty = _PropertyGet(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName, ObjectName) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetValue(Optional ByVal Range As Variant) As Variant +''' Get the value(s) stored in the given range of cells +''' Args: +''' Range : the range as a string where to get the value from +''' Returns: +''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and doubles +''' To convert doubles to dates, use the CDate builtin function +''' Examples: +''' Val = oDoc.GetValue("~.A1:A1000") + +Dim vGet As Variant ' Return value +Dim oAddress As Object ' Alias of Range +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.GetValue" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vGet = Empty + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + ' Get the data + Set oAddress = _ParseAddress(Range) + vDataArray = oAddress.XCellRange.getDataArray() + + ' Convert the data array to scalar, vector or array + vGet = _ConvertFromDataArray(vDataArray) + +Finally: + GetValue = vGet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.GetValue + +REM ----------------------------------------------------------------------------- +Public Function ImportFromCSVFile(Optional ByVal FileName As Variant _ + , Optional ByVal DestinationCell As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As String +''' Import the content of a CSV-formatted text file starting from a given cell +''' Beforehand the destination area will be cleared from any content and format +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' DestinationCell: the destination of the copied range of cells, as a string +''' If given as range, the destination will be reduced to its top-left cell +''' FilterOptions: The arguments of the CSV input filter. +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options_for_the_CSV_Filter +''' Default: input file encoding is UTF8 +''' separator = comma, semi-colon or tabulation +''' string delimiter = double quote +''' all lines are included +''' quoted strings are formatted as texts +''' special numbers are detected +''' all columns are presumed texts +''' language = english/US => decimal separator is ".", thousands separator = "," +''' Returns: +''' A string representing the modified range of cells +''' The modified area depends only on the content of the source file +''' Exceptions: +''' DOCUMENTOPENERROR The csv file could not be opened +''' Examples: +''' oDoc.ImportFromCSVFile("C:\Temp\myCsvFile.csv", "SheetY.C5") + +Dim sImport As String ' Return value +Dim oUI As Object ' UI service +Dim oSource As Object ' New Calc document with csv loaded +Dim oSelect As Object ' Current selection in destination + +Const cstFilter = "Text - txt - csv (StarCalc)" +Const cstFilterOptions = "9/44/59/MRG,34,76,1,,1033,true,true" +Const cstThisSub = "SFDocuments.Calc.ImportFromCSVFile" +Const cstSubArgs = "FileName, DestinationCell, [FilterOptions]=""9/44/59/MRG,34,76,1,,1033,true,true""" + +' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sImport = "" + +Check: + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = cstFilterOptions + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + End If + +Try: + ' Input file is loaded in an empty worksheet. Data are copied to destination cell + Set oUI = CreateScriptService("UI") + Set oSource = oUI.OpenDocument(FileName _ + , ReadOnly := True _ + , Hidden := True _ + , FilterName := cstFilter _ + , FilterOptions := FilterOptions _ + ) + ' Remember current selection and restore it after copy + Set oSelect = _Component.CurrentController.getSelection() + sImport = CopyToCell(oSource.Range("*"), DestinationCell) + _RestoreSelections(_Component, oSelect) + +Finally: + If Not IsNull(oSource) Then oSource.CloseDocument(False) + ImportFromCSVFile = sImport + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.ImportFromCSVFile + +REM ----------------------------------------------------------------------------- +Public Sub ImportFromDatabase(Optional ByVal FileName As Variant _ + , Optional ByVal RegistrationName As Variant _ + , Optional ByVal DestinationCell As Variant _ + , Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + ) +''' Import the content of a database table, query or resultset, i.e. the result of a SELECT SQL command, +''' starting from a given cell +''' Beforehand the destination area will be cleared from any content and format +''' The modified area depends only on the content of the source data +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' RegistrationName: the name of a registered database +''' It is ignored if FileName <> "" +''' DestinationCell: the destination of the copied range of cells, as a string +''' If given as a range of cells, the destination will be reduced to its top-left cell +''' SQLCommand: either a table or query name (without square brackets) +''' or a full SQL commands where table and fieldnames are preferably surrounded with square brackets +''' Returns: +''' Implemented as a Sub because the doImport UNO method does not return any error +''' Exceptions: +''' BASEDOCUMENTOPENERROR The database file could not be opened +''' Examples: +''' oDoc.ImportFromDatabase("C:\Temp\myDbFile.odb", , "SheetY.C5", "SELECT * FROM [Employees] ORDER BY [LastName]") + +Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext +Dim oDatabase As Object ' SFDatabases.Database service +Dim lCommandType As Long ' A com.sun.star.sheet.DataImportMode.xxx constant +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim bDirect As Boolean ' Alias of DirectSQL +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.XCell +Dim oSelect As Object ' Current selection in destination +Dim vImportOptions As Variant ' Array of PropertyValues + +Const cstThisSub = "SFDocuments.Calc.ImportFromDatabase" +Const cstSubArgs = "[FileName=""""], [RegistrationName=""""], DestinationCell, SQLCommand, [DirectSQL=False]" + +' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + + If IsMissing(FileName) Or IsEmpty(FileName) Then FileName = "" + If IsMissing(RegistrationName) Or IsEmpty(RegistrationName) Then RegistrationName = "" + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check the existence of FileName + If Len(FileName) = 0 Then ' FileName has precedence over RegistrationName + If Len(RegistrationName) = 0 Then GoTo CatchError + Set oDBContext = ScriptForge.SF_Utils._GetUNOService("DatabaseContext") + If Not oDBContext.hasRegisteredDatabase(RegistrationName) Then GoTo CatchError + FileName = ScriptForge.SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(RegistrationName)) + End If + If Not ScriptForge.SF_FileSystem.FileExists(FileName) Then GoTo CatchError + +Try: + ' Check command type + Set oDatabase = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database", FileName, , True) ' Read-only + If IsNull(oDatabase) Then GoTo CatchError + With oDatabase + If ScriptForge.SF_Array.Contains(.Tables, SQLCommand) Then + bDirect = True + lCommandType = com.sun.star.sheet.DataImportMode.TABLE + ElseIf ScriptForge.SF_Array.Contains(.Queries, SQLCommand) Then + Set oQuery = .XConnection.Queries.getByName(SQLCommand) + bDirect = Not oQuery.EscapeProcessing + lCommandType = com.sun.star.sheet.DataImportMode.QUERY + Else + bDirect = DirectSQL + lCommandType = com.sun.star.sheet.DataImportMode.SQL + SQLCommand = ._ReplaceSquareBrackets(SQLCommand) + End If + .CloseDatabase() + Set oDatabase = oDatabase.Dispose() + End With + + ' Determine the destination cell as the top-left coordinates of the given range + Set oDestRange = _ParseAddress(DestinationCell) + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = oDestRange.XSpreadsheet.getCellByPosition(oDestAddress.StartColumn, oDestAddress.StartRow) + + ' Remember current selection + Set oSelect = _Component.CurrentController.getSelection() + ' Import arguments + vImportOptions = Array(_ + ScriptForge.SF_Utils._MakePropertyValue("DatabaseName", ScriptForge.SF_FileSystem._ConvertToUrl(FileName)) _ + , ScriptForge.SF_Utils._MakePropertyValue("SourceObject", SQLCommand) _ + , ScriptForge.SF_Utils._MakePropertyValue("SourceType", lCommandType) _ + , ScriptForge.SF_Utils._MakePropertyValue("IsNative", bDirect) _ + ) + oDestCell.doImport(vImportOptions) + ' Restore selection after import_ + _RestoreSelections(_Component, oSelect) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +CatchError: + SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", FileName, "RegistrationName", RegistrationName) + GoTo Finally +End Sub ' SFDocuments.SF_Calc.ImportFromDatabase + +REM ----------------------------------------------------------------------------- +Public Function InsertSheet(Optional ByVal SheetName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Insert a new empty sheet before an existing sheet or at the end of the list of sheets +''' Args: +''' SheetName: The name of the new sheet +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert +''' Returns: +''' True if the sheet could be inserted successfully +''' Examples: +''' oDoc.InsertSheet("SheetX", "SheetY") + +Dim bInsert As Boolean ' Return value +Dim vSheets As Variant ' List of existing sheets +Dim lSheetIndex As Long ' Index of a sheet +Const cstThisSub = "SFDocuments.Calc.InsertSheet" +Const cstSubArgs = "SheetName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bInsert = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + vSheets = _Component.getSheets.getElementNames() + +Try: + If VarType(BeforeSheet) = V_STRING Then + lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet) + Else + lSheetIndex = BeforeSheet - 1 + If lSheetIndex < 0 Then lSheetIndex = 0 + If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1 + End If + _Component.getSheets.insertNewByName(SheetName, lSheetIndex) + bInsert = True + +Finally: + InsertSheet = binsert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.InsertSheet + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Calc service as an array + + Methods = Array( _ + "A1Style" _ + , "Charts" _ + , "ClearAll" _ + , "ClearFormats" _ + , "ClearValues" _ + , "CopySheet" _ + , "CopySheetFromFile" _ + , "CopyToCell" _ + , "CopyToRange" _ + , "CreateChart" _ + , "DAvg" _ + , "DCount" _ + , "DMax" _ + , "DMin" _ + , "DSum" _ + , "ExportRangeToFile" _ + , "GetColumnName" _ + , "GetFormula" _ + , "GetValue" _ + , "ImportFromCSVFile" _ + , "ImportFromDatabase" _ + , "InsertSheet" _ + , "MoveRange" _ + , "MoveSheet" _ + , "Offset" _ + , "OpenRangeSelector" _ + , "Printf" _ + , "PrintOut" _ + , "RemoveSheet" _ + , "RenameSheet" _ + , "SetArray" _ + , "SetCellStyle" _ + , "SetFormula" _ + , "SetValue" _ + , "ShiftDown" _ + , "ShiftLeft" _ + , "ShiftRight" _ + , "ShiftUp" _ + , "SortRange" _ + ) + +End Function ' SFDocuments.SF_Calc.Methods + +REM ----------------------------------------------------------------------------- +Public Function MoveRange(Optional ByVal Source As Variant _ + , Optional ByVal Destination As Variant _ + ) As String +''' Move a specified source range to a destination range +''' Args: +''' Source: the source range of cells as a string +''' Destination: the destination of the moved range of cells, as a string +''' If given as a range of cells, the destination will be reduced to its top-left cell +''' Returns: +''' A string representing the modified range of cells +''' The modified area depends only on the size of the source area +''' Examples: +''' oDoc.MoveRange("SheetX.A1:F10", "SheetY.C5") + +Dim sMove As String ' Return value +Dim oSource As Object ' Alias of Source to avoid "Object variable not set" run-time error +Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim oSelect As Object ' Current selection in source +Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable +Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges +Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.MoveRange" +Const cstSubArgs = "Source, Destination" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sMove = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _Validate(Source, "Source", V_STRING) Then GoTo Finally + If Not _Validate(Destination, "Destination", V_STRING) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Source).XCellRange.RangeAddress + Set oDestRange = _ParseAddress(Destination) + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = New com.sun.star.table.CellAddress + With oDestAddress + oDestCell.Sheet = .Sheet + oDestCell.Column = .StartColumn + oDestCell.Row = .StartRow + End With + oDestRange.XSpreadsheet.moveRange(oDestCell, oSourceAddress) + + With oSourceAddress + sMove = _Offset(Destination, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName + End With + +Finally: + MoveRange = sMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.MoveRange + +REM ----------------------------------------------------------------------------- +Public Function MoveSheet(Optional ByVal SheetName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Move a sheet before an existing sheet or at the end of the list of sheets +''' Args: +''' SheetName: The name of the sheet to move +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to move the sheet +''' Returns: +''' True if the sheet could be moved successfully +''' Examples: +''' oDoc.MoveSheet("SheetX", "SheetY") + +Dim bMove As Boolean ' Return value +Dim vSheets As Variant ' List of existing sheets +Dim lSheetIndex As Long ' Index of a sheet +Const cstThisSub = "SFDocuments.Calc.MoveSheet" +Const cstSubArgs = "SheetName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMove = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + vSheets = _Component.getSheets.getElementNames() + +Try: + If VarType(BeforeSheet) = V_STRING Then + lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet) + Else + lSheetIndex = BeforeSheet - 1 + If lSheetIndex < 0 Then lSheetIndex = 0 + If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1 + End If + _Component.getSheets.MoveByName(SheetName, lSheetIndex) + bMove = True + +Finally: + MoveSheet = bMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.MoveSheet + +REM ----------------------------------------------------------------------------- +Public Function Offset(Optional ByRef Range As Variant _ + , Optional ByVal Rows As Variant _ + , Optional ByVal Columns As Variant _ + , Optional ByVal Height As Variant _ + , Optional ByVal Width As Variant _ + ) As String +''' Returns a new range offset by a certain number of rows and columns from a given range +''' Args: +''' Range : the range, as a string, from which the function searches for the new range +''' Rows : the number of rows by which the reference was corrected up (negative value) or down. +''' Use 0 (default) to stay in the same row. +''' Columns : the number of columns by which the reference was corrected to the left (negative value) or to the right. +''' Use 0 (default) to stay in the same column +''' Height : the vertical height for an area that starts at the new reference position. +''' Default = no vertical resizing +''' Width : the horizontal width for an area that starts at the new reference position. +''' Default - no horizontal resizing +''' Arguments Rows and Columns must not lead to zero or negative start row or column. +''' Arguments Height and Width must not lead to zero or negative count of rows or columns. +''' Returns: +''' A new range as a string +''' Exceptions: +''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries +''' Examples: +''' oDoc.Offset("A1", 2, 2) ' "'SheetX'.$C$3" (A1 moved by two rows and two columns down) +''' oDoc.Offset("A1", 2, 2, 5, 6) ' "'SheetX'.$C$3:$H$7" + +Dim sOffset As String ' Return value +Dim oAddress As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.Offset" +Const cstSubArgs = "Range, [Rows=0], [Columns=0], [Height], [Width]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sOffset = "" + +Check: + If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 + If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 + If IsMissing(Height) Or IsEmpty(Height) Then Height = 0 + If IsMissing(Width) Or IsEmpty(Width) Then Width = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Define the new range string + Set oAddress = _Offset(Range, Rows, Columns, Height, Width) + sOffset = oAddress.RangeName + +Finally: + Offset = sOffset + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.Offset + +REM ----------------------------------------------------------------------------- +Public Function OpenRangeSelector(Optional ByVal Title As Variant _ + , Optional ByVal Selection As Variant _ + , Optional ByVal SingleCell As Variant _ + , Optional ByVal CloseAfterSelect As Variant _ + ) As String +''' Activates the Calc document, opens a non-modal dialog with a text box, +''' let the user make a selection in the current or another sheet and +''' returns the selected area as a string. +''' This method does not change the current selection. +''' Args: +''' Title: the title to display on the top of the dialog +''' Selection: a default preselection as a String. When absent, the first element of the +''' current selection is preselected. +''' SingleCell: When True, only a single cell may be selected. Default = False +''' CloseAfterSelect: When True (default-, the dialog is closed immediately after +''' the selection. When False, the user may change his/her mind and must close +''' the dialog manually. +''' Returns: +''' The selected range as a string, or the empty string when the user cancelled the request (close window button) +''' Exceptions: +''' Examples: +''' Dim sSelect As String, vValues As Variant +''' sSelect = oDoc.OpenRangeSelector("Select a range ...") +''' If sSelect = "" Then Exit Function +''' vValues = oDoc.GetValue(sSelect) + +Dim sSelector As String ' Return value +Dim vPropertyValues As Variant ' Array of com.sun.star.beans.PropertyValue +Dim oSelection As Object ' The current selection before opening the selector +Dim oAddress As Object ' Preselected address as _Address + +Const cstThisSub = "SFDocuments.Calc.OpenRangeSelector" +Const cstSubArgs = "[Title=""""], [Selection=""~""], [SingleCell=False], [CloseAfterSelect=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSelector = "" + +Check: + If IsMissing(Title) Or IsEmpty(Title) Then Title = "" + If IsMissing(Selection) Or IsEmpty(Selection) Then Selection = "~" + If IsMissing(SingleCell) Or IsEmpty(SingleCell) Then SingleCell = False + If IsMissing(CloseAfterSelect) Or IsEmpty(CloseAfterSelect) Then CloseAfterSelect = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Title, "Title", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Selection, "Selection", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SingleCell, "SingleCell", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(CloseAfterSelect, "CloseAfterSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + ' Save the current selections + Set oSelection = _Component.CurrentController.getSelection() + + ' Process preselection and select its containing sheet + Set oAddress = _ParseAddress(Selection) + Activate(oAddress.SheetName) + + ' Build arguments array and execute the dialog box + With ScriptForge.SF_Utils + vPropertyValues = Array( _ + ._MakePropertyValue("Title", Title) _ + , ._MakePropertyValue("CloseOnMouseRelease", CloseAfterSelect) _ + , ._MakePropertyValue("InitialValue", oAddress.XCellRange.AbsoluteName) _ + , ._MakePropertyValue("SingleCellMode", SingleCell) _ + ) + End With + sSelector = SF_DocumentListener.RunRangeSelector(_Component, vPropertyValues) + + ' Restore the saved selections + _RestoreSelections(_Component, oSelection) + +Finally: + OpenRangeSelector = sSelector + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.OpenRangeSelector + +REM ----------------------------------------------------------------------------- +Public Function Printf(Optional ByVal InputStr As Variant _ + , Optional ByVal Range As Variant _ + , Optional ByVal TokenCharacter As Variant _ + ) As String +''' Returns the input string after substitution of its tokens by +''' their values in the given range +''' This method is usually used in combination with SetFormula() +''' The accepted tokens are: +''' - %S The sheet name containing the range, including single quotes when necessary +''' - %R1 The row number of the topleft part of the range +''' - %C1 The column letter of the topleft part of the range +''' - %R2 The row number of the bottomright part of the range +''' - %C2 The column letter of the bottomright part of the range +''' Args: +''' InputStr: usually a Calc formula or a part of a formula, but may be any string +''' Range: the range, as a string from which the values of the tokens are derived +''' TokenCharacter: the character identifying tokens. Default = "%". +''' Double the TokenCharacter to not consider it as a token. +''' Returns: +''' The input string after substitution of the contained tokens +''' Exceptions: +''' Examples: +''' Assume we have in A1:E10 a matrix of numbers. To obtain the sum by row in F1:F10 ... +''' Dim range As String, formula As String +''' range = "$A$1:$E$10") +''' formula = "=SUM($%C1%R1:$%C2%R1)" ' "=SUM($A1:$E1)", note the relative references +''' oDoc.SetFormula("$F$1:$F$10", formula) +''' 'F1 will contain =Sum($A1:$E1) +''' 'F2 =Sum($A2:$E2) +''' ' ... + +Dim sPrintf As String ' Return value +Dim vSubstitute As Variants ' Array of strings representing the token values +Dim oAddress As Object ' A range as an _Address object +Dim sSheetName As String ' The %S token value +Dim sC1 As String ' The %C1 token value +Dim sR1 As String ' The %R1 token value +Dim sC2 As String ' The %C2 token value +Dim sR2 As String ' The %R2 token value +Dim i As Long +Const cstPseudoToken = "@#@" + +Const cstThisSub = "SFDocuments.Calc.Printf" +Const cstSubArgs = "InputStr, Range, TokenCharacter=""%""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sPrintf = "" + +Check: + If IsMissing(TokenCharacter) Or IsEmpty(TokenCharacter) Then TokenCharacter = "%" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TokenCharacter, "TokenCharacter", V_STRING) Then GoTo Finally + End If + +Try: + ' Define the token values + Set oAddress = _ParseAddress(Range) + With oAddress.XCellRange + sC1 = _GetColumnName(.RangeAddress.StartColumn + 1) + sR1 = CStr(.RangeAddress.StartRow + 1) + sC2 = _GetColumnName(.RangeAddress.EndColumn + 1) + sR2 = CStr(.RangeAddress.EndRow + 1) + sSheetName = _QuoteSheetName(oAddress.XSpreadsheet.Name) + End With + + ' Substitute tokens by their values + sPrintf = ScriptForge.SF_String.ReplaceStr(InputStr _ + , Array(TokenCharacter & TokenCharacter _ + , TokenCharacter & "R1" _ + , TokenCharacter & "C1" _ + , TokenCharacter & "R2" _ + , TokenCharacter & "C2" _ + , TokenCharacter & "S" _ + , cstPseudoToken _ + ) _ + , Array(cstPseudoToken _ + , sR1 _ + , sC1 _ + , sR2 _ + , sC2 _ + , sSheetName _ + , TokenCharacter _ + ) _ + ) + +Finally: + Printf = sPrintf + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.Printf + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal SheetName As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + ) As Boolean +''' Send the content of the given sheet to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' Args: +''' SheetName: the sheet to print. Default = the active sheet +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("SheetX", "1-4;10;15-18", Copies := 2) + +Dim bPrint As Boolean ' Return value +Dim oSheet As Object ' SheetName as a reference + +Const cstThisSub = "SFDocuments.Calc.PrintOut" +Const cstSubArgs = "[SheetName=""~""], [Pages=""""], [Copies=1]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "" + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True, True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + If SheetName = "~" Then SheetName = "" + ' Make given sheet active + If Len(SheetName) > 0 Then + With _Component + Set oSheet = .getSheets.getByName(SheetName) + Set .CurrentController.ActiveSheet = oSheet + End With + End If + + bPrint = [_Super].PrintOut(Pages, Copies, _Component) + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Calc class as an array + + Properties = Array( _ + "CurrentSelection" _ + , "CustomProperties" _ + , "Description" _ + , "DocumentProperties" _ + , "DocumentType" _ + , "ExportFilters" _ + , "FirstCell" _ + , "FirstColumn" _ + , "FirstRow" _ + , "Height" _ + , "ImportFilters" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw" _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "Keywords" _ + , "LastCell" _ + , "LastColumn" _ + , "LastRow" _ + , "Range" _ + , "Readonly" _ + , "Region" _ + , "Sheet" _ + , "SheetName" _ + , "Sheets" _ + , "Subject" _ + , "Title" _ + , "Width" _ + , "XCellRange" _ + , "XComponent" _ + , "XSheetCellCursor" _ + , "XSpreadsheet" _ + ) + +End Function ' SFDocuments.SF_Calc.Properties + +REM ----------------------------------------------------------------------------- +Public Function RemoveSheet(Optional ByVal SheetName As Variant) As Boolean +''' Remove an existing sheet from the document +''' Args: +''' SheetName: The name of the sheet to remove +''' Returns: +''' True if the sheet could be removed successfully +''' Examples: +''' oDoc.RemoveSheet("SheetX") + +Dim bRemove As Boolean ' Return value +Const cstThisSub = "SFDocuments.Calc.RemoveSheet" +Const cstSubArgs = "SheetName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRemove = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + End If + +Try: + _Component.getSheets.RemoveByName(SheetName) + bRemove = True + +Finally: + RemoveSheet = bRemove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.RemoveSheet + +REM ----------------------------------------------------------------------------- +Public Function RenameSheet(Optional ByVal SheetName As Variant _ + , Optional ByVal NewName As Variant _ + ) As Boolean +''' Rename a specified sheet +''' Args: +''' SheetName: The name of the sheet to rename +''' NewName: Must not exist +''' Returns: +''' True if the sheet could be renamed successfully +''' Exceptions: +''' DUPLICATESHEETERROR A sheet with the given name exists already +''' Examples: +''' oDoc.RenameSheet("SheetX", "SheetY") + +Dim bRename As Boolean ' Return value +Const cstThisSub = "SFDocuments.Calc.RenameSheet" +Const cstSubArgs = "SheetName, NewName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRename = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally + End If + +Try: + _Component.getSheets.getByName(SheetName).setName(NewName) + bRename = True + +Finally: + RenameSheet = bRename + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.RenameSheet + +REM ----------------------------------------------------------------------------- +Public Function SetArray(Optional ByVal TargetCell As Variant _ + , Optional ByRef Value As Variant _ + ) As String +''' Set the given (array of) values starting from the target cell +''' The updated area expands itself from the target cell or from the top-left corner of the given range +''' as far as determined by the size of the input Value. +''' Vectors are always expanded vertically +''' Args: +''' TargetCell : the cell or the range as a string that should receive a new value +''' Value: a scalar, a vector or an array with the new values +''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell +''' Returns: +''' A string representing the updated range +''' Exceptions: +''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries +''' Examples: +''' oDoc.SetArray("SheetX.A1", SF_Array.RangeInit(1, 1000)) + +Dim sSet As String ' Return value +Dim oSet As Object ' _Address alias of sSet +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.SetArray" +Const cstSubArgs = "TargetCell, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally + If IsArray(Value) Then + If Not ScriptForge.SF_Utils._ValidateArray(Value, "Value") Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(Value, "Value") Then GoTo Finally + End If + End If + +Try: + ' Convert argument to data array and derive new range from its size + vDataArray = _ConvertToDataArray(Value) + If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally + Set oSet = _Offset(TargetCell, 0, 0, plHeight := UBound(vDataArray) + 1, plWidth := UBound(vDataArray(0)) + 1) ' +1 : vDataArray is zero-based + With oSet + .XCellRange.setDataArray(vDataArray) + sSet = .RangeName + End With + +Finally: + SetArray = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetArray + +REM ----------------------------------------------------------------------------- +Public Function SetCellStyle(Optional ByVal TargetRange As Variant _ + , Optional ByVal Style As Variant _ + ) As String +''' Apply the given cell style in the given range +''' The full range is updated and the remainder of the sheet is left untouched +''' If the cell style does not exist, an error is raised +''' Args: +''' TargetRange : the range as a string that should receive a new cell style +''' Style: the style name as a string +''' Returns: +''' A string representing the updated range +''' Examples: +''' oDoc.SetCellStyle("A1:F1", "Heading 2") + +Dim sSet As String ' Return value +Dim oAddress As _Address ' Alias of TargetRange +Dim oStyleFamilies As Object ' com.sun.star.container.XNameAccess +Dim vStyles As Variant ' Array of existing cell styles +Const cstStyle = "CellStyles" +Const cstThisSub = "SFDocuments.Calc.SetCellStyle" +Const cstSubArgs = "TargetRange, Style" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally + Set oStyleFamilies = _Component.StyleFamilies + If oStyleFamilies.hasByName(cstStyle) Then vStyles = oStyleFamilies.getByName(cstStyle).getElementNames() Else vStyles = Array() + If Not ScriptForge.SF_Utils._Validate(Style, "Style", V_STRING, vStyles) Then GoTo Finally + End If + +Try: + Set oAddress = _ParseAddress(TargetRange) + With oAddress + .XCellRange.CellStyle = Style + sSet = .RangeName + End With + +Finally: + SetCellStyle = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetCellStyle + +REM ----------------------------------------------------------------------------- +Public Function SetFormula(Optional ByVal TargetRange As Variant _ + , Optional ByRef Formula As Variant _ + ) As String +''' Set the given (array of) formulae in the given range +''' The full range is updated and the remainder of the sheet is left untouched +''' If the given formula is a string: +''' the unique formula is pasted across the whole range with adjustment of the relative references +''' Otherwise +''' If the size of Formula < the size of Range, then the other cells are emptied +''' If the size of Formula > the size of Range, then Formula is only partially copied +''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row +''' Args: +''' TargetRange : the range as a string that should receive a new Formula +''' Formula: a scalar, a vector or an array with the new formula(e) as strings for each cell of the range. +''' Returns: +''' A string representing the updated range +''' Examples: +''' oDoc.SetFormula("A1", "=A2") +''' oDoc.SetFormula("A1:F1", Array("=A2", "=B2", "=C2+10")) ' Horizontal vector, partially empty +''' oDoc.SetFormula("A1:D2", "=E1") ' D2 contains the formula "=H2" + +Dim sSet As String ' Return value.XSpreadsheet.Name) +Dim oAddress As Object ' Alias of TargetRange +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.SetFormula" +Const cstSubArgs = "TargetRange, Formula" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally + If IsArray(Formula) Then + If Not ScriptForge.SF_Utils._ValidateArray(Formula, "Formula", 0, V_STRING) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(Formula, "Formula", V_STRING) Then GoTo Finally + End If + End If + +Try: + Set oAddress = _ParseAddress(TargetRange) + With oAddress + If IsArray(Formula) Then + ' Convert to data array and limit its size to the size of the initial range + vDataArray = _ConvertToDataArray(Formula, .Height - 1, .Width - 1) + If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally + .XCellRange.setFormulaArray(vDataArray) + Else + With .XCellRange + ' Store formula in top-left cell and paste it along the whole range + .getCellByPosition(0, 0).setFormula(Formula) + .fillSeries(com.sun.star.sheet.FillDirection.TO_BOTTOM, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0) + .fillSeries(com.sun.star.sheet.FillDirection.TO_RIGHT, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0) + End With + End If + sSet = .RangeName + End With + +Finally: + SetFormula = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetFormula + +REM ----------------------------------------------------------------------------- +Private Function SetProperty(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Calc.set" & psProperty + If IsMissing(pvValue) Then pvValue = Empty + 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("CurrentSelection") + CurrentSelection = pvValue + Case UCase("CustomProperties") + CustomProperties = pvValue + Case UCase("Description") + Description = pvValue + Case UCase("Keywords") + Keywords = pvValue + Case UCase("Subject") + Subject = pvValue + Case UCase("Title") + Title = pvValue + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SetValue(Optional ByVal TargetRange As Variant _ + , Optional ByRef Value As Variant _ + ) As String +''' Set the given value in the given range +''' The full range is updated and the remainder of the sheet is left untouched +''' If the size of Value < the size of Range, then the other cells are emptied +''' If the size of Value > the size of Range, then Value is only partially copied +''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row +''' Args: +''' TargetRange : the range as a string that should receive a new value +''' Value: a scalar, a vector or an array with the new values for each cell o.XSpreadsheet.Name)f the range. +''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell +''' Returns: +''' A string representing the updated range +''' Examples: +''' oDoc.SetValue("A1", 2) +''' oDoc.SetValue("A1:F1", Array(1, 2, 3)) ' Horizontal vector, partially empty +''' oDoc.SetValue("A1:D2", SF_Array.AppendRow(Array(1, 2, 3, 4), Array(5, 6, 7, 8))) + +Dim sSet As String ' Return value +Dim oAddress As Object ' Alias of TargetRange +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.SetValue" +Const cstSubArgs = "TargetRange, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally + If IsArray(Value) Then + If Not ScriptForge.SF_Utils._ValidateArray(Value, "Value") Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(Value, "Value") Then GoTo Finally + End If + End If + +Try: + Set oAddress = _ParseAddress(TargetRange) + With oAddress + ' Convert to data array and limit its size to the size of the initial range + vDataArray = _ConvertToDataArray(Value, .Height - 1, .Width - 1) + If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally + .XCellRange.setDataArray(vDataArray) + sSet = .RangeName + End With + +Finally: + SetValue = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetValue + +REM ----------------------------------------------------------------------------- +Public Function ShiftDown(Optional ByVal Range As Variant _ + , Optional ByVal WholeRow As Variant _ + , Optional ByVal Rows As Variant _ + ) As String +''' Move a specified range and all cells below in the same columns downwards by inserting empty cells +''' The inserted cells can span whole rows or be limited to the width of the range +''' The height of the inserted area is provided by the Rows argument +''' Nothing happens if the range shift crosses one of the edges of the worksheet +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range above which cells have to be inserted, as a string +''' WholeRow: when True (default = False), insert whole rows +''' Rows: the height of the area to insert. Default = the height of the Range argument +''' Returns: +''' A string representing the new location of the initial range +''' Examples: +''' newrange = oDoc.ShiftDown("SheetX.A1:F10") ' "$SheetX.$A$11:$F$20" +''' newrange = oDoc.ShiftDown("SheetX.A1:F10", Rows := 3) ' "$SheetX.$A$4:$F$13" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lHeight As Long ' Range height +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftDown" +Const cstSubArgs = "Range, [WholeRow=False], [Rows]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False + If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Manage the height of the area to shift + ' The insertCells() method inserts a number of rows equal to the height of the cell range to shift + lHeight = .Height + If Rows <= 0 Then Rows = lHeight + If _LastCell(.XSpreadsheet)(1) + Rows > MAXROWS Then GoTo Catch + If Rows <> lHeight Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, Rows, 0).XCellRange.RangeAddress + Else + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the shift mode + With com.sun.star.sheet.CellInsertMode + If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .DOWN + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.insertCells(oShiftAddress, lShiftMode) + + ' Determine the receiving area + sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftDown = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftDown + +REM ----------------------------------------------------------------------------- +Public Function ShiftLeft(Optional ByVal Range As Variant _ + , Optional ByVal WholeColumn As Variant _ + , Optional ByVal Columns As Variant _ + ) As String +''' Delete the leftmost columns of a specified range and move all cells at their right leftwards +''' The deleted cells can span whole columns or be limited to the height of the range +''' The width of the deleted area is provided by the Columns argument +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeColumn: when True (default = False), erase whole columns +''' Columns: the width of the area to delete. +''' Default = the width of the Range argument, it is also its maximum value +''' Returns: +''' A string representing the location of the remaining part of the initial range, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.ShiftLeft("SheetX.G1:L10") ' """ +''' newrange = oDoc.ShiftLeft("SheetX.G1:L10", Columns := 3) ' "$SheetX.$G$1:$I$10" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lWidth As Long ' Range width +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftLeft" +Const cstSubArgs = "Range, [WholeColumn=False], [Columns]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False + If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time + + With oSourceAddress + + ' Manage the width of the area to delete + ' The removeRange() method erases a number of columns equal to the width of the cell range to delete + lWidth = .Width + If Columns <= 0 Then Columns = lWidth + If Columns < lWidth Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, 0, Columns).XCellRange.RangeAddress + Else ' Columns is capped at the range width + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the Delete mode + With com.sun.star.sheet.CellDeleteMode + If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .LEFT + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.removeRange(oShiftAddress, lShiftMode) + + ' Determine the remaining area + If Columns < lWidth Then sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftLeft = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftLeft + +REM ----------------------------------------------------------------------------- +Public Function ShiftRight(Optional ByVal Range As Variant _ + , Optional ByVal WholeColumn As Variant _ + , Optional ByVal Columns As Variant _ + ) As String +''' Move a specified range and all next cells in the same rows to the right by inserting empty cells +''' The inserted cells can span whole columns or be limited to the height of the range +''' The width of the inserted area is provided by the Columns argument +''' Nothing happens if the range shift crosses one of the edges of the worksheet +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range before which cells have to be inserted, as a string +''' WholeColumn: when True (default = False), insert whole columns +''' Columns: the width of the area to insert. Default = the width of the Range argument +''' Returns: +''' A string representing the new location of the initial range +''' Examples: +''' newrange = oDoc.ShiftRight("SheetX.A1:F10") ' "$SheetX.$G$1:$L$10" +''' newrange = oDoc.ShiftRight("SheetX.A1:F10", Columns := 3) ' "$SheetX.$D$1:$I$10" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lWidth As Long ' Range width +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftRight" +Const cstSubArgs = "Range, [WholeColumn=False], [Columns]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False + If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Manage the width of the area to Shift + ' The insertCells() method inserts a number of columns equal to the width of the cell range to Shift + lWidth = .Width + If Columns <= 0 Then Columns = lWidth + If _LastCell(.XSpreadsheet)(0) + Columns > MAXCOLS Then GoTo Catch + If Columns <> lWidth Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, 0, Columns).XCellRange.RangeAddress + Else + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the Shift mode + With com.sun.star.sheet.CellInsertMode + If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .RIGHT + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.insertCells(oShiftAddress, lShiftMode) + + ' Determine the receiving area + sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftRight = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftRight + +REM ----------------------------------------------------------------------------- +Public Function ShiftUp(Optional ByVal Range As Variant _ + , Optional ByVal WholeRow As Variant _ + , Optional ByVal Rows As Variant _ + ) As String +''' Delete the topmost rows of a specified range and move all cells below upwards +''' The deleted cells can span whole rows or be limited to the width of the range +''' The height of the deleted area is provided by the Rows argument +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeRow: when True (default = False), erase whole rows +''' Rows: the height of the area to delete. +''' Default = the height of the Range argument, it is also its maximum value +''' Returns: +''' A string representing the location of the remaining part of the initial range, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.ShiftUp("SheetX.G1:L10") ' "" +''' newrange = oDoc.ShiftUp("SheetX.G1:L10", Rows := 3) ' "$SheetX.$G$1:$I$10" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lHeight As Long ' Range height +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right height +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftUp" +Const cstSubArgs = "Range, [WholeRow=False], [Rows]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False + If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time + + With oSourceAddress + + ' Manage the height of the area to delete + ' The removeRange() method erases a number of rows equal to the height of the cell range to delete + lHeight = .Height + If Rows <= 0 Then Rows = lHeight + If Rows < lHeight Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, Rows, 0).XCellRange.RangeAddress + Else ' Rows is capped at the range height + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the Delete mode + With com.sun.star.sheet.CellDeleteMode + If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .UP + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.removeRange(oShiftAddress, lShiftMode) + + ' Determine the remaining area + If Rows < lHeight Then sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftUp = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftUp + +REM ----------------------------------------------------------------------------- +Public Function SortRange(Optional ByVal Range As Variant _ + , Optional ByVal SortKeys As Variant _ + , Optional ByVal SortOrder As Variant _ + , Optional ByVal DestinationCell As Variant _ + , Optional ByVal ContainsHeader As Variant _ + , Optional ByVal CaseSensitive As Variant _ + , Optional ByVal SortColumns As Variant _ + ) As Variant +''' Sort the given range on maximum 3 columns/rows. The sorting order may vary by column/row +''' Args: +''' Range: the range to sort as a string +''' SortKeys: a scalar (if 1 column/row) or an array of column/row numbers starting from 1 +''' SortOrder: a scalar or an array of strings: "ASC" or "DESC" +''' Each item is paired with the corresponding item in SortKeys +''' If the SortOrder array is shorter than SortKeys, the remaining keys are sorted +''' in ascending order +''' DestinationCell: the destination of the sorted range of cells, as a string +''' If given as range, the destination will be reduced to its top-left cell +''' By default, Range is overwritten with its sorted content +''' ContainsHeader: when True, the first row/column is not sorted. Default = False +''' CaseSensitive: only for string comparisons, default = False +''' SortColumns: when True, the columns are sorted from left to right +''' Default = False: rows are sorted from top to bottom. +''' Returns: +''' The modified range of cells as a string +''' Example: +''' oDoc.SortRange("A2:J200", Array(1, 3), , Array("ASC", "DESC"), CaseSensitive := True) +''' ' Sort on columns A (ascending) and C (descending) + +Dim sSort As String ' Return value +Dim oRangeAddress As _Address ' Parsed range +Dim oRange As Object ' com.sun.star.table.XCellRange +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim vSortDescriptor As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vSortFields As Variant ' Array of com.sun.star.table.TableSortField +Dim sOrder As String ' Item in SortOrder +Dim i As Long +Const cstThisSub = "SFDocuments.Calc.SortRange" +Const cstSubArgs = "Range, SortKeys, [TargetRange=""""], [SortOrder=""ASC""], [DestinationCell=""""], [ContainsHeader=False], [CaseSensitive=False], [SortColumns=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSort = "" + +Check: + If IsMissing(SortKeys) Or IsEmpty(SortKeys) Then + SortKeys = Array(1) + ElseIf Not IsArray(SortKeys) Then + SortKeys = Array(SortKeys) + End If + If IsMissing(DestinationCell) Or IsEmpty(DestinationCell) Then DestinationCell = "" + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then + SortOrder = Array("ASC") + ElseIf Not IsArray(SortOrder) Then + SortOrder = Array(SortOrder) + End If + If IsMissing(ContainsHeader) Or IsEmpty(ContainsHeader) Then ContainsHeader = False + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If IsMissing(SortColumns) Or IsEmpty(SortColumns) Then SortColumns = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateArray(SortKeys, "SortKeys", 1, V_NUMERIC, True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateArray(SortOrder, "SortOrder", 1, V_STRING, True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ContainsHeader, "ContainsHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SortColumns, "SortColumns", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + Set oRangeAddress = _ParseAddress(Range) + If Len(DestinationCell) > 0 Then Set oDestRange = _ParseAddress(DestinationCell) + +Try: + ' Initialize the sort descriptor + Set oRange = oRangeAddress.XCellRange + vSortDescriptor = oRange.createSortDescriptor + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsSortColumns", SortColumns) + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "ContainsHeader", ContainsHeader) + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "BindFormatsToContent", True) + If Len(DestinationCell) = 0 Then + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", False) + Else + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = New com.sun.star.table.CellAddress + With oDestAddress + oDestCell.Sheet = .Sheet + oDestCell.Column = .StartColumn + oDestCell.Row = .StartRow + End With + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", True) + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", oDestCell) + End If + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsUserListEnabled", False) + + ' Define the sorting keys + vSortFields = Array() + ReDim vSortFields(0 To UBound(SortKeys)) + For i = 0 To UBound(SortKeys) + vSortFields(i) = New com.sun.star.table.TableSortField + If i > UBound(SortOrder) Then sOrder = "" Else sOrder = SortOrder(i) + If Len(sOrder) = 0 Then sOrder = "ASC" + With vSortFields(i) + .Field = SortKeys(i) - 1 + .IsAscending = ( UCase(sOrder) = "ASC" ) + .IsCaseSensitive = CaseSensitive + End With + Next i + + ' Associate the keys and the descriptor, and sort + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "SortFields", vSortFields) + oRange.sort(vSortDescriptor) + + ' Compute the changed area + If Len(DestinationCell) = 0 Then + sSort = oRangeAddress.RangeName + Else + With oRangeAddress + sSort = _Offset(oDestRange, 0, 0, .Height, .Width).RangeName + End With + End If + +Finally: + SortRange = sSort + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SortRange + +REM ======================================================= SUPERCLASS PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CustomProperties() As Variant + CustomProperties = [_Super].GetProperty("CustomProperties") +End Property ' SFDocuments.SF_Calc.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) + [_Super].CustomProperties = pvCustomProperties +End Property ' SFDocuments.SF_Calc.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant + Description = [_Super].GetProperty("Description") +End Property ' SFDocuments.SF_Calc.Description + +REM ----------------------------------------------------------------------------- +Property Let Description(Optional ByVal pvDescription As Variant) + [_Super].Description = pvDescription +End Property ' SFDocuments.SF_Calc.Description + +REM ----------------------------------------------------------------------------- +Property Get DocumentProperties() As Variant + DocumentProperties = [_Super].GetProperty("DocumentProperties") +End Property ' SFDocuments.SF_Calc.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String + DocumentType = [_Super].GetProperty("DocumentType") +End Property ' SFDocuments.SF_Calc.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get ExportFilters() As Variant + ExportFilters = [_Super].GetProperty("ExportFilters") +End Property ' SFDocuments.SF_Calc.ExportFilters + +REM ----------------------------------------------------------------------------- +Property Get ImportFilters() As Variant + ImportFilters = [_Super].GetProperty("ImportFilters") +End Property ' SFDocuments.SF_Calc.ImportFilters + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = [_Super].GetProperty("IsBase") +End Property ' SFDocuments.SF_Calc.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = [_Super].GetProperty("IsCalc") +End Property ' SFDocuments.SF_Calc.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = [_Super].GetProperty("IsDraw") +End Property ' SFDocuments.SF_Calc.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = [_Super].GetProperty("IsImpress") +End Property ' SFDocuments.SF_Calc.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = [_Super].GetProperty("IsMath") +End Property ' SFDocuments.SF_Calc.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = [_Super].GetProperty("IsWriter") +End Property ' SFDocuments.SF_Calc.IsWriter + +REM ----------------------------------------------------------------------------- +Property Get Keywords() As Variant + Keywords = [_Super].GetProperty("Keywords") +End Property ' SFDocuments.SF_Calc.Keywords + +REM ----------------------------------------------------------------------------- +Property Let Keywords(Optional ByVal pvKeywords As Variant) + [_Super].Keywords = pvKeywords +End Property ' SFDocuments.SF_Calc.Keywords + +REM ----------------------------------------------------------------------------- +Property Get Readonly() As Variant + Readonly = [_Super].GetProperty("Readonly") +End Property ' SFDocuments.SF_Calc.Readonly + +REM ----------------------------------------------------------------------------- +Property Get Subject() As Variant + Subject = [_Super].GetProperty("Subject") +End Property ' SFDocuments.SF_Calc.Subject + +REM ----------------------------------------------------------------------------- +Property Let Subject(Optional ByVal pvSubject As Variant) + [_Super].Subject = pvSubject +End Property ' SFDocuments.SF_Calc.Subject + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant + Title = [_Super].GetProperty("Title") +End Property ' SFDocuments.SF_Calc.Title + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) + [_Super].Title = pvTitle +End Property ' SFDocuments.SF_Calc.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant + XComponent = [_Super].GetProperty("XComponent") +End Property ' SFDocuments.SF_Calc.XComponent + +REM ========================================================== SUPERCLASS METHODS + +REM ----------------------------------------------------------------------------- +'Public Function Activate() As Boolean +' Activate = [_Super].Activate() +'End Function ' SFDocuments.SF_Calc.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean + CloseDocument = [_Super].CloseDocument(SaveAsk) +End Function ' SFDocuments.SF_Calc.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object + Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) +End Function ' SFDocuments.SF_Calc.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function ExportAsPDF(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal Watermark As Variant _ + ) As Boolean + ExportAsPDF = [_Super].ExportAsPDF(FileName, Overwrite, Pages, Password, Watermark) +End Function ' SFDocuments.SF_Calc.ExportAsPDF + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean + RemoveMenu = [_Super].RemoveMenu(MenuHeader) +End Function ' SFDocuments.SF_Calc.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) + [_Super].RunCommand(Command, Args) +End Sub ' SFDocuments.SF_Calc.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean + Save = [_Super].Save() +End Function ' SFDocuments.SF_Calc.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Calc.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Calc.SaveCopyAs + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + ) As Boolean + SetPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat) +End Function ' SFDocuments.SF_Calc.SetPrinter + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _ConvertFromDataArray(ByRef pvDataArray As Variant) As Variant +''' Convert a data array to a scalar, a vector or a 2D array +''' Args: +''' pvDataArray: an array as returned by the XCellRange.getDataArray or .getFormulaArray methods +''' Returns: +''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and/or doubles +''' To convert doubles to dates, use the CDate builtin function + +Dim vArray As Variant ' Return value +Dim lMax1 As Long ' UBound of pvDataArray +Dim lMax2 As Long ' UBound of pvDataArray items +Dim i As Long +Dim j As Long + + vArray = Empty + +Try: + ' Convert the data array to scalar, vector or array + lMax1 = UBound(pvDataArray) + If lMax1 >= 0 Then + lMax2 = UBound(pvDataArray(0)) + If lMax2 >= 0 Then + If lMax1 + lMax2 > 0 Then vArray = Array() + Select Case True + Case lMax1 = 0 And lMax2 = 0 ' Scalar + vArray = pvDataArray(0)(0) + Case lMax1 > 0 And lMax2 = 0 ' Vertical vector + ReDim vArray(0 To lMax1) + For i = 0 To lMax1 + vArray(i) = pvDataArray(i)(0) + Next i + Case lMax1 = 0 And lMax2 > 0 ' Horizontal vector + ReDim vArray(0 To lMax2) + For j = 0 To lMax2 + vArray(j) = pvDataArray(0)(j) + Next j + Case Else ' Array + ReDim vArray(0 To lMax1, 0 To lMax2) + For i = 0 To lMax1 + For j = 0 To lMax2 + vArray(i, j) = pvDataArray(i)(j) + Next j + Next i + End Select + End If + End If + +Finally: + _ConvertFromDataArray = vArray +End Function ' SF_Documents.SF_Calc._ConvertFromDataArray + +REM ----------------------------------------------------------------------------- +Private Function _ConvertToCellValue(ByVal pvItem As Variant) As Variant +''' Convert the argument to a valid Calc cell content + +Dim vCell As Variant ' Return value + +Try: + Select Case ScriptForge.SF_Utils._VarTypeExt(pvItem) + Case V_STRING : vCell = pvItem + Case V_DATE : vCell = CDbl(pvItem) + Case ScriptForge.V_NUMERIC : vCell = CDbl(pvItem) + Case ScriptForge.V_BOOLEAN : vCell = CDbl(Iif(pvItem, 1, 0)) + Case Else : vCell = "" + End Select + +Finally: + _ConvertToCellValue = vCell + Exit Function +End Function ' SF_Documents.SF_Calc._ConvertToCellValue + +REM ----------------------------------------------------------------------------- +Private Function _ConvertToDataArray(ByRef pvArray As Variant _ + , Optional ByVal plRows As Long _ + , Optional ByVal plColumns As Long _ + ) As Variant +''' Create a 2-dimensions nested array (compatible with the ranges .DataArray property) +''' from a scalar, a 1D array or a 2D array +''' Input may be a 1D array of arrays, typically when call issued by a Python script +''' Array items are converted to (possibly empty) strings or doubles +''' Args: +''' pvArray: the input scalar or array. If array, must be 1 or 2D otherwise it is ignored. +''' plRows, plColumns: the upper bounds of the data array +''' If bigger than input array, fill with zero-length strings +''' If smaller than input array, truncate +''' If plRows = 0 and the input array is a vector, the data array is aligned horizontally +''' They are either both present or both absent +''' When absent +''' The size of the output is fully determined by the input array +''' Vectors are aligned vertically +''' Returns: +''' A data array compatible with ranges .DataArray property +''' The output is always an array of nested arrays + +Dim vDataArray() As Variant ' Return value +Dim vVector() As Variant ' A temporary 1D array +Dim vItem As Variant ' A single input item +Dim iDims As Integer ' Number of dimensions of the input argument +Dim lMin1 As Long ' Lower bound (1) of input array +Dim lMax1 As Long ' Upper bound (1) +Dim lMin2 As Long ' Lower bound (2) +Dim lMax2 As Long ' Upper bound (2) +Dim lRows As Long ' Upper bound of vDataArray +Dim lCols As Long ' Upper bound of vVector +Dim bHorizontal As Boolean ' Horizontal vector +Dim bDataArray As Boolean ' Input array is already an array of arrays +Dim i As Long +Dim j As Long + +Const cstEmpty = "" ' Empty cell + + If IsMissing(plRows) Or IsEmpty(plRows) Then plRows = -1 + If IsMissing(plColumns) Or IsEmpty(plColumns) Then plColumns = -1 + + vDataArray = Array() + +Try: + ' Check the input argument and know its boundaries + iDims = ScriptForge.SF_Array.CountDims(pvArray) + If iDims = 0 Or iDims > 2 Then Exit Function + lMin1 = 0 : lMax1 = 0 ' Default values + lMin2 = 0 : lMax2 = 0 + Select Case iDims + Case -1 ' Scalar value + Case 1 + bHorizontal = ( plRows = 0 And plColumns > 0 ) + bDataArray = IsArray(pvArray(0)) + If Not bDataArray Then + If Not bHorizontal Then + lMin1 = LBound(pvArray) : lMax1 = UBound(pvArray) + Else + lMin2 = LBound(pvArray) : lMax2 = UBound(pvArray) + End If + Else + iDims = 2 + lMin1 = LBound(pvArray) : lMax1 = UBound(pvArray) + lMin2 = LBound(pvArray(0)) : lMax2 = UBound(pvArray(0)) + End If + Case 2 + lMin1 = LBound(pvArray, 1) : lMax1 = UBound(pvArray, 1) + lMin2 = LBound(pvArray, 2) : lMax2 = UBound(pvArray, 2) + End Select + + ' Set the output dimensions accordingly + If plRows >= 0 Then ' Dimensions of output are imposed + lRows = plRows + lCols = plColumns + Else ' Dimensions of output determined by input argument + lRows = 0 : lCols = 0 ' Default values + Select Case iDims + Case -1 ' Scalar value + Case 1 ' Vectors are aligned vertically + lRows = lMax1 - lMin1 + Case 2 + lRows = lMax1 - lMin1 + lCols = lMax2 - lMin2 + End Select + End If + ReDim vDataArray(0 To lRows) + + ' Feed the output array row by row, each row being a vector + For i = 0 To lRows + ReDim vVector(0 To lCols) + For j = 0 To lCols + If i > lMax1 - lMin1 Then + vVector(j) = cstEmpty + ElseIf j > lMax2 - lMin2 Then + vVector(j) = cstEmpty + Else + Select Case iDims + Case -1 : vItem = _ConvertToCellValue(pvArray) + Case 1 + If bHorizontal Then + vItem = _ConvertToCellValue(pvArray(j + lMin2)) + Else + vItem = _ConvertToCellValue(pvArray(i + lMin1)) + End If + Case 2 + If bDataArray Then + vItem = _ConvertToCellValue(pvArray(i + lMin1)(j + lMin2)) + Else + vItem = _ConvertToCellValue(pvArray(i + lMin1, j + lMin2)) + End If + End Select + vVector(j) = vItem + End If + vDataArray(i) = vVector + Next j + Next i + +Finally: + _ConvertToDataArray = vDataArray + Exit Function +End Function ' SF_Documents.SF_Calc._ConvertToDataArray + +REM ----------------------------------------------------------------------------- +Private Function _DFunction(ByVal psFunction As String _ + , Optional ByVal Range As Variant _ + ) As Double +''' Apply the given function on all the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to apply the function on +''' Returns: +''' The resulting value as a double + +Dim dblGet As Double ' Return value +Dim oAddress As Object ' Alias of Range +Dim vFunction As Variant ' com.sun.star.sheet.GeneralFunction.XXX +Dim cstThisSub As String : cstThisSub = "SFDocuments.Calc." & psFunction +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + dblGet = 0 + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + ' Get the data + Set oAddress = _ParseAddress(Range) + Select Case psFunction + Case "DAvg" : vFunction = com.sun.star.sheet.GeneralFunction.AVERAGE + Case "DCount" : vFunction = com.sun.star.sheet.GeneralFunction.COUNTNUMS + Case "DMax" : vFunction = com.sun.star.sheet.GeneralFunction.MAX + Case "DMin" : vFunction = com.sun.star.sheet.GeneralFunction.MIN + Case "DSum" : vFunction = com.sun.star.sheet.GeneralFunction.SUM + Case Else : GoTo Finally + End Select + dblGet = oAddress.XCellRange.computeFunction(vFunction) + +Finally: + _DFunction = dblGet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc._DFunction + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Calc._FileIdent + +REM ----------------------------------------------------------------------------- +Function _GetColumnName(ByVal plColumnNumber As Long) As String +''' Convert a column number (range 1, 2,..1024) into its letter counterpart (range 'A', 'B',..'AMJ'). +''' Args: +''' ColumnNumber: the column number, must be in the interval 1 ... 1024 +''' Returns: +''' a string representation of the column name, in range 'A'..'AMJ' +''' Adapted from a Python function by sundar nataraj +''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter + +Dim sCol As String ' Return value +Dim lDiv As Long ' Intermediate result +Dim lMod As Long ' Result of modulo 26 operation + +Try: + lDiv = plColumnNumber + Do While lDiv > 0 + lMod = (lDiv - 1) Mod 26 + sCol = Chr(65 + lMod) + sCol + lDiv = Int((lDiv - lMod)/26) + Loop + +Finally: + _GetColumnName = sCol +End Function ' SFDocuments.SF_Calc._GetColumnName + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) + +Finally: + _IsStillAlive = bAlive + Exit Function +End Function ' SFDocuments.SF_Calc._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _LastCell(ByRef poSheet As Object) As Variant +''' Returns in an array the coordinates of the last used cell in the given sheet + +Dim oCursor As Object ' Cursor on the cell +Dim oRange As Object ' The used range +Dim vCoordinates(0 To 1) As Long ' Return value: (0) = Column, (1) = Row + +Try: + Set oCursor = poSheet.createCursorByRange(poSheet.getCellRangeByName("A1")) + oCursor.gotoEndOfUsedArea(True) + Set oRange = poSheet.getCellRangeByName(oCursor.AbsoluteName) + + vCoordinates(0) = oRange.RangeAddress.EndColumn + 1 + vCoordinates(1) = oRange.RangeAddress.EndRow + 1 + +Finally: + _LastCell = vCoordinates +End Function ' SFDocuments.SF_Calc._LastCell + +REM ----------------------------------------------------------------------------- +Public Function _Offset(ByRef pvRange As Variant _ + , ByVal plRows As Long _ + , ByVal plColumns As Long _ + , ByVal plHeight As Long _ + , ByVal plWidth As Long _ + ) As Object +''' Returns a new range offset by a certain number of rows and columns from a given range +''' Args: +''' pvRange : the range, as a string or an object, from which the function searches for the new range +''' plRows : the number of rows by which the reference was corrected up (negative value) or down. +''' plColumns : the number of columns by which the reference was corrected to the left (negative value) or to the right. +''' plHeight : the vertical height for an area that starts at the new reference position. +''' plWidth : the horizontal width for an area that starts at the new reference position. +''' Arguments Rows and Columns must not lead to zero or negative start row or column. +''' Arguments Height and Width must not lead to zero or negative count of rows or columns. +''' Returns: +''' A new range as object of type _Address +''' Exceptions: +''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries + +Dim oOffset As Object ' Return value +Dim oAddress As Object ' Alias of Range +Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet +Dim oRange As Object ' com.sun.star.table.XCellRange +Dim oNewRange As Object ' com.sun.star.table.XCellRange +Dim lLeft As Long ' New range coordinates +Dim lTop As Long +Dim lRight As Long +Dim lBottom As Long + + Set oOffset = Nothing + +Check: + If plHeight < 0 Or plWidth < 0 Then GoTo CatchAddress + +Try: + If VarType(pvRange) = V_STRING Then Set oAddress = _ParseAddress(pvRange) Else Set oAddress = pvRange + Set oSheet = oAddress.XSpreadSheet + Set oRange = oAddress.XCellRange.RangeAddress + + + ' Compute and validate new coordinates + With oRange + lLeft = .StartColumn + plColumns + lTop = .StartRow + plRows + lRight = lLeft + Iif(plWidth = 0, .EndColumn - .StartColumn, plWidth - 1) + lBottom = lTop + Iif(plHeight = 0, .EndRow - .StartRow, plHeight - 1) + If lLeft < 0 Or lRight < 0 Or lTop < 0 Or lBottom < 0 _ + Or lLeft > MAXCOLS Or lRight > MAXCOLS _ + Or lTop > MAXROWS Or lBottom > MAXROWS _ + Then GoTo CatchAddress + Set oNewRange = oSheet.getCellRangeByPosition(lLeft, lTop, lRight, lBottom) + End With + + ' Define the new range address + Set oOffset = New _Address + With oOffset + .ObjectType = CALCREFERENCE + .ServiceName = SERVICEREFERENCE + .RawAddress = oNewRange.AbsoluteName + .Component = _Component + .XSpreadsheet = oNewRange.Spreadsheet + .SheetName = .XSpreadsheet.Name + .SheetIndex = .XSpreadsheet.RangeAddress.Sheet + .RangeName = .RawAddress + .XCellRange = oNewRange + .Height = oNewRange.RangeAddress.EndRow - oNewRange.RangeAddress.StartRow + 1 + .Width = oNewRange.RangeAddress.EndColumn - oNewRange.RangeAddress.StartColumn + 1 + End With + +Finally: + Set _Offset = oOffset + Exit Function +Catch: + GoTo Finally +CatchAddress: + ScriptForge.SF_Exception.RaiseFatal(OFFSETADDRESSERROR, "Range", oAddress.RawAddress _ + , "Rows", plRows, "Columns", plColumns, "Height", plHeight, "Width", plWidth _ + , "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SF_Documents.SF_Calc._Offset + +REM ----------------------------------------------------------------------------- +Private Function _ParseAddress(ByVal psAddress As String) As Object +''' Parse and validate a sheet or range reference +''' Syntax to parse: +''' [Sheet].[Range] +''' Sheet => ['][$]sheet['] or document named range or ~ +''' Range => A1:D10, A1, A:D, 10:10 ($ ignored), or sheet named range or ~ +''' Returns: +''' An object of type _Address +''' Exceptions: +''' CALCADDRESSERROR ' Address could not be parsed to a valid address + +Dim oAddress As Object ' Return value +Dim sAddress As String ' Alias of psAddress +Dim lStart As Long ' Position of found regex +Dim sSheet As String ' Sheet component +Dim sRange As String ' Range component +Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets +Dim oNamedRanges As Object ' com.sun.star.sheet.XNamedRanges +Dim oRangeAddress As Object ' Alias for rangeaddress +Dim vLastCell As Variant ' Result of _LastCell() method +Dim oSelect As Object ' Current selection + + ' If psAddress has already been parsed, get the result back + If Not IsNull(_LastParsedAddress) Then + ' Given argument must contain an explicit reference to a sheet + If (InStr(psAddress, "~.") = 0 And InStr(psAddress, ".") > 0 And psAddress = _LastParsedAddress.RawAddress) _ + Or psAddress = _LastParsedAddress.RangeName Then + Set _ParseAddress = _LastParsedAddress + Exit Function + Else + Set _LastParsedAddress = Nothing + End If + End If + + ' Reinitialize a new _Address object + Set oAddress = New _Address + With oAddress + sSheet = "" : sRange = "" + .SheetName = "" : .RangeName = "" + + .ObjectType = CALCREFERENCE + .ServiceName = SERVICEREFERENCE + .RawAddress = psAddress + Set .XSpreadSheet = Nothing : Set .XCellRange = Nothing + + ' Remove leading '$' + If Left(psAddress, 1) = "$" Then sAddress = Mid(psAddress, 2) Else sAddress = psAddress + ' Split in sheet and range components - Check presence of surrounding single quotes or dot + If Left(sAddress, 1) = "'" Then + lStart = 1 + sSheet = ScriptForge.SF_String.FindRegex(sAddress, "^'[^\[\]*?:\/\\]+'") + If lStart = 0 Then GoTo CatchAddress ' Invalid sheet name + If Len(sAddress) > Len(sSheet) + 1 Then + If Mid(sAddress, Len(sSheet) + 1, 1) = "." then sRange = Mid(sAddress, Len(sSheet) + 2) + End If + sSheet = Replace(Replace(sSheet, "$", ""), "'", "") + ElseIf InStr(sAddress, ".") > 0 Then + sSheet = Replace(Split(sAddress, ".")(0), "$", "") + sRange = Replace(Split(sAddress, ".")(1), "$", "") + Else + sSheet = sAddress + End If + + ' Resolve sheet part: either a document named range, or the active sheet or a real sheet + Set oSheets = _Component.getSheets() + Set oNamedRanges = _Component.NamedRanges + If oSheets.hasByName(sSheet) Then + ElseIf sSheet = "~" And Len(sRange) > 0 Then + sSheet = _Component.CurrentController.ActiveSheet.Name + ElseIf oNamedRanges.hasByName(sSheet) Then + .XCellRange = oNamedRanges.getByName(sSheet).ReferredCells + sSheet = oSheets.getByIndex(oNamedRanges.getByName(sSheet).ReferencePosition.Sheet).Name + Else + sRange = sSheet + sSheet = _Component.CurrentController.ActiveSheet.Name + End If + .SheetName = sSheet + .XSpreadSheet = oSheets.getByName(sSheet) + .SheetIndex = .XSpreadSheet.RangeAddress.Sheet + + ' Resolve range part - either a sheet named range or the current selection or a real range or "" + If IsNull(.XCellRange) Then + Set oNamedRanges = .XSpreadSheet.NamedRanges + If sRange = "~" Then + Set oSelect = _Component.CurrentController.getSelection() + If oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections + Set .XCellRange = oSelect.getByIndex(0) + Else + Set .XCellRange = oSelect + End If + ElseIf sRange = "*" Or sRange = "" Then + vLastCell = _LastCell(.XSpreadSheet) + sRange = "A1:" & _GetColumnName(vLastCell(0)) & CStr(vLastCell(1)) + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + ElseIf oNamedRanges.hasByName(sRange) Then + .XCellRange = oNamedRanges.getByName(sRange).ReferredCells + Else + On Local Error GoTo CatchError + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + ' If range reaches the limits of the sheets, reduce it up to the used area + Set oRangeAddress = .XCellRange.RangeAddress + If oRangeAddress.StartColumn = 0 And oRangeAddress.EndColumn = MAXCOLS - 1 Then + vLastCell = _LastCell(.XSpreadSheet) + sRange = "A" & CStr(oRangeAddress.StartRow + 1) & ":" _ + & _GetColumnName(vLastCell(0)) & CStr(oRangeAddress.EndRow + 1) + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + ElseIf oRangeAddress.StartRow = 0 And oRangeAddress.EndRow = MAXROWS - 1 Then + vLastCell = _LastCell(.XSpreadSheet) + sRange = _GetColumnName(oRangeAddress.StartColumn + 1) & "1" & ":" _ + & _GetColumnName(oRangeAddress.EndColumn + 1) & CStr(_LastCell(.XSpreadSheet)(1)) + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + End If + End If + End If + If IsNull(.XCellRange) Then GoTo CatchAddress + + Set oRangeAddress = .XCellRange.RangeAddress + .RangeName = .XCellRange.AbsoluteName + .Height = oRangeAddress.EndRow - oRangeAddress.StartRow + 1 + .Width = oRangeAddress.EndColumn - oRangeAddress.StartColumn + 1 + + ' Remember the current component in case of use outside the current instance + Set .Component = _Component + + End With + + ' Store last parsed address for reuse + Set _LastParsedAddress = oAddress + +Finally: + Set _ParseAddress = oAddress + Exit Function +CatchError: + ScriptForge.SF_Exception.Clear() +CatchAddress: + ScriptForge.SF_Exception.RaiseFatal(CALCADDRESSERROR, "Range", psAddress _ + , "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc._ParseAddress + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvArg As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim oProperties As Object ' Document or Custom properties +Dim vLastCell As Variant ' Coordinates of last used cell in a sheet +Dim oSelect As Object ' Current selection +Dim vRanges As Variant ' List of selected ranges +Dim oAddress As Object ' _Address type for range description +Dim oCursor As Object ' com.sun.star.sheet.XSheetCellCursor +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + cstThisSub = "SFDocuments.Calc.get" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case UCase(psProperty) + Case UCase("CurrentSelection") + Set oSelect = _Component.CurrentController.getSelection() + If IsNull(oSelect) Then + _PropertyGet = Array() + ElseIf oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections + vRanges = Array() + For i = 0 To oSelect.Count - 1 + vRanges = ScriptForge.SF_Array.Append(vRanges, oSelect.getByIndex(i).AbsoluteName) + Next i + _PropertyGet = vRanges + Else + _PropertyGet = oSelect.AbsoluteName + End If + Case UCase("Height") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + _PropertyGet = 0 + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + _PropertyGet = _ParseAddress(pvArg).Height + End If + Case UCase("FirstCell"), UCase("FirstRow"), UCase("FirstColumn") _ + , UCase("LastCell"), UCase("LastColumn"), UCase("LastRow") _ + , UCase("SheetName") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then ' Avoid errors when instance is watched in Basic IDE + If InStr(UCase(psProperty), "CELL") > 0 Then _PropertyGet = "" Else _PropertyGet = -1 + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set oAddress = _ParseAddress(pvArg) + With oAddress.XCellRange + Select Case UCase(psProperty) + Case UCase("FirstCell") + _PropertyGet = A1Style(.RangeAddress.StartRow + 1, .RangeAddress.StartColumn + 1, , , oAddress.XSpreadsheet.Name) + Case UCase("FirstColumn") : _PropertyGet = CLng(.RangeAddress.StartColumn + 1) + Case UCase("FirstRow") : _PropertyGet = CLng(.RangeAddress.StartRow + 1) + Case UCase("LastCell") + _PropertyGet = A1Style(.RangeAddress.EndRow + 1, .RangeAddress.EndColumn + 1, , , oAddress.XSpreadsheet.Name) + Case UCase("LastColumn") : _PropertyGet = CLng(.RangeAddress.EndColumn + 1) + Case UCase("LastRow") : _PropertyGet = CLng(.RangeAddress.EndRow + 1) + Case UCase("SheetName") : _PropertyGet = oAddress.XSpreadsheet.Name + End Select + End With + End If + Case UCase("Range") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set _PropertyGet = _ParseAddress(pvArg) + End If + Case UCase("Region") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + _PropertyGet = "" + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set oAddress = _ParseAddress(pvArg) + With oAddress + Set oCursor = .XSpreadsheet.createCursorByRange(.XCellRange) + oCursor.collapseToCurrentRegion() + _PropertyGet = oCursor.AbsoluteName + End With + End If + Case UCase("Sheet") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally + Set _PropertyGet = _ParseAddress(pvArg) + End If + Case UCase("Sheets") + _PropertyGet = _Component.getSheets.getElementNames() + Case UCase("Width") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + _PropertyGet = 0 + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + _PropertyGet = _ParseAddress(pvArg).Width + End If + Case UCase("XCellRange") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set _PropertyGet = _ParseAddress(pvArg).XCellRange + End If + Case UCase("XSheetCellCursor") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set oAddress = _ParseAddress(pvArg) + Set _PropertyGet = oAddress.XSpreadsheet.createCursorByRange(oAddress.XCellRange) + End If + Case UCase("XSpreadsheet") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally + Set _PropertyGet = _Component.getSheets.getByName(pvArg) + End If + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Calc._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _QuoteSheetName(ByVal psSheetName As String) As String +''' Return the given sheet name surrounded with single quotes +''' when required to insert the sheet name into a Calc formula +''' Enclosed single quotes are doubled +''' Args: +''' psSheetName: the name to quote +''' Returns: +''' The quoted or unchanged sheet name + +Dim sSheetName As String ' Return value +Dim i As Long + +Try: + ' Surround the sheet name with single quotes when required by the presence of single quotes + If InStr(psSheetName, "'") > 0 Then + sSheetName = "'" & Replace(psSheetName, "'", "''") & "'" + Else + ' Surround the sheet name with single quotes when required by the presence of at least one of the special characters + sSheetName = psSheetName + For i = 1 To Len(cstSPECIALCHARS) + If InStr(sSheetName, Mid(cstSPECIALCHARS, i, 1)) > 0 Then + sSheetName = "'" & sSheetName & "'" + Exit For + End If + Next i + End If + +Finally: + _QuoteSheetName = sSheetName + Exit Function +End Function ' SFDocuments.SF_Calc._QuoteSheetName + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Calc instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DOCUMENT]: Type/File" + + _Repr = "[Calc]: " & [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Calc._Repr + +REM ----------------------------------------------------------------------------- +Private Sub _RestoreSelections(ByRef pvComponent As Variant _ + , ByRef pvSelection As Variant _ + ) +''' Set the selection to a single or a multiple range +''' Does not work well when multiple selections and macro terminating in Basic IDE +''' Called by the CopyToCell and CopyToRange methods +''' Args: +''' pvComponent: should work for foreign instances as well +''' pvSelection: the stored selection done previously by Component.CurrentController.getSelection() + +Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges +Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress +Dim i As Long + +Try: + If IsArray(pvSelection) Then + Set oCellRanges = pvComponent.createInstance("com.sun.star.sheet.SheetCellRanges") + vRangeAddresses = Array() + ReDim vRangeAddresses(0 To UBound(pvSelection)) + For i = 0 To UBound(pvSelection) + vRangeAddresses(i) = pvSelection.getByIndex(i).RangeAddress + Next i + oCellRanges.addRangeAddresses(vRangeAddresses, False) + pvComponent.CurrentController.select(oCellRanges) + Else + pvComponent.CurrentController.select(pvSelection) + End If + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_Calc._RestoreSelections + +REM ----------------------------------------------------------------------------- +Private Function _ValidateSheet(Optional ByRef pvSheetName As Variant _ + , Optional ByVal psArgName As String _ + , Optional ByVal pvNew As Variant _ + , Optional ByVal pvActive As Variant _ + , Optional ByVal pvOptional as Variant _ + , Optional ByVal pvNumeric As Variant _ + , Optional ByVal pvReference As Variant _ + , Optional ByVal pvResetSheet As Variant _ + ) As Boolean +''' Sheet designation validation function similar to the SF_Utils._ValidateXXX functions +''' Args: +''' pvSheetName: string or numeric position +''' pvArgName: the name of the variable to be used in the error message +''' pvNew: if True, sheet must not exist (default = False) +''' pvActive: if True, the shortcut "~" is accepted (default = False) +''' pvOptional: if True, a zero-length string is accepted (default = False) +''' pvNumeric: if True, the sheet position is accepted (default = False) +''' pvReference: if True, a sheet reference is acceptable (default = False) +''' pvNumeric and pvReference must not both be = True +''' pvResetSheet: if True, return in pvSheetName the correct (case-sensitive) sheet name (default = False) +''' Returns +''' True if valid. SheetName is reset to current value if = "~" +''' Exceptions +''' DUPLICATESHEETERROR A sheet with the given name exists already + +Dim vSheets As Variant ' List of sheets +Dim sSheet As String ' Sheet name without single quotes +Dim lSheet As Long ' Index in list of sheets +Dim vTypes As Variant ' Array of accepted variable types +Dim bValid As Boolean ' Return value + +Check: + If IsMissing(pvNew) Or IsEmpty(pvNew) Then pvNew = False + If IsMissing(pvActive) Or IsEmpty(pvActive) Then pvActive = False + If IsMissing(pvOptional) Or IsEmpty(pvOptional) Then pvOptional = False + If IsMissing(pvNumeric) Or IsEmpty(pvNumeric) Then pvNumeric = False + If IsMissing(pvReference) Or IsEmpty(pvReference) Then pvReference = False + If IsMissing(pvResetSheet) Or IsEmpty(pvResetSheet) Then pvResetSheet = False + + ' Define the acceptable variable types + If pvNumeric Then + vTypes = Array(V_STRING, V_NUMERIC) + ElseIf pvReference Then + vTypes = Array(V_STRING, ScriptForge.V_OBJECT) + Else + vTypes = V_STRING + End If + If Not ScriptForge.SF_Utils._Validate(pvSheetName, psArgName, vTypes, , , Iif(pvReference, CALCREFERENCE, "")) Then GoTo Finally + bValid = False + +Try: + If VarType(pvSheetName) = V_STRING Then + If pvOptional And Len(pvSheetName) = 0 Then + ElseIf pvActive And pvSheetName = "~" Then + pvSheetName = _Component.CurrentController.ActiveSheet.Name + Else + vSheets = _Component.getSheets.getElementNames() + sSheet = Replace(pvSheetName, "'", "") + If pvNew Then + If ScriptForge.SF_Array.Contains(vSheets, sSheet) Then GoTo CatchDuplicate + Else + If Not ScriptForge.SF_Utils._Validate(sSheet, psArgName, V_STRING, vSheets) Then GoTo Finally + If pvResetSheet Then + lSheet = ScriptForge.SF_Array.IndexOf(vSheets, sSheet, CaseSensitive := False) + pvSheetName = vSheets(lSheet) + End If + End If + End If + End If + bValid = True + +Finally: + _ValidateSheet = bValid + Exit Function +CatchDuplicate: + ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, psArgName, pvSheetName, "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc._ValidateSheet + +REM ============================================ END OF SFDOCUMENTS.SF_CALC +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Chart.xba b/wizards/source/sfdocuments/SF_Chart.xba new file mode 100644 index 000000000..0538fb8af --- /dev/null +++ b/wizards/source/sfdocuments/SF_Chart.xba @@ -0,0 +1,814 @@ +<?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="SF_Chart" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Chart +''' ======== +''' +''' The SF_Chart module is focused on the description of chart documents +''' stored in Calc sheets. +''' With this service, many chart types and chart characteristics available +''' in the user interface can be read or modified. +''' +''' Definitions +''' Charts have 2 distinct names: +''' - an internal name, given by the LibreOffice application +''' - an optional user-defined name +''' In the scope of the ScriptForge libraries, the chart name is the name given by the user. +''' Only when there is no user name, the internal name may be used instead. +''' +''' Service invocation from the "Calc" service +''' Either make a new chart +''' calc.CreateChart(ChartName, SheetName, "SheetX.A1:C8") +''' or select an existing one +''' calc.Charts(SheetName, ChartName) +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_chart.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const CHARTEXPORTERROR = "CHARTEXPORTERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object ' Parent Calc document +Private ObjectType As String ' Must be CHART +Private ServiceName As String + +' Chart description +Private _SheetName As String ' Name of the Calc sheet containing the chart +Private _DrawIndex As Long ' Index of the chart in the sheet's draw page +Private _ChartName As String ' User name +Private _PersistentName As String ' Internal name +Private _Shape As Object ' com.sun.star.drawing.XShape +Private _Chart As Object ' com.sun.star.table.XTableChart +Private _ChartObject As Object ' com.sun.star.lang.XComponent - ScChartObj +Private _Diagram As Object ' com.sun.star.chart.XDiagram + +REM ============================================================ MODULE CONSTANTS + + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "CHART" + ServiceName = "SFDocuments.Chart" + _SheetName = "" + _DrawIndex = -1 + _ChartName = "" + _PersistentName = "" + Set _Shape = Nothing + Set _Chart = Nothing + Set _ChartObject = Nothing + Set _Diagram = Nothing +End Sub ' SFDocuments.SF_Chart Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Chart Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Chart Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ChartType() As Variant +''' The ChartType property specifies the type of chart as a string among next values: +''' Pie, Bar, Donut, Column, Area, Line, XY, Bubble, Net + ChartType = _PropertyGet("ChartType") +End Property ' SFDocuments.SF_Chart.ChartType (get) + +REM ----------------------------------------------------------------------------- +Property Let ChartType(Optional ByVal pvChartType As Variant) +''' Set the updatable property ChartType + _PropertySet("ChartType", pvChartType) +End Property ' SFDocuments.SF_Chart.ChartType (let) + +REM ----------------------------------------------------------------------------- +Property Get Deep() As Variant +''' If True, determines that in a three-dimensional bar chart the bars of each series are arranged behind each other in the z-direction. +''' If False the arrangement of bars is like in two-dimensional bar charts. +''' Bar and Column chart types only + Deep = _PropertyGet("Deep") +End Property ' SFDocuments.SF_Chart.Deep (get) + +REM ----------------------------------------------------------------------------- +Property Let Deep(Optional ByVal pvDeep As Variant) +''' Set the updatable property Deep + _PropertySet("Deep", pvDeep) +End Property ' SFDocuments.SF_Chart.Deep (let) + +REM ----------------------------------------------------------------------------- +Property Get Dim3D() As Variant +''' The Dim3D property specifies if the chart is displayed with 3D elements +''' String or Boolean +''' When String, must be 1 of next values: Bar, Cylinder, Cone or Pyramid +''' When Boolean True, Bar is assumed; when False, no 3D to be applied + Dim3D = _PropertyGet("Dim3D") +End Property ' SFDocuments.SF_Chart.Dim3D (get) + +REM ----------------------------------------------------------------------------- +Property Let Dim3D(Optional ByVal pvDim3D As Variant) +''' Set the updatable property Dim3D + _PropertySet("Dim3D", pvDim3D) +End Property ' SFDocuments.SF_Chart.Dim3D (let) + +REM ----------------------------------------------------------------------------- +Property Get Exploded() As Variant +''' the offset by which pie segments in a PieDiagram (pie or donut) are dragged outside from the center. +''' This value is given in percent of the radius. + Exploded = _PropertyGet("Exploded") +End Property ' SFDocuments.SF_Chart.Exploded (get)_ChartObject + +REM ----------------------------------------------------------------------------- +Property Let Exploded(Optional ByVal pvExploded As Variant) +''' Set the updatable property Exploded + _PropertySet("Exploded", pvExploded) +End Property ' SFDocuments.SF_Chart.Exploded (let) + +REM ----------------------------------------------------------------------------- +Property Get Filled() As Variant +''' When True, the Net diagram is said of FilledNet type +''' Net chart type only + Filled = _PropertyGet("Filled") +End Property ' SFDocuments.SF_Chart.Filled (get) + +REM ----------------------------------------------------------------------------- +Property Let Filled(Optional ByVal pvFilled As Variant) +''' Set the updatable property Filled + _PropertySet("Filled", pvFilled) +End Property ' SFDocuments.SF_Chart.Filled (let) + +REM ----------------------------------------------------------------------------- +Property Get Legend() As Variant +''' Specifies if the chart has a legend + Legend = _PropertyGet("Legend") +End Property ' SFDocuments.SF_Chart.Legend (get) + +REM ----------------------------------------------------------------------------- +Property Let Legend(Optional ByVal pvLegend As Variant) +''' Set the updatable property Legend + _PropertySet("Legend", pvLegend) +End Property ' SFDocuments.SF_Chart.Legend (let) + +REM ----------------------------------------------------------------------------- +Property Get Percent() As Variant +''' When True, the series of the diagram are stacked and each category sums up to 100%. +''' Area, Bar, Bubble, Column and Net chart types only_ChartObject + Percent = _PropertyGet("Percent") +End Property ' SFDocuments.SF_Chart.Percent (get) + +REM ----------------------------------------------------------------------------- +Property Let Percent(Optional ByVal pvPercent As Variant) +''' Set the updatable property Percent + _PropertySet("Percent", pvPercent) +End Property ' SFDocuments.SF_Chart.Percent (let) + +REM ----------------------------------------------------------------------------- +Property Get Stacked() As Variant +''' When True, the series of the diagram are stacked. +''' Area, Bar, Bubble, Column and Net chart types only + Stacked = _PropertyGet("Stacked") +End Property ' SFDocuments.SF_Chart.Stacked (get) + +REM ----------------------------------------------------------------------------- +Property Let Stacked(Optional ByVal pvStacked As Variant) +''' Set the updatable property Stacked + _PropertySet("Stacked", pvStacked) +End Property ' SFDocuments.SF_Chart.Stacked (let) + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant +''' Specifies the main title of the chart + Title = _PropertyGet("Title") +End Property ' SFDocuments.SF_Chart.Title (get) + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) +''' Set the updatable property Title + _PropertySet("Title", pvTitle) +End Property ' SFDocuments.SF_Chart.Title (let) + +REM ----------------------------------------------------------------------------- +Property Get XTitle() As Variant +''' Specifies the main XTitle of the chart + XTitle = _PropertyGet("XTitle") +End Property ' SFDocuments.SF_Chart.XTitle (get) + +REM ----------------------------------------------------------------------------- +Property Let XTitle(Optional ByVal pvXTitle As Variant) +''' Set the updatable property XTitle + _PropertySet("XTitle", pvXTitle) +End Property ' SFDocuments.SF_Chart.XTitle (let) + +REM ----------------------------------------------------------------------------- +Property Get YTitle() As Variant +''' Specifies the main YTitle of the chart + YTitle = _PropertyGet("YTitle") +End Property ' SFDocuments.SF_Chart.YTitle (get) + +REM ----------------------------------------------------------------------------- +Property Let YTitle(Optional ByVal pvYTitle As Variant) +''' Set the updatable property YTitle + _PropertySet("YTitle", pvYTitle) +End Property ' SFDocuments.SF_Chart.YTitle (let) + +REM ----------------------------------------------------------------------------- +Property Get XChartObj() As Variant +''' com.sun.star.lang.XComponent - ScChartObj + ChartType = _PropertyGet("XChartObj") +End Property ' SFDocuments.SF_Chart.XChartObj (get) + +REM ----------------------------------------------------------------------------- +Property Get XDiagram() As Variant +''' com.sun.star.chart.XDiagram + ChartType = _PropertyGet("XDiagram") +End Property ' SFDocuments.SF_Chart.XDiagram (get) + +REM ----------------------------------------------------------------------------- +Property Get XShape() As Variant +''' com.sun.star.drawing.XShape + ChartType = _PropertyGet("XShape") +End Property ' SFDocuments.SF_Chart.XShape (get) + +REM ----------------------------------------------------------------------------- +Property Get XTableChart() As Variant +''' com.sun.star.table.XTableChart + ChartType = _PropertyGet("XTableChart") +End Property ' SFDocuments.SF_Chart.XTableChart (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function ExportToFile(Optional ByVal FileName As Variant _ + , Optional ByVal ImageType As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Store the chart as an image to the given file location +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' ImageType: the name of the targeted image type +''' Allowed values: gif, jpeg, png (default), svg and tiff +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' CHARTEXPORTERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oChart.ExportToFile("C:\Me\Chart2.gif", ImageType := "gif", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vStoreArguments As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Dim oExport As Object ' com.sun.star.drawing.GraphicExportFilter +Dim vImageTypes As Variant ' Array of permitted image types +Dim vMimeTypes As Variant ' Array of corresponding mime types in the same order as vImageTypes + +Const cstImageTypes = "gif,jpeg,png,svg,tiff" +Const cstMimeTypes = "image/gif,image/jpeg,image/png,image/svg+xml,image/tiff" + +Const cstThisSub = "SFDocuments.Chart.ExportToFile" +Const cstSubArgs = "FileName, [ImageType=""png""|""gif""|""jpeg""|""svg""|""tiff""], [Overwrite=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(ImageType) Or IsEmpty(ImageType) Then ImageType = "png" + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + + vImageTypes = Split(cstImageTypes, ",") + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ImageType, "ImageType", V_STRING, vImageTypes) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + vMimeTypes = Split(cstMimeTypes, ",") + vStoreArguments = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("URL", sFile) _ + , ScriptForge.SF_Utils._MakePropertyValue("MediaType" _ + , vMimeTypes(ScriptForge.SF_Array.IndexOf(vImageTypes, ImageType, CaseSensitive := False))) _ + ) + ' Export with the com.sun.star.drawing.GraphicExportFilter UNO service + Set oExport = ScriptForge.SF_Utils._GetUNOService("GraphicExportFilter") + With oExport + .setSourceDocument(_Shape) + .filter(vStoreArguments) + End With + bSaved = True + +Finally: + ExportToFile = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(CHARTEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite) + GoTo Finally +End Function ' SFDocuments.SF_Chart.ExportToFile + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Chart.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Chart.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Chart service as an array + + Methods = Array( _ + "ExportToFile" _ + , "Resize" _ + ) + +End Function ' SFDocuments.SF_Chart.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Chart class as an array + + Properties = Array( _ + "ChartType" _ + , "Deep" _ + , "Dim3D" _ + , "Exploded" _ + , "Filled" _ + , "Legend" _ + , "Percent" _ + , "Stacked" _ + , "Title" _ + , "XChartObj" _ + , "XDiagram" _ + , "XShape" _ + , "XTableChart" _ + , "XTitle" _ + , "YTitle" _ + ) + +End Function ' SFDocuments.SF_Chart.Properties + +REM ----------------------------------------------------------------------------- +Public Function Resize(Optional ByVal XPos As Variant _ + , Optional ByVal YPos As Variant _ + , Optional ByVal Width As Variant _ + , Optional ByVal Height As Variant _ + ) As Boolean +''' Move the topleft corner of a chart to new coordinates and/or modify its dimensions +''' All distances are expressed in 1/100th mm +''' Args: +''' XPos : the vertical distance from the topleft corner +''' YPos : the horizontal distance from the topleft corner +''' Width : the horizontal width of the shape containing the chart +''' Height : the vertical height of the shape containing the chart +''' Negative or missing arguments are left unchanged +''' Returns: +''' True when successful +''' Examples: +''' oChart.Resize(1000, 2000, Height := 6000) ' Width is not changed + +Dim bResize As Boolean ' Return value +Dim oPosition As Object ' com.sun.star.awt.Point +Dim oSize As Object ' com.sun.star.awt.Size +Const cstThisSub = "SFDocuments.Chart.Resize" +Const cstSubArgs = "[XPos], [YPos], [Width], [Height]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bResize = False + +Check: + If IsMissing(XPos) Or IsEmpty(XPos) Then XPos = -1 + If IsMissing(YPos) Or IsEmpty(YPos) Then YPos = -1 + If IsMissing(Height) Or IsEmpty(Height) Then Height = -1 + If IsMissing(Width) Or IsEmpty(Width) Then Width = -1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(XPos, "XPos", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(YPos, "YPos", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + With _Shape + ' Get the current values + Set oPosition = .Position + Set oSize = .Size + ' Modify relevant elements + If XPos >= 0 Then oPosition.X = CLng(XPos) + If YPos >= 0 Then oPosition.Y = CLng(YPos) + If Width > 0 Then oSize.Width = CLng(Width) + If Height > 0 Then oSize.Height = CLng(Height) + ' Rewrite + .setPosition(oPosition) + .setSize(oSize) + End With + bResize = True + +Finally: + Resize = bResize + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Chart.Resize + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Chart.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Chart.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Static oSession As Object ' Alias of SF_Session +Dim vData As Variant ' Data points array of values + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDocuments.Chart.get" & psProperty + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("ChartType") + With _Diagram + Select Case .DiagramType + Case "com.sun.star.chart.BarDiagram" + If .Vertical Then _PropertyGet = "Bar" Else _PropertyGet = "Column" + Case "com.sun.star.chart.PieDiagram" + _PropertyGet = "Pie" + Case "com.sun.star.chart.DonutDiagram" + _PropertyGet = "Donut" + Case "com.sun.star.chart.AreaDiagram" + _PropertyGet = "Area" + Case "com.sun.star.chart.LineDiagram" + _PropertyGet = "Line" + Case "com.sun.star.chart.XYDiagram" + _PropertyGet = "XY" + Case "com.sun.star.chart.BubbleDiagram" + _PropertyGet = "Bubble" + Case "com.sun.star.chart.NetDiagram", "com.sun.star.chart.FilledNetDiagram" + _PropertyGet = "Net" + Case Else + _PropertyGet = "" + End Select + End With + Case UCase("Deep") + If oSession.HasUnoProperty(_Diagram, "Deep") Then _PropertyGet = _Diagram.Deep Else _PropertyGet = False + Case UCase("Dim3D") + If oSession.HasUnoProperty(_Diagram, "Dim3D") Then + If _Diagram.Dim3D Then + If oSession.HasUnoProperty(_Diagram, "SolidType") Then + Select Case _Diagram.SolidType + Case com.sun.star.chart.ChartSolidType.RECTANGULAR_SOLID : _PropertyGet = "Bar" + Case com.sun.star.chart.ChartSolidType.CYLINDER : _PropertyGet = "Cylinder" + Case com.sun.star.chart.ChartSolidType.CONE : _PropertyGet = "Cone" + Case com.sun.star.chart.ChartSolidType.PYRAMID : _PropertyGet = "Pyramid" + End Select + Else + _PropertyGet = _Diagram.Dim3D + End If + Else + _PropertyGet = False + End If + Else + _PropertyGet = False + End If + Case UCase("Exploded") + If oSession.HasUnoProperty(_ChartObject, "Data") Then + ' All data points are presumed exploded with the same coefficient. Determine the (0, 0)th + With _ChartObject + vData = .Data.Data + _PropertyGet = 0 + If IsArray(vData) Then + If UBound(vData) >= 0 Then + If IsArray(vData(0)) Then + If UBound(vData(0)) >= 0 Then _PropertyGet = _Diagram.getDataPointProperties(0, 0).SegmentOffset + End If + End If + End If + End With + End If + Case UCase("Filled") + _PropertyGet = ( _Diagram.DiagramType = "com.sun.star.chart.FilledNetDiagram" ) + Case UCase("Legend") + If oSession.HasUnoProperty(_ChartObject, "HasLegend") Then _PropertyGet = _ChartObject.HasLegend Else _PropertyGet = False + Case UCase("Percent") + If oSession.HasUnoProperty(_Diagram, "Percent") Then _PropertyGet = _Diagram.Percent Else _PropertyGet = False + Case UCase("Stacked") + If oSession.HasUnoProperty(_Diagram, "Stacked") Then _PropertyGet = _Diagram.Stacked Else _PropertyGet = False + Case UCase("Title") + If oSession.HasUnoProperty(_ChartObject, "HasMainTitle") Then + If _ChartObject.HasMainTitle Then _PropertyGet = _ChartObject.Title.String Else _PropertyGet = "" + End If + Case UCase("XTitle") + If oSession.HasUnoProperty(_Diagram, "HasXAxisTitle") Then + If _Diagram.HasXAxisTitle Then _PropertyGet = _Diagram.XAxisTitle.String Else _PropertyGet = "" + End If + Case UCase("YTitle") + If oSession.HasUnoProperty(_Diagram, "HasYAxisTitle") Then + If _Diagram.HasYAxisTitle Then _PropertyGet = _Diagram.YAxisTitle.String Else _PropertyGet = "" + End If + Case UCase("XChartObj") + Set _PropertyGet = _ChartObject + Case UCase("XDiagram") + Set _PropertyGet = _Diagram + Case UCase("XShape") + Set _PropertyGet = _Shape + Case UCase("XTableChart") + Set _PropertyGet = _Chart + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Chart._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim sChartType As String ' Diagram type +Dim bDim3D As Boolean ' Alias of Dim3D property of diagram +Dim bVertical As Boolean ' When True, chart type is a bar, not a column +Dim vData As Variant ' Data points array of values +Dim i As Long, j As Long +Const cstChart = "com.sun.star.chart." + +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Chart.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Catch + + bSet = True + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("ChartType") + If Not ScriptForge.SF_Utils._Validate(pvValue, "ChartType", V_STRING _ + , Array("Bar", "Column", "Pie", "Donut", "Area", "Line", "XY", "Bubble", "Net") _ + ) Then GoTo Finally + With _Diagram + ' Specify the targeted chart type + Select Case UCase(pvValue) + Case "BAR", "COLUMN" : sChartType = cstChart & "BarDiagram" + Case "PIE" : sChartType = cstChart & "PieDiagram" + Case "DONUT" : sChartType = cstChart & "DonutDiagram" + Case "AREA" : sChartType = cstChart & "AreaDiagram" + Case "LINE" : sChartType = cstChart & "LineDiagram" + Case "XY" : sChartType = cstChart & "XYDiagram" + Case "BUBBLE" : sChartType = cstChart & "BubbleDiagram" + Case "NET" : sChartType = cstChart & "NetDiagram" + End Select + ' If there is no change, do nothing + If sChartType <> .DiagramType Then + ' Some combinations old type => new type require the cancellation of 3D graphs + bDim3D = .Dim3D + .Dim3D = False + _ChartObject.createInstance(sChartType) + Set _Diagram = _ChartObject.Diagram + .Dim3D = bDim3D + End If + If UCase(pvValue) = "BAR" Or UCase(pvValue) = "COLUMN" Then .Vertical = ( UCase(pvValue) = "BAR" ) + End With + Case UCase("Deep") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Deep", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "Deep") Then _Diagram.Deep = pvValue + Case UCase("Dim3D") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Dim3D", Array(ScriptForge.V_Boolean, V_STRING) _ + , Array(False, True, "Bar", "Cylinder", "Cone", "Pyramid") _ + ) Then GoTo Finally + With _Diagram + If oSession.HasUnoProperty(_Diagram, "Dim3D") Then + If _Diagram.DiagramType = "com.sun.star.chart.BubbleDiagram" Then + .Dim3D = False ' Force False value to avoid empty graph + ElseIf VarType(pvValue) = V_STRING Then + bVertical = .Vertical + .Dim3D = True + .Vertical = bVertical + If oSession.HasUnoProperty(_Diagram, "SolidType") Then + If .DiagramType = cstChart & "BarDiagram" Then + Select Case UCase(pvValue) + Case "BAR" : .SolidType = com.sun.star.chart.ChartSolidType.RECTANGULAR_SOLID + Case "CYLINDER" : .SolidType = com.sun.star.chart.ChartSolidType.CYLINDER + Case "CONE" : .SolidType = com.sun.star.chart.ChartSolidType.CONE + Case "PYRAMID" : .SolidType = com.sun.star.chart.ChartSolidType.PYRAMID + End Select + Else + .SolidType = 0 + End If + End If + Else ' Boolean + If oSession.HasUnoProperty(_Diagram, "SolidType") Then .SolidType = 0 + .Dim3D = pvValue + End If + End If + End With + Case UCase("Exploded") + If oSession.HasUnoProperty(_ChartObject, "Data") And _Diagram.DiagramType <> "com.sun.star.chart.BubbleDiagram" Then + ' All data points are presumed exploded with the same coefficient + If Not ScriptForge.SF_Utils._Validate(pvValue, "Exploded", ScriptForge.V_NUMERIC) Then GoTo Finally + With _ChartObject + vData = .Data.Data + If IsArray(vData) Then + For i = 0 To UBound(vData) + If IsArray(vData(i)) Then + For j = 0 To UBound(vData(i)) + _Diagram.getDataPointProperties(i, j).SegmentOffset = CLng(pvValue) + Next j + End If + Next i + End If + End With + End If + Case UCase("Filled") + ' Flipflop between NetDiagram and FilledNetDiagram + If Not ScriptForge.SF_Utils._Validate(pvValue, "Filled", ScriptForge.V_BOOLEAN) Then GoTo Finally + With _Diagram + ' Specify the targeted chart type + sChartType = cstChart & Iif(pvValue, "Filled", "") & "NetDiagram" + ' If there is no change, do nothing + If sChartType <> .DiagramType then + ' Do not apply if the chart type not = "Net" + If (pvValue And .DiagramType = cstChart & "NetDiagram") _ + Or (Not pvValue And .DiagramType = cstChart & "FilledNetDiagram") Then + ' Some combinations old type => new type require the cancellation of 3D graphs + bDim3D = .Dim3D + .Dim3D = False + _ChartObject.createInstance(sChartType) + Set _Diagram = _ChartObject.Diagram + .Dim3D = bDim3D + End If + End If + End With + Case UCase("Legend") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Legend", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ChartObject, "HasLegend") Then _ChartObject.HasLegend = pvValue + Case UCase("Percent") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Percent", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "Percent") Then + _Diagram.Stacked = pvValue + _Diagram.Percent = pvValue + End If + Case UCase("Stacked") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Stacked", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "Stacked") Then + _Diagram.Stacked = pvValue + If Not pvValue Then _Diagram.Percent = False + End If + Case UCase("Title") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Title", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ChartObject, "HasMainTitle") Then + _ChartObject.HasMainTitle = ( Len(pvValue) > 0 ) + If Len(pvValue) > 0 Then _ChartObject.Title.String = pvValue + End If + Case UCase("XTitle") + If Not ScriptForge.SF_Utils._Validate(pvValue, "XTitle", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "HasXAxisTitle") Then + _Diagram.HasXAxisTitle = ( Len(pvValue) > 0 ) + If Len(pvValue) > 0 Then _Diagram.XAxisTitle.String = pvValue + End If + Case UCase("YTitle") + If Not ScriptForge.SF_Utils._Validate(pvValue, "YTitle", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "HasYAxisTitle") Then + _Diagram.HasYAxisTitle = ( Len(pvValue) > 0 ) + If Len(pvValue) > 0 Then _Diagram.YAxisTitle.String = pvValue + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bSet = False + GoTo Finally +End Function ' SFDocuments.SF_FormControl._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Chart instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Chart]: Name - Type + + _Repr = "[Chart]: " & ChartName & " - " & ChartType + +End Function ' SFDocuments.SF_Chart._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_CHART +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Document.xba b/wizards/source/sfdocuments/SF_Document.xba new file mode 100644 index 000000000..c54409445 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Document.xba @@ -0,0 +1,1504 @@ +<?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="SF_Document" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Document +''' =========== +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' managing and manipulating LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the +''' current SF_Document module +''' - saving, closing documents +''' - accessing their standard or custom properties +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ... +''' +''' Documents might contain forms. The current service gives access to the "SFDocuments.Form" service +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties implemented below +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The current module is closely related to the "UI" and "FileSystem" services +''' of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.GetDocument("Untitled 1") +''' ' or Set oDoc = ui.CreateDocument("Calc", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.odt") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", "Untitled 1") ' Default = ActiveWindow +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_document.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DOCUMENTDEADERROR = "DOCUMENTDEADERROR" +Private Const DOCUMENTSAVEERROR = "DOCUMENTSAVEERROR" +Private Const DOCUMENTSAVEASERROR = "DOCUMENTSAVEASERROR" +Private Const DOCUMENTREADONLYERROR = "DOCUMENTREADONLYERROR" + +Private Const FORMDEADERROR = "FORMDEADERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private [_SubClass] As Object ' Subclass instance +Private ObjectType As String ' Must be DOCUMENT +Private ServiceName As String + +' Window description +Private _Component As Object ' com.sun.star.lang.XComponent +Private _Frame As Object ' com.sun.star.comp.framework.Frame +Private _WindowName As String ' Object Name +Private _WindowTitle As String ' Only mean to identify new documents +Private _WindowFileName As String ' URL of file name +Private _DocumentType As String ' Writer, Calc, ... + +' Properties (work variables - real properties could have been set manually by user) +Private _DocumentProperties As Object ' Dictionary of document properties +Private _CustomProperties As Object ' Dictionary of custom properties + +REM ============================================================ MODULE CONSTANTS + +Const ISDOCFORM = 1 ' Form is stored in a Writer document + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + Set [_SubClass] = Nothing + ObjectType = "DOCUMENT" + ServiceName = "SFDocuments.Document" + Set _Component = Nothing + Set _Frame = Nothing + _WindowName = "" + _WindowTitle = "" + _WindowFileName = "" + _DocumentType = "" + Set _DocumentProperties = Nothing + Set _CustomProperties = Nothing +End Sub ' SFDocuments.SF_Document Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Document Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Document Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CustomProperties() As Variant +''' Returns a dictionary of all custom properties of the document + CustomProperties = _PropertyGet("CustomProperties") +End Property ' SFDocuments.SF_Document.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) +''' Sets the updatable custom properties +''' The argument is a dictionary + +Dim vPropertyValues As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vCustomProperties As Variant ' Alias of argument +Dim oUserdefinedProperties As Object ' Custom properties object +Dim vOldPropertyValues As Variant ' Array of (to remove) existing user defined properties +Dim oProperty As Object ' Single com.sun.star.beans.PropertyValues +Dim sProperty As String ' Property name +Dim vKeys As Variant ' Array of dictionary keys +Dim vItems As Variant ' Array of dictionary items +Dim vValue As Variant ' Value to store in property +Dim iAttribute As Integer ' com.sun.star.beans.PropertyAttribute.REMOVEABLE +Dim i As Long +Const cstThisSub = "SFDocuments.Document.setCustomProperties" +Const cstSubArgs = "CustomProperties" + + On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvCustomProperties, "CustomProperties", ScriptForge.V_OBJECT, , , "DICTIONARY") Then GoTo Finally + End If + +Try: + Set oUserDefinedProperties = _Component.getDocumentProperties().UserDefinedProperties + + Set vCustomProperties = pvCustomProperties ' To avoid "Object variable not set" error + With vCustomProperties + + ' All existing custom properties must first be removed to avoid type conflicts + vOldPropertyValues = oUserDefinedProperties.getPropertyValues + For Each oProperty In vOldPropertyValues + sProperty = oProperty.Name + oUserDefinedProperties.removeProperty(sProperty) + Next oProperty + + ' Insert new properties one by one after type adjustment (dates, arrays, numbers) + vKeys = .Keys + vItems = .Items + iAttribute = com.sun.star.beans.PropertyAttribute.REMOVEABLE + For i = 0 To UBound(vKeys) + If VarType(vItems(i)) = V_DATE Then + vValue = ScriptForge.SF_Utils._CDateToUnoDate(vItems(i)) + ElseIf IsArray(vItems(i)) Then + vValue = Null + ElseIf ScriptForge.SF_Utils._VarTypeExt(vItems(i)) = ScriptForge.V_NUMERIC Then + vValue = CreateUnoValue("double", vItems(i)) + Else + vValue = vItems(i) + End If + oUserDefinedProperties.addProperty(vKeys(i), iAttribute, vValue) + Next i + + ' Declare the document as changed + _Component.setModified(True) + End With + + ' Reload custom properties in current object instance + _PropertyGet("CustomProperties") + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +Catch: + GoTo Finally +End Property ' SFDocuments.SF_Document.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant +''' Returns the updatable document property Description + Description = _PropertyGet("Description") +End Property ' SFDocuments.SF_Document.Description + +REM ----------------------------------------------------------------------------- +Property Let Description(Optional ByVal pvDescription As Variant) +''' Sets the updatable document property Description +''' If multilined, separate lines by "\n" escape sequence or by hard breaks + +Dim sDescription As String ' Alias of pvDescription +Const cstThisSub = "SFDocuments.Document.setDescription" +Const cstSubArgs = "Description" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvDescription, "Description", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + sDescription = Replace(pvDescription, "\n", ScriptForge.SF_String.sfNEWLINE) + _Component.DocumentProperties.Description = sDescription + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Description", sdescription) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Description + +REM ----------------------------------------------------------------------------- +Property Get DocumentProperties() As Variant +''' Returns a dictionary of all standard document properties, custom properties are excluded + DocumentProperties = _PropertyGet("DocumentProperties") +End Property ' SFDocuments.SF_Document.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String +''' Returns "Base", "Calc", "Draw", ... or "Writer" + DocumentType = _PropertyGet("DocumentType") +End Property ' SFDocuments.SF_Document.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get ExportFilters() As Variant +''' Returns the list of the export filter names applicable to the current document +''' as a zero-based array of strings +''' Import/Export filters are included + ExportFilters = _PropertyGet("ExportFilters") +End Property ' SFDocuments.SF_Document.ExportFilters + +REM ----------------------------------------------------------------------------- +Property Get ImportFilters() As Variant +''' Returns the list of the import filter names applicable to the current document +''' as a zero-based array of strings +''' Import/Export filters are included + ImportFilters = _PropertyGet("ImportFilters") +End Property ' SFDocuments.SF_Document.ImportFilters + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = _PropertyGet("IsBase") +End Property ' SFDocuments.SF_Document.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = _PropertyGet("IsCalc") +End Property ' SFDocuments.SF_Document.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = _PropertyGet("IsDraw") +End Property ' SFDocuments.SF_Document.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = _PropertyGet("IsImpress") +End Property ' SFDocuments.SF_Document.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = _PropertyGet("IsMath") +End Property ' SFDocuments.SF_Document.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = _PropertyGet("IsWriter") +End Property ' SFDocuments.SF_Document.IsWriter + +REM ----------------------------------------------------------------------------- +Property Get Keywords() As Variant +''' Returns the updatable document property Keywords + Keywords = _PropertyGet("Keywords") +End Property ' SFDocuments.SF_Document.Keywords + +REM ----------------------------------------------------------------------------- +Property Let Keywords(Optional ByVal pvKeywords As Variant) +''' Sets the updatable document property Keywords + +Dim vKeywords As Variant ' Alias of pvKeywords +Const cstThisSub = "SFDocuments.Document.setKeywords" +Const cstSubArgs = "Keywords" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvKeywords, "Keywords", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + vKeywords = ScriptForge.SF_Array.TrimArray(Split(pvKeywords, ",")) + _Component.DocumentProperties.Keywords = vKeywords + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Keywords", Join(vKeywords, ", ")) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Keywords + +REM ----------------------------------------------------------------------------- +Property Get Readonly() As Boolean +''' Returns True if the document must not be modified + Readonly = _PropertyGet("Readonly") +End Property ' SFDocuments.SF_Document.Readonly + +REM ----------------------------------------------------------------------------- +Property Get Subject() As Variant +''' Returns the updatable document property Subject + Subject = _PropertyGet("Subject") +End Property ' SFDocuments.SF_Document.Subject + +REM ----------------------------------------------------------------------------- +Property Let Subject(Optional ByVal pvSubject As Variant) +''' Sets the updatable document property Subject + +Const cstThisSub = "SFDocuments.Document.setSubject" +Const cstSubArgs = "Subject" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvSubject, "Subject", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + _Component.DocumentProperties.Subject = pvSubject + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Subject", pvSubject) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Subject + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant +''' Returns the updatable document property Title + Title = _PropertyGet("Title") +End Property ' SFDocuments.SF_Document.Title + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) +''' Sets the updatable document property Title + +Const cstThisSub = "SFDocuments.Document.setTitle" +Const cstSubArgs = "Title" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvTitle, "Title", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + _Component.DocumentProperties.Title = pvTitle + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Title", pvTitle) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant +''' Returns the com.sun.star.lang.XComponent UNO object representing the document + XComponent = _PropertyGet("XComponent") +End Property ' SFDocuments.SF_Document.XComponent + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean +''' Make the current document active +''' Args: +''' Returns: +''' True if the document could be activated +''' Otherwise, there is no change in the actual user interface +''' Examples: +''' oDoc.Activate() + +Dim bActivate As Boolean ' Return value +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDocuments.Document.Activate" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActivate = False + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + +Try: + Set oContainer = _Frame.ContainerWindow + With oContainer + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .toFront() ' Force window change in Linux + Wait 1 ' Bypass desynchro issue in Linux + End With + bActivate = True + +Finally: + Activate = bActivate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean +''' Close the document. Does nothing if the document is already closed +''' regardless of how the document was closed, manually or by program +''' Args: +''' SaveAsk: If True (default), the user is invited to confirm or not the writing of the changes on disk +''' No effect if the document was not modified +''' Returns: +''' False if the user declined to close +''' Examples: +''' If oDoc.CloseDocument() Then +''' ' ... + +Dim bClosed As Boolean ' return value +Dim oDispatch ' com.sun.star.frame.DispatchHelper +Const cstThisSub = "SFDocuments.Document.CloseDocument" +Const cstSubArgs = "[SaveAsk=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClosed = False + +Check: + If IsMissing(SaveAsk) Or IsEmpty(SaveAsk) Then SaveAsk = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SaveAsk, "SaveAsk", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + If SaveAsk And _Component.IsModified Then ' Execute closure with the File/Close menu command + Activate() + RunCommand("CloseDoc") + bClosed = _IsStillAlive(, False) ' Do not raise error + Else + _Frame.close(True) + _Frame.dispose() + bClosed = True + End If + +Finally: + If bClosed Then Dispose() + CloseDocument = bClosed + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + , Optional ByRef _Document As Variant _ + ) As Object +''' Create a new menu entry in the document's menubar +''' The menu is not intended to be saved neither in the LibreOffice global environment, nor in the document +''' The method returns a SFWidgets.Menu instance. Its methods let define the menu further. +''' Args: +''' MenuHeader: the name/header of the menu +''' Before: the place where to put the new menu on the menubar (string or number >= 1) +''' When not found => last position +''' SubmenuChar: the delimiter used in menu trees. Default = ">" +''' _Document: undocumented argument to designate the document where the menu will be located +''' Returns: +''' A SFWidgets.Menu instance or Nothing +''' Examples: +''' Dim oMenu As Object +''' Set oMenu = oDoc.CreateMenu("My menu", Before := "Styles") +''' With oMenu +''' .AddItem("Item 1", Command := "About") +''' '... +''' .Dispose() ' When definition is complete, the menu instance may be disposed +''' End With +''' ' ... + +Dim oMenu As Object ' return value +Const cstThisSub = "SFDocuments.Document.CreateMenu" +Const cstSubArgs = "MenuHeader, [Before=""""], [SubmenuChar="">""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oMenu = Nothing + +Check: + If IsMissing(Before) Or IsEmpty(Before) Then Before = "" + If IsMissing(SubmenuChar) Or IsEmpty(SubmenuChar) Then SubmenuChar = "" + If IsMissing(_Document) Or IsEmpty(_Document) Or IsNull(_Document) Then Set _Document = _Component + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MenuHeader, "MenuHeader", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Before, "Before", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SubmenuChar, "SubmenuChar", V_STRING) Then GoTo Finally + End If + +Try: + Set oMenu = ScriptForge.SF_Services.CreateScriptService("SFWidgets.Menu", _Document, MenuHeader, Before, SubmenuChar) + +Finally: + Set CreateMenu = oMenu + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function ExportAsPDF(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal Watermark As Variant _ + ) As Boolean +''' Store the document to the given file location in PDF format +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Password: password to open the document +''' Watermark: the text for a watermark to be drawn on every page of the exported PDF file +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEASERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.ExportAsPDF("C:\Me\myDoc.pdf", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim sFilter As String ' One of the pdf filter names +Dim vFilterData As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Document.ExportAsPDF" +Const cstSubArgs = "FileName, [Overwrite=False], [Pages=""""], [Password=""""], [Watermark=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(Watermark) Or IsEmpty(Watermark) Then Watermark = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Watermark, "Watermark", V_STRING) Then GoTo Finally + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + sFilter = LCase(_DocumentType) & "_pdf_Export" + ' FilterData parameters are added only if they are meaningful + vFilterData = Array() + If Len(Pages) > 0 Then + vFilterData = ScriptForge.SF_Array.Append(vFilterData _ + , ScriptForge.SF_Utils._MakePropertyValue("PageRange", Pages)) + End If + If Len(Password) > 0 Then + vFilterData = ScriptForge.SF_Array.Append(vFilterData _ + , ScriptForge.SF_Utils._MakePropertyValue("EncryptFile", True) _ + , ScriptForge.SF_Utils._MakePropertyValue("DocumentOpenPassword", Password)) + End If + If Len(Watermark) > 0 Then + vFilterData = ScriptForge.SF_Array.Append(vFilterData _ + , ScriptForge.SF_Utils._MakePropertyValue("Watermark", Watermark)) + End If + + ' Finalize properties and export + vProperties = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterData", vFilterData)) + _Component.StoreToURL(sFile, vProperties) + bSaved = True + +Finally: + ExportAsPDF = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEASERROR, "FileName", FileName, "Overwrite", Overwrite _ + , "FilterName", "PDF Export") + GoTo Finally +End Function ' SFDocuments.SF_Document.ExportAsPDF + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "SFDocuments.Document.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Document service as an array + + Methods = Array( _ + "Activate" _ + , "CloseDocument" _ + , "CreateMenu" _ + , "ExportAsPDF" _ + , "PrintOut" _ + , "RemoveMenu" _ + , "RunCommand" _ + , "Save" _ + , "SaveAs" _ + , "SaveCopyAs" _ + , "SetPrinter" _ + ) + +End Function ' SFDocuments.SF_Document.Methods + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + , Optional ByRef _Document As Variant _ + ) As Boolean +''' Send the content of the document to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' Args: +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' _Document: undocumented argument to designate the document to print when called from a subclass +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("1-4;10;15-18", Copies := 2) + +Dim bPrint As Boolean ' Return value +Dim vPrintGoal As Variant ' Array of property values + +Const cstThisSub = "SFDocuments.Document.PrintOut" +Const cstSubArgs = "[Pages=""""], [Copies=1]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + If IsMissing(_Document) Or IsEmpty(_Document) Or IsNull(_Document) Then Set _Document = _Component + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + vPrintGoal = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("CopyCount", CInt(Copies)) _ + , ScriptForge.SF_Utils._MakePropertyValue("Collate", True) _ + , ScriptForge.SF_Utils._MakePropertyValue("Pages", Pages) _ + , ScriptForge.SF_Utils._MakePropertyValue("Wait", False) _ + ) + + _Document.Print(vPrintGoal) + bPrint = True + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Document class as an array + + Properties = Array( _ + "CustomProperties" _ + , "Description" _ + , "DocumentProperties" _ + , "DocumentType" _ + , "ExportFilters" _ + , "ImportFilters" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw" _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "Keywords" _ + , "Readonly" _ + , "Subject" _ + , "Title" _ + , "XComponent" _ + ) + +End Function ' SFDocuments.SF_Document.Properties + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByRef _Document As Variant _ +) As Boolean +''' Remove a menu entry in the document's menubar +''' The removal is not intended to be saved neither in the LibreOffice global environment, nor in the document +''' Args: +''' MenuHeader: the name/header of the menu, without tilde "~", as a case-sensitive string +''' _Document: undocumented argument to designate the document where the menu is located +''' Returns: +''' True when successful +''' Examples: +''' oDoc.RemoveMenu("File") +''' ' ... + +Dim bRemove As Boolean ' Return value +Dim oLayout As Object ' com.sun.star.comp.framework.LayoutManager +Dim oMenuBar As Object ' com.sun.star.awt.XMenuBar or stardiv.Toolkit.VCLXMenuBar +Dim sName As String ' Menu name +Dim iMenuId As Integer ' Menu identifier +Dim iMenuPosition As Integer ' Menu position >= 0 +Dim i As Integer +Const cstTilde = "~" + +Const cstThisSub = "SFDocuments.Document.RemoveMenu" +Const cstSubArgs = "MenuHeader" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRemove = False + +Check: + If IsMissing(_Document) Or IsEmpty(_Document) Or IsNull(_Document) Then Set _Document = _Component + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MenuHeader, "MenuHeader", V_STRING) Then GoTo Finally + End If + +Try: + Set oLayout = _Document.CurrentController.Frame.LayoutManager + Set oMenuBar = oLayout.getElement("private:resource/menubar/menubar").XMenuBar + + ' Search the menu identifier to remove by its name, Mark its position + With oMenuBar + iMenuPosition = -1 + For i = 0 To .ItemCount - 1 + iMenuId = .getItemId(i) + sName = Replace(.getItemText(iMenuId), cstTilde, "") + If MenuHeader= sName Then + iMenuPosition = i + Exit For + End If + Next i + ' Remove the found menu item + If iMenuPosition >= 0 Then + .removeItem(iMenuPosition, 1) + bRemove = True + End If + End With + +Finally: + RemoveMenu = bRemove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) +''' Run on the current document window the given menu command. The command is executed with or without arguments +''' A few typical commands: +''' Save, SaveAs, ExportToPDF, SetDocumentProperties, Undo, Copy, Paste, ... +''' Dozens can be found on next page: https://wiki.documentfoundation.org/Development/DispatchCommands +''' Args: +''' Command: Case-sensitive. The command itself is not checked. +''' If the command does not contain the ".uno:" prefix, it is added. +''' If nothing happens, then the command is probably wrong +''' Args: Pairs of arguments name (string), value (any) +''' Returns: +''' Examples: +''' oDoc.RunCommand("EditDoc", "Editable", False) ' Toggle edit mode + +Dim vArgs As Variant ' Alias of Args +Dim oDispatch ' com.sun.star.frame.DispatchHelper +Dim vProps As Variant ' Array of PropertyValues +Dim vValue As Variant ' A single value argument +Dim sCommand As String ' Alias of Command +Dim i As Long +Const cstPrefix = ".uno:" + +Const cstThisSub = "SFDocuments.Document.RunCommand" +Const cstSubArgs = "Command, [arg0Name, arg0Value], [arg1Name, arg1Value], ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + ' When called from a subclass (Calc, Writer, ..) the arguments are gathered into one single array item + vArgs = Args + If IsArray(Args) Then + If UBound(Args) >= 0 And IsArray(Args(0)) Then vArgs = Args(0) + End If + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Command, "Command", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateArray(vArgs, "Args", 1) Then GoTo Finally + For i = 0 To UBound(vArgs) - 1 Step 2 + If Not ScriptForge.SF_Utils._Validate(vArgs(i), "Arg" & CStr(i/2) & "Name", V_STRING) Then GoTo Finally + Next i + End If + +Try: + ' Build array of property values + vProps = Array() + For i = 0 To UBound(vArgs) - 1 Step 2 + If IsEmpty(vArgs(i + 1)) Then vValue = Null Else vValue = vArgs(i + 1) + vProps = ScriptForge.SF_Array.Append(vProps, ScriptForge.SF_Utils._MakePropertyValue(vArgs(i), vValue)) + Next i + Set oDispatch = ScriptForge.SF_Utils._GetUNOService("DispatchHelper") + If ScriptForge.SF_String.StartsWith(Command, cstPrefix) Then sCommand = Command Else sCommand = cstPrefix & Command + oDispatch.executeDispatch(_Frame, sCommand, "", 0, vProps) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SFDocuments.SF_Document.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean +''' Store the document to the file location from which it was loaded +''' Ignored if the document was not modified +''' Args: +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEERROR The file has been opened readonly or was opened as new and was not yet saved +''' Examples: +''' If Not oDoc.Save() Then +''' ' ... + +Dim bSaved As Boolean ' return value +Const cstThisSub = "SFDocuments.Document.Save" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSaved = False + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + bSaved = False + +Try: + With _Component + If .isReadonly() Or Not .hasLocation() Then GoTo CatchReadonly + If .IsModified() Then + .store() + bSaved = True + End If + End With + +Finally: + Save = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchReadonly: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEERROR, "FileName", _FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Document.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean +''' Store the document to the given file location +''' The new location becomes the new file name on which simple Save method calls will be applied +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Password: Use to protect the document +''' FilterName: the name of a filter that should be used for saving the document +''' If present, the filter must exist +''' FilterOptions: an optional string of options associated with the filter +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEASERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.SaveAs("C:\Me\Copy2.odt", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Document.SaveAs" +Const cstSubArgs = "FileName, [Overwrite=False], [Password=""""], [FilterName=""""], [FilterOptions=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(FilterName) Or IsEmpty(FilterName) Then FilterName = "" + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterName, "FilterName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterOptions, "FilterOptions", V_STRING) Then GoTo Finally + End If + + ' Check that the filter exists + If Len(FilterName) > 0 Then + Set oFilterFactory = ScriptForge.SF_Utils._GetUNOService("FilterFactory") + If Not oFilterFactory.hasByName(FilterName) Then GoTo CatchError + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + If Len(Password) + Len(FilterName) = 0 Then + vProperties = Array() + Else + vProperties = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", FilterName) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterOptions", FilterOptions) _ + ) + If Len(Password) > 0 Then ' Password is to add only if <> "" !? + vProperties = ScriptForge.SF_Array.Append(vProperties _ + , ScriptForge.SF_Utils._MakePropertyValue("Password", Password)) + End If + End If + + _Component.StoreAsURL(sFile, vProperties) + + ' Remind the new file name + _WindowFileName = sFile + _WindowName = FSO.GetName(FileName) + bSaved = True + +Finally: + SaveAs = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEASERROR, "FileName", FileName, "Overwrite", Overwrite _ + , "FilterName", FilterName) + GoTo Finally +End Function ' SFDocuments.SF_Document.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean +''' Store a copy or export the document to the given file location +''' The actual location is unchanged +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Password: Use to protect the document +''' FilterName: the name of a filter that should be used for saving the document +''' If present, the filter must exist +''' FilterOptions: an optional string of options associated with the filter +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEASERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.SaveCopyAs("C:\Me\Copy2.odt", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Document.SaveCopyAs" +Const cstSubArgs = "FileName, [Overwrite=False], [Password=""""], [FilterName=""""], [FilterOptions=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(FilterName) Or IsEmpty(FilterName) Then FilterName = "" + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterName, "FilterName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterOptions, "FilterOptions", V_STRING) Then GoTo Finally + End If + + ' Check that the filter exists + If Len(FilterName) > 0 Then + Set oFilterFactory = ScriptForge.SF_Utils._GetUNOService("FilterFactory") + If Not oFilterFactory.hasByName(FilterName) Then GoTo CatchError + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + If Len(Password) + Len(FilterName) = 0 Then + vProperties = Array() + Else + vProperties = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", FilterName) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterOptions", FilterOptions) _ + ) + If Len(Password) > 0 Then ' Password is to add only if <> "" !? + vProperties = ScriptForge.SF_Array.Append(vProperties _ + , ScriptForge.SF_Utils._MakePropertyValue("Password", Password)) + End If + End If + + _Component.StoreToURL(sFile, vProperties) + bSaved = True + +Finally: + SaveCopyAs = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEASERROR, "FileName", FileName, "Overwrite", Overwrite _ + , "FilterName", FilterName) + GoTo Finally +End Function ' SFDocuments.SF_Document.SaveCopyAs + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + , Optional ByRef _PrintComponent As Variant _ + ) As Boolean +''' Define the printer options for the document +''' Args: +''' Printer: the name of the printer queue where to print to +''' When absent or space, the default printer is set +''' Orientation: either "PORTRAIT" or "LANDSCAPE". Left unchanged when absent +''' PaperFormat: one of next values +''' "A3", "A4", "A5", "B4", "B5", "LETTER", "LEGAL", "TABLOID" +''' Left unchanged when absent +''' _PrintComponent: undocumented argument to determine the component +''' Useful typically to apply printer settings on a Base form document +''' Returns: +''' True when successful +''' Examples: +''' oDoc.SetPrinter(Orientation := "PORTRAIT") + +Dim bPrinter As Boolean ' Return value +Dim vPrinters As Variant ' Array of known printers +Dim vOrientations As Variant ' Array of allowed paper orientations +Dim vPaperFormats As Variant ' Array of allowed formats +Dim vPrinterSettings As Variant ' Array of property values +Dim oPropertyValue As New com.sun.star.beans.PropertyValue + ' A single property value item +Const cstThisSub = "SFDocuments.Document.SetPrinter" +Const cstSubArgs = "[Printer=""""], [Orientation=""PORTRAIT""|""LANDSCAPE""]" _ + & ", [PaperFormat=""A3""|""A4""|""A5""|""B4""|""B5""|""LETTER""|""LEGAL""|""TABLOID""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrinter = False + +Check: + If IsMissing(Printer) Or IsEmpty(Printer) Then Printer = "" + If IsMissing(Orientation) Or IsEmpty(Orientation) Then Orientation = "" + If IsMissing(PaperFormat) Or IsEmpty(PaperFormat) Then PaperFormat = "" + If IsMissing(_PrintComponent) Or IsEmpty(_PrintComponent) Then Set _PrintComponent = _Component + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional validation + If Not _IsStillAlive() Then GoTo Finally + If VarType(Printer) = V_STRING Then + vPrinters = ScriptForge.SF_Platform.Printers + If Len(Printer) > 0 Then + If Not ScriptForge.SF_Utils._Validate(Printer, "Printer", V_STRING, vPrinters) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(Printer, "Printer", V_STRING) Then GoTo Finally ' Manage here the VarType error + End If + If VarType(Orientation) = V_STRING Then + vOrientations = Array("PORTRAIT", "LANDSCAPE") + If Len(Orientation) > 0 Then + If Not ScriptForge.SF_Utils._Validate(Orientation, "Orientation", V_STRING, vOrientations) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(Orientation, "Orientation", V_STRING) Then GoTo Finally + End If + If VarType(PaperFormat) = V_STRING Then + vPaperFormats = Array("A3", "A4", "A5", "B4", "B5", "LETTER", "LEGAL", "TABLOID") + If Len(PaperFormat) > 0 Then + If Not ScriptForge.SF_Utils._Validate(PaperFormat, "PaperFormat", V_STRING, vPaperFormats) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(PaperFormat, "PaperFormat", V_STRING) Then GoTo Finally + End If + +Try: + With _PrintComponent + Set oPropertyValue = ScriptForge.SF_Utils._MakePropertyValue("Name", Iif(Len(Printer) > 0, Printer, vPrinters(0))) + vPrinterSettings = Array(oPropertyValue) + If Len(Orientation) > 0 Then + vPrinterSettings = ScriptForge.SF_Utils._SetPropertyValue(vPrinterSettings, "PaperOrientation" _ + , ScriptForge.SF_Array.IndexOf(vOrientations, Orientation, CaseSensitive := False)) + End If + If Len(PaperFormat) > 0 Then + vPrinterSettings = ScriptForge.SF_Utils._SetPropertyValue(vPrinterSettings, "PaperFormat" _ + , ScriptForge.SF_Array.IndexOf(vPaperFormats, PaperFormat, CaseSensitive := False)) + End If + .setPrinter(vPrinterSettings) + End With + bPrinter = True + +Finally: + SetPrinter = bPrinter + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.SetPrinter + +REM ----------------------------------------------------------------------------- +Private Function SetProperty(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Document.set" & psProperty + If IsMissing(pvValue) Then pvValue = Empty + 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("CustomProperties") + CustomProperties = pvValue + Case UCase("Description") + Description = pvValue + Case UCase("Keywords") + Keywords = pvValue + Case UCase("Subject") + Subject = pvValue + Case UCase("Title") + Title = pvValue + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = Iif(Len(_WindowFileName) > 0, SF_FileSystem._ConvertFromUrl(_WindowFileName), _WindowTitle) + +End Function ' SFDocuments.SF_Document._FileIdent + +REM ----------------------------------------------------------------------------- +Private Function _GetFilterNames(ByVal pbExport As Boolean) As Variant +''' Returns the list of export (pbExport = True) or import filters +''' applicable to the current document +''' Args: +''' pbExport: True for export, False for import +''' Returns: +''' A zero-based array of strings + +Dim vFilters As Variant ' Return value +Dim sIdentifier As String ' Document service, like com.sun.star.text.TextDocument +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim vAllFilters As Variant ' The full list of installed filters +Dim sFilter As String ' A single filter name +Dim iCount As Integer ' Filters counter +Dim vFilter As Variant ' A filter descriptor as an array of Name/Value pairs +Dim sType As String ' The filter type to be compared with the document service +Dim lFlags As Long ' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Office_Development#Properties_of_a_Filter +Dim bExport As Boolean ' Filter valid for export when True +Dim bImport As Boolean ' Filter valid for import when True +Dim bImportExport As Boolean ' Filter valid both for import and export when True + + vFilters = Array() + On Local Error GoTo Finally ' Return empty or partial list if error + +Try: + sIdentifier = _Component.Identifier + Set oFilterFactory = ScriptForge.SF_Utils._GetUNOService("FilterFactory") + vAllFilters = oFilterFactory.getElementNames() + ReDim vFilters(0 To UBound(vAllFilters)) + iCount = -1 + + For Each sFilter In vAllFilters + vFilter = oFilterFactory.getByName(sFilter) + sType = vFilter(12).Value ' Hard-coded index for document types + If sType = sIdentifier Then + lFlags = vFilter(10).Value ' Hard-coded index for flags + ' export: flag is even + ' import: flag is odd and flag/2 is even + ' import/export: flag is odd and flag/2 is odd + bExport = ( lFlags Mod 2 = 0 ) + bImport = ( (lFlags Mod 2 = 1) And ((lFlags \ 2) Mod 2 = 0) ) + bImportExport = ( (lFlags Mod 2 = 1) And ((lFlags \ 2) Mod 2 = 1) ) + ' Select filter ? + If bImportExport _ + Or (pbExport And bExport) _ + Or (Not pbExport And bImport) Then + iCount = iCount + 1 + vFilters(iCount) = sFilter + End If + End If + Next sFilter + + If iCount > -1 Then + ReDim Preserve vFilters(0 To iCount) + End If + +Finally: + _GetFilterNames = vFilters + Exit Function +End Function ' SFDocuments.SF_Document._GetFilterNames + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value +Dim sFileName As String ' File identification used to display error message + + On Local Error GoTo Catch ' Anticipate DisposedException errors or alike + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + ' Check existence of document + bAlive = Not IsNull(_Frame) + If bAlive Then bAlive = Not IsNull(_Component) + If bAlive Then bAlive = Not IsNull(_Component.CurrentController) + + ' Check document is not read only + If bAlive And pbForUpdate Then + If _Component.isreadonly() Then GoTo CatchReadonly + End If + +Finally: + _IsStillAlive = bAlive + Exit Function +Catch: + bAlive = False + On Error GoTo 0 + sFileName = _FileIdent() + Dispose() + If pbError Then ScriptForge.SF_Exception.RaiseFatal(DOCUMENTDEADERROR, sFileName) + GoTo Finally +CatchReadonly: + bAlive = False + If pbError Then ScriptForge.SF_Exception.RaiseFatal(DOCUMENTREADONLYERROR, "Document", _FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Document._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Sub _LoadDocumentProperties() +''' Create dictionary with document properties as entries/ Custom properties are excluded +''' Document is presumed still alive +''' Special values: +''' Only valid dates are taken +''' Statistics are exploded in subitems. Subitems are specific to document type +''' Keywords are joined +''' Language is aligned on L10N convention la-CO + +Dim oProperties As Object ' Document properties +Dim vNamedValue As Variant ' com.sun.star.beans.NamedValue + + If IsNull(_DocumentProperties) Then + Set oProperties = _Component.getDocumentProperties + Set _DocumentProperties = CreateScriptService("Dictionary") + With _DocumentProperties + .Add("Author", oProperties.Author) + .Add("AutoloadSecs", oProperties.AutoloadSecs) + .Add("AutoloadURL", oProperties.AutoloadURL) + If oProperties.CreationDate.Year > 0 Then .Add("CreationDate", CDateFromUnoDateTime(oProperties.CreationDate)) + .Add("DefaultTarget", oProperties.DefaultTarget) + .Add("Description", oProperties.Description) ' The description can be multiline + ' DocumentStatistics : number and names of statistics depend on document type + For Each vNamedValue In oProperties.DocumentStatistics + .Add(vNamedValue.Name, vNamedValue.Value) + Next vNamedValue + .Add("EditingDuration", oProperties.EditingDuration) + .Add("Generator", oProperties.Generator) + .Add("Keywords", Join(oProperties.Keywords, ", ")) + .Add("Language", oProperties.Language.Language & Iif(Len(oProperties.Language.Country) > 0, "-" & oProperties.Language.Country, "")) + If oProperties.ModificationDate.Year > 0 Then .Add("ModificationDate", CDateFromUnoDateTime(oProperties.ModificationDate)) + If oProperties.PrintDate.Year > 0 Then .Add("PrintDate", CDateFromUnoDateTime(oProperties.PrintDate)) + .Add("PrintedBy", oProperties.PrintedBy) + .Add("Subject", oProperties.Subject) + If oProperties.TemplateDate.Year > 0 Then .Add("TemplateDate", CDateFromUnoDateTime(oProperties.TemplateDate)) + .Add("TemplateName", oProperties.TemplateName) + .Add("TemplateURL", oProperties.TemplateURL) + .Add("Title", oProperties.Title) + End With + End If + +End Sub ' SFDocuments.SF_Document._LoadDocumentProperties + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim oProperties As Object ' Document or Custom properties +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + Select Case _DocumentType + Case "Calc" : cstThisSub = "SFDocuments.SF_" & _DocumentType & ".get" & psProperty + Case Else : cstThisSub = "SFDocuments.SF_Document.get" & psProperty + End Select + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case psProperty + Case "CustomProperties" + _CustomProperties = CreateScriptService("Dictionary") ' Always reload as updates could have been done manually by user + _CustomProperties.ImportFromPropertyValues(_Component.getDocumentProperties().UserDefinedProperties.getPropertyValues) + _PropertyGet = _CustomProperties + Case "Description" + _PropertyGet = _Component.DocumentProperties.Description + Case "DocumentProperties" + _LoadDocumentProperties() ' Always reload as updates could have been done manually by user + Set _PropertyGet = _DocumentProperties + Case "DocumentType" + _PropertyGet = _DocumentType + Case "ExportFilters" + _PropertyGet = _GetFilterNames(True) + Case "ImportFilters" + _PropertyGet = _GetFilterNames(False) + Case "IsBase", "IsCalc", "IsDraw", "IsImpress", "IsMath", "IsWriter" + _PropertyGet = ( Mid(psProperty, 3) = _DocumentType ) + Case "Keywords" + _PropertyGet = Join(_Component.DocumentProperties.Keywords, ", ") + Case "Readonly" + _PropertyGet = _Component.isReadonly() + Case "Subject" + _PropertyGet = _Component.DocumentProperties.Subject + Case "Title" + _PropertyGet = _Component.DocumentProperties.Title + Case "XComponent" + Set _PropertyGet = _Component + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Document._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Document instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DOCUMENT]: Type - File" + + _Repr = "[Document]: " & _DocumentType & " - " & _FileIdent() + +End Function ' SFDocuments.SF_Document._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_DOCUMENT +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_DocumentListener.xba b/wizards/source/sfdocuments/SF_DocumentListener.xba new file mode 100644 index 000000000..fbb0271bb --- /dev/null +++ b/wizards/source/sfdocuments/SF_DocumentListener.xba @@ -0,0 +1,114 @@ +<?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="SF_DocumentListener" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_DocumentListener +''' =================== +''' The current module is dedicated to the management of document events + listeners, triggered by user actions, +''' which cannot be defined with the Basic IDE +''' +''' Concerned listeners: +''' com.sun.star.sheet.XRangeSelectionListener +''' allowing a user to select a cell range at any moment +''' +''' The described events/listeners are processed by UNO listeners +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================= DEFINITIONS + +REM ============================================================= PRIVATE MEMBERS + +Private _SelectedRange As String ' The selected range is returned by a "done" event +Private _RangeSelectionFinished As Boolean ' Flag indicating that the interaction with the user has stopped + +REM ================================================================== EXCEPTIONS + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function RunRangeSelector(ByRef poComponent As Object _ + , ByRef pvPropertyValues As Variant _ + ) As String +''' Called from the SF_Calc.OpenRangeSelector() method +''' Opens a non-modal dialog with a text box, +''' let the user make a selection in the current or another sheet and +''' returns the selected area as a string. + +Dim oController As Object ' com.sun.star.frame.Controller +Dim oListener As Object ' com.sun.star.sheet.XRangeSelectionListener +Dim lCountLoops As Long ' Sleep cycles counter + +Const cstListenerPrefix = "_SFRGSEL_" ' Prefix used for naming events Subs +Const cstSleep = 50 ' Sleep steps in ms while waiting for the end of the interaction +Const cstMaxSleep = (60 * 5 * 1000) / cstSleep ' Never sleep more than 5 minutes. Afterwards, processing continues + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + ' Create the listener + Set oController = poComponent.CurrentController + Set oListener = CreateUnoListener(cstListenerPrefix, "com.sun.star.sheet.XRangeSelectionListener") + oController.addRangeSelectionListener(oListener) + + ' Open the selector + _SelectedRange = "" + _RangeSelectionFinished = False + oController.startRangeSelection(pvPropertyValues) + + ' Dummy thread synchronization + lCountLoops = 0 + Do While Not _RangeSelectionFinished And lCountLoops < cstMaxSleep + Wait(cstSleep) + lCountLoops = lCountLoops + 1 + Loop + +Finally: + If Not IsNull(oListener) Then oController.removeRangeSelectionListener(oListener) + RunRangeSelector = _SelectedRange + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_DocumentListener.RunRangeSelector + +REM ============================================================= PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Sub _SFRGSEL_done(Optional poEvent As Object) ' com.sun.star.sheet.RangeSelectionEvent + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + _SelectedRange = poEvent.RangeDescriptor + _RangeSelectionFinished = True + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub + +REM ----------------------------------------------------------------------------- +Sub _SFRGSEL_aborted(Optional poEvent As Object) ' com.sun.star.sheet.RangeSelectionEvent + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + _RangeSelectionFinished = True + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub + +REM ============================================ END OF SFDIALOGS.SF_DIALOGLISTENER +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Form.xba b/wizards/source/sfdocuments/SF_Form.xba new file mode 100644 index 000000000..404c24bd3 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Form.xba @@ -0,0 +1,1535 @@ +<?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="SF_Form" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Form +''' ======= +''' Management of forms defined in LibreOffice documents. Supported types are Base, Calc and Writer documents. +''' It includes the management of subforms +''' Each instance of the current class represents a single form or a single subform +''' +''' A form may optionally be (understand "is often") linked to a data source manageable with the SFDatabases.Database service +''' The current service offers a rapid access to that service +''' +''' Definitions: +''' +''' FormDocument: +''' For usual documents, there is only 1 form document. It is in fact the document itself. +''' A Base document may contain an unlimited number of form documents. +''' In the Base terminology they are called "forms" or "Base forms". This could create some confusion. +''' They can be organized in folders. Their name is then always the full path of folders + form +''' with the slash ("/") as path separator +''' A FormDocument is a set of Forms. Form names are visible in the user interface thanks to the form navigator +''' Often there is only 1 Form present in a FormDocument. Having more, however, might improve +''' the user experience significantly +''' +''' Form: WHERE IT IS ABOUT IN THE CURRENT "Form" SERVICE +''' Is an abstract set of Controls in an OPEN FormDocument +''' Each form is usually linked to one single dataset (table, query or Select statement), +''' located in any database (provided the user may access it) +''' A usual document may contain several forms. Each of which may have its own data source (database + dataset) +''' A Base form document may contain several forms. Each of which may address its own dataset. The database however is unique +''' A form is defined by its owning FormDocument and its FormName or FormIndex +''' +''' Service invocations: +''' +''' REM the form is stored in a not-Base document (Calc, Writer) +''' Dim oDoc As Object, myForm As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", ThisComponent) +''' Set myForm = oDoc.Forms("Form1") +''' ' or, alternatively, when there is only 1 form +''' Set myForm = oDoc.Forms(0) +''' +''' REM the form is stored in one of the FormDocuments of a Base document +''' Dim oDoc As Object, myForm As Object, mySubForm As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", ThisDatabaseDocument) +''' oDoc.OpenFormDocument("thisFormDocument") +''' Set myForm = oDoc.Forms("thisFormDocument", "MainForm") +''' ' or, alternatively, when there is only 1 form +''' Set myForm = oDoc.Forms("thisFormDocument", 0) +''' ' To access a subform: myForm and mySubForm become distinct instances of the current class +''' Set mySubForm = myForm.SubForms("mySubForm") +''' +''' REM the form is the subject of an event +''' Sub OnEvent(ByRef poEvent As Object) +''' Dim myForm As Object +''' Set myForm = CreateScriptService("SFDocuments.FormEvent", poEvent) +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_form.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const FORMDEADERROR = "FORMDEADERROR" +Private Const SUBFORMNOTFOUNDERROR = "SUBFORMNOTFOUNDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be Form +Private ServiceName As String + +' Form location +Private _Name As String ' Internal name of the form +Private _FormType As Integer ' One of the ISxxxFORM constants +Private _SheetName As String ' Name as the sheet containing the form (Calc only) +Private _FormDocumentName As String ' The hierarchical name of the containing form document (Base only) +Private _FormDocument As Object ' com.sun.star.comp.sdb.Content - the containing form document + ' The form topmost container +Private _Component As Object ' com.sun.star.lang.XComponent or com.sun.star.comp.dba.ODatabaseDocument + +' Events management +Private _CacheIndex As Long ' Index in central cache storage + +' Form UNO references +' The entry to the interactions with the form. Validity checked by the _IsStillAlive() method +' Each method or property requiring that the form is opened should first invoke that method +Private _Form As Object ' com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +Private _Database As Object ' Database class instance + +' Form attributes + +' Cache storage for controls +Private _ControlNames As Variant ' Array of control names +Private _ControlCache As Variant ' Array of control objects sorted like ElementNames of XForm + +REM ============================================================ MODULE CONSTANTS + +Const ISDOCFORM = 1 ' Form is stored in a Writer document +Const ISCALCFORM = 2 ' Form is stored in a Calc document +Const ISBASEFORM = 3 ' Form is stored in a Base document +Const ISSUBFORM = 4 ' Form is a subform of a form or of another subform +Const ISUNDEFINED = -1 ' Undefined form type + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "FORM" + ServiceName = "SFDocuments.Form" + _Name = "" + _SheetName = "" + _FormDocumentName = "" + Set _FormDocument = Nothing + _FormType = ISUNDEFINED + _CacheIndex = -1 + Set _Form = Nothing + Set _Database = Nothing + _ControlNames = Array() + _ControlCache = Array() +End Sub ' SFDocuments.SF_Form Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Form Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull(_Database) And (_FormType = ISDOCFORM Or _FormType = ISCALCFORM) Then + Set _Database = _Database.Dispose() + End If + SF_Register._CleanCacheEntry(_CacheIndex) + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Form Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get AllowDeletes() As Variant +''' The AllowDeletes property specifies if the form allows to delete records + AllowDeletes = _PropertyGet("AllowDeletes") +End Property ' SFDocuments.SF_Form.AllowDeletes (get) + +REM ----------------------------------------------------------------------------- +Property Let AllowDeletes(Optional ByVal pvAllowDeletes As Variant) +''' Set the updatable property AllowDeletes + _PropertySet("AllowDeletes", pvAllowDeletes) +End Property ' SFDocuments.SF_Form.AllowDeletes (let) + +REM ----------------------------------------------------------------------------- +Property Get AllowInserts() As Variant +''' The AllowInserts property specifies if the form allows to add records + AllowInserts = _PropertyGet("AllowInserts") +End Property ' SFDocuments.SF_Form.AllowInserts (get) + +REM ----------------------------------------------------------------------------- +Property Let AllowInserts(Optional ByVal pvAllowInserts As Variant) +''' Set the updatable property AllowInserts + _PropertySet("AllowInserts", pvAllowInserts) +End Property ' SFDocuments.SF_Form.AllowInserts (let) + +REM ----------------------------------------------------------------------------- +Property Get AllowUpdates() As Variant +''' The AllowUpdates property specifies if the form allows to update records + AllowUpdates = _PropertyGet("AllowUpdates") +End Property ' SFDocuments.SF_Form.AllowUpdates (get) + +REM ----------------------------------------------------------------------------- +Property Let AllowUpdates(Optional ByVal pvAllowUpdates As Variant) +''' Set the updatable property AllowUpdates + _PropertySet("AllowUpdates", pvAllowUpdates) +End Property ' SFDocuments.SF_Form.AllowUpdates (let) + +REM ----------------------------------------------------------------------------- +Property Get BaseForm() As String +''' The BaseForm property specifies the hierarchical name of the Base form containing the actual form + BaseForm = _PropertyGet("BaseForm") +End Property ' SFDocuments.SF_Form.BaseForm (get) + +REM ----------------------------------------------------------------------------- +Property Get Bookmark() As Variant +''' The Bookmark property specifies uniquely the current record of the form's underlying table, query or SQL statement. + Bookmark = _PropertyGet("Bookmark") +End Property ' SFDocuments.SF_Form.Bookmark (get) + +REM ----------------------------------------------------------------------------- +Property Let Bookmark(Optional ByVal pvBookmark As Variant) +''' Set the updatable property Bookmark + _PropertySet("Bookmark", pvBookmark) +End Property ' SFDocuments.SF_Form.Bookmark (let) + +REM ----------------------------------------------------------------------------- +Property Get CurrentRecord() As Variant +''' The CurrentRecord property identifies the current record in the recordset being viewed on a form + CurrentRecord = _PropertyGet("CurrentRecord") +End Property ' SFDocuments.SF_Form.CurrentRecord (get) + +REM ----------------------------------------------------------------------------- +Property Let CurrentRecord(Optional ByVal pvCurrentRecord As Variant) +''' Set the updatable property CurrentRecord +''' If the row number is positive, the cursor moves to the given row number with respect to the beginning of the result set. +''' The first row is row 1, the second is row 2, and so on. +''' If the given row number is negative, the cursor moves to an absolute row position with respect to the end of the result set. +''' For example, setting CurrentRecord = -1 positions the cursor on the last row, -2 indicates the next-to-last row, and so on + _PropertySet("CurrentRecord", pvCurrentRecord) +End Property ' SFDocuments.SF_Form.CurrentRecord (let) + +REM ----------------------------------------------------------------------------- +Property Get Filter() As Variant +''' The Filter property specifies a subset of records to be displayed. + Filter = _PropertyGet("Filter") +End Property ' SFDocuments.SF_Form.Filter (get) + +REM ----------------------------------------------------------------------------- +Property Let Filter(Optional ByVal pvFilter As Variant) +''' Set the updatable property Filter + _PropertySet("Filter", pvFilter) +End Property ' SFDocuments.SF_Form.Filter (let) + +REM ----------------------------------------------------------------------------- +Property Get LinkChildFields() As Variant +''' The LinkChildFields property specifies how records in a subform (child) are linked to records in its parent form +''' It returns an array of strings + LinkChildFields = _PropertyGet("LinkChildFields") +End Property ' SFDocuments.SF_Form.LinkChildFields (get) + +REM ----------------------------------------------------------------------------- +Property Get LinkParentFields() As Variant +''' The LinkParentFields property specifies how records in a subform (Child) are linked to records in its parent form +''' It returns an array of strings + LinkParentFields = _PropertyGet("LinkParentFields") +End Property ' SFDocuments.SF_Form.LinkParentFields (get) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual Form + Name = _PropertyGet("Name") +End Property ' SFDocuments.SF_Form.Name + +REM ----------------------------------------------------------------------------- +Property Get OnApproveCursorMove() As Variant +''' The OnApproveCursorMove property specifies the script to trigger when this event occurs + OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") +End Property ' SFDocuments.SF_Form.OnApproveCursorMove (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveCursorMove(Optional ByVal pvOnApproveCursorMove As Variant) +''' Set the updatable property OnApproveCursorMove + _PropertySet("OnApproveCursorMove", pvOnApproveCursorMove) +End Property ' SFDocuments.SF_Form.OnApproveCursorMove (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant +''' The OnApproveReset property specifies the script to trigger when this event occurs + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' SFDocuments.SF_Form.OnApproveReset (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveReset(Optional ByVal pvOnApproveReset As Variant) +''' Set the updatable property OnApproveReset + _PropertySet("OnApproveReset", pvOnApproveReset) +End Property ' SFDocuments.SF_Form.OnApproveReset (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveRowChange() As Variant +''' The OnApproveRowChange property specifies the script to trigger when this event occurs + OnApproveRowChange = _PropertyGet("OnApproveRowChange") +End Property ' SFDocuments.SF_Form.OnApproveRowChange (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveRowChange(Optional ByVal pvOnApproveRowChange As Variant) +''' Set the updatable property OnApproveRowChange + _PropertySet("OnApproveRowChange", pvOnApproveRowChange) +End Property ' SFDocuments.SF_Form.OnApproveRowChange (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveSubmit() As Variant +''' The OnApproveSubmit property specifies the script to trigger when this event occurs + OnApproveSubmit = _PropertyGet("OnApproveSubmit") +End Property ' SFDocuments.SF_Form.OnApproveSubmit (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveSubmit(Optional ByVal pvOnApproveSubmit As Variant) +''' Set the updatable property OnApproveSubmit + _PropertySet("OnApproveSubmit", pvOnApproveSubmit) +End Property ' SFDocuments.SF_Form.OnApproveSubmit (let) + +REM ----------------------------------------------------------------------------- +Property Get OnConfirmDelete() As Variant +''' The OnConfirmDelete property specifies the script to trigger when this event occurs + OnConfirmDelete = _PropertyGet("OnConfirmDelete") +End Property ' SFDocuments.SF_Form.OnConfirmDelete (get) + +REM ----------------------------------------------------------------------------- +Property Let OnConfirmDelete(Optional ByVal pvOnConfirmDelete As Variant) +''' Set the updatable property OnConfirmDelete + _PropertySet("OnConfirmDelete", pvOnConfirmDelete) +End Property ' SFDocuments.SF_Form.OnConfirmDelete (let) + +REM ----------------------------------------------------------------------------- +Property Get OnCursorMoved() As Variant +''' The OnCursorMoved property specifies the script to trigger when this event occurs + OnCursorMoved = _PropertyGet("OnCursorMoved") +End Property ' SFDocuments.SF_Form.OnCursorMoved (get) + +REM ----------------------------------------------------------------------------- +Property Let OnCursorMoved(Optional ByVal pvOnCursorMoved As Variant) +''' Set the updatable property OnCursorMoved + _PropertySet("OnCursorMoved", pvOnCursorMoved) +End Property ' SFDocuments.SF_Form.OnCursorMoved (let) + +REM ----------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant +''' The OnErrorOccurred property specifies the script to trigger when this event occurs + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' SFDocuments.SF_Form.OnErrorOccurred (get) + +REM ----------------------------------------------------------------------------- +Property Let OnErrorOccurred(Optional ByVal pvOnErrorOccurred As Variant) +''' Set the updatable property OnErrorOccurred + _PropertySet("OnErrorOccurred", pvOnErrorOccurred) +End Property ' SFDocuments.SF_Form.OnErrorOccurred (let) + +REM ----------------------------------------------------------------------------- +Property Get OnLoaded() As Variant +''' The OnLoaded property specifies the script to trigger when this event occurs + OnLoaded = _PropertyGet("OnLoaded") +End Property ' SFDocuments.SF_Form.OnLoaded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnLoaded(Optional ByVal pvOnLoaded As Variant) +''' Set the updatable property OnLoaded + _PropertySet("OnLoaded", pvOnLoaded) +End Property ' SFDocuments.SF_Form.OnLoaded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnReloaded() As Variant +''' The OnReloaded property specifies the script to trigger when this event occurs + OnReloaded = _PropertyGet("OnReloaded") +End Property ' SFDocuments.SF_Form.OnReloaded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnReloaded(Optional ByVal pvOnReloaded As Variant) +''' Set the updatable property OnReloaded + _PropertySet("OnReloaded", pvOnReloaded) +End Property ' SFDocuments.SF_Form.OnReloaded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnReloading() As Variant +''' The OnReloading property specifies the script to trigger when this event occurs + OnReloading = _PropertyGet("OnReloading") +End Property ' SFDocuments.SF_Form.OnReloading (get) + +REM ----------------------------------------------------------------------------- +Property Let OnReloading(Optional ByVal pvOnReloading As Variant) +''' Set the updatable property OnReloading + _PropertySet("OnReloading", pvOnReloading) +End Property ' SFDocuments.SF_Form.OnReloading (let) + +REM ----------------------------------------------------------------------------- +Property Get OnResetted() As Variant +''' The OnResetted property specifies the script to trigger when this event occurs + OnResetted = _PropertyGet("OnResetted") +End Property ' SFDocuments.SF_Form.OnResetted (get) + +REM ----------------------------------------------------------------------------- +Property Let OnResetted(Optional ByVal pvOnResetted As Variant) +''' Set the updatable property OnResetted + _PropertySet("OnResetted", pvOnResetted) +End Property ' SFDocuments.SF_Form.OnResetted (let) + +REM ----------------------------------------------------------------------------- +Property Get OnRowChanged() As Variant +''' The OnRowChanged property specifies the script to trigger when this event occurs + OnRowChanged = _PropertyGet("OnRowChanged") +End Property ' SFDocuments.SF_Form.OnRowChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnRowChanged(Optional ByVal pvOnRowChanged As Variant) +''' Set the updatable property OnRowChanged + _PropertySet("OnRowChanged", pvOnRowChanged) +End Property ' SFDocuments.SF_Form.OnRowChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnUnloaded() As Variant +''' The OnUnloaded property specifies the script to trigger when this event occurs + OnUnloaded = _PropertyGet("OnUnloaded") +End Property ' SFDocuments.SF_Form.OnUnloaded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnUnloaded(Optional ByVal pvOnUnloaded As Variant) +''' Set the updatable property OnUnloaded + _PropertySet("OnUnloaded", pvOnUnloaded) +End Property ' SFDocuments.SF_Form.OnUnloaded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnUnloading() As Variant +''' The OnUnloading property specifies the script to trigger when this event occurs + OnUnloading = _PropertyGet("OnUnloading") +End Property ' SFDocuments.SF_Form.OnUnloading (get) + +REM ----------------------------------------------------------------------------- +Property Let OnUnloading(Optional ByVal pvOnUnloading As Variant) +''' Set the updatable property OnUnloading + _PropertySet("OnUnloading", pvOnUnloading) +End Property ' SFDocuments.SF_Form.OnUnloading (let) + +REM ----------------------------------------------------------------------------- +Property Get OrderBy() As Variant +''' The OrderBy property specifies in which order the records should be displayed. + OrderBy = _PropertyGet("OrderBy") +End Property ' SFDocuments.SF_Form.OrderBy (get) + +REM ----------------------------------------------------------------------------- +Property Let OrderBy(Optional ByVal pvOrderBy As Variant) +''' Set the updatable property OrderBy + _PropertySet("OrderBy", pvOrderBy) +End Property ' SFDocuments.SF_Form.OrderBy (let) + +REM ----------------------------------------------------------------------------- +Property Get Parent() As Object +''' Return the Parent of the actual Form + Parent = _PropertyGet("Parent") +End Property ' SFDocuments.SF_Form.Parent + +REM ----------------------------------------------------------------------------- +Property Get RecordSource() As Variant +''' The RecordSource property specifies the source of the data, +''' a table name, a query name or a SQL statement + RecordSource = _PropertyGet("RecordSource") +End Property ' SFDocuments.SF_Form.RecordSource (get) + +REM ----------------------------------------------------------------------------- +Property Let RecordSource(Optional ByVal pvRecordSource As Variant) +''' Set the updatable property RecordSource + _PropertySet("RecordSource", pvRecordSource) +End Property ' SFDocuments.SF_Form.RecordSource (let) + +REM ----------------------------------------------------------------------------- +Property Get XForm() As Object +''' The XForm property returns the XForm UNO object of the Form + XForm = _PropertyGet("XForm") +End Property ' SFDocuments.SF_Form.XForm (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean +''' Set the focus on the current Form instance +''' Probably called from after an event occurrence or to focus on an open Base form document +''' If the parent document is ... +''' Calc Activate the corresponding sheet +''' Writer Activate the parent document +''' Base Activate the parent form document +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' myForm.Activate() + +Dim bActivate As Boolean ' Return value +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDocuments.Form.Activate" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActivate = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + Select Case _FormType + Case ISDOCFORM : bActivate = [_Parent].Activate() + Case ISCALCFORM : bActivate = [_Parent].Activate(_SheetName) + Case ISBASEFORM + Set oContainer = _FormDocument.Component.CurrentController.Frame.ContainerWindow + With oContainer + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .toFront() ' Force window change in Linux + Wait 1 ' Bypass desynchro issue in Linux + End With + bActivate = True + End Select + +Finally: + Activate = bActivate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseFormDocument() As Boolean +''' Close the form document containing the actual form instance +''' The form instance is disposed +''' The method does nothing if the actual form is not located in a Base form document +''' Args: +''' Returns: +''' True if closure is successful +''' Example: +''' myForm.CloseFormDocument() + +Dim bClose As Boolean ' Return value +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDocuments.Form.CloseFormDocument" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + Select Case _FormType + Case ISDOCFORM, ISCALCFORM, ISSUBFORM + Case ISBASEFORM + _FormDocument.close() + Dispose() + bClose = True + End Select + +Finally: + CloseFormDocument = bClose + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.CloseFormDocument + +REM ----------------------------------------------------------------------------- +Public Function Controls(Optional ByVal ControlName As Variant) As Variant +''' Return either +''' - the list of the controls contained in the Form +''' - a Form control object based on its name +''' Args: +''' ControlName: a valid control name as a case-sensitive string. If absent the list is returned +''' Returns: +''' A zero-base array of strings if ControlName is absent +''' An instance of the SF_FormControl class if ControlName exists +''' Exceptions: +''' ControlName is invalid +''' Example: +''' Dim myForm As Object, myList As Variant, myControl As Object +''' Set myForm = myDoc.Forms("myForm") +''' myList = myForm.Controls() +''' Set myControl = myForm.Controls("myTextBox") + +Dim oControl As Object ' The new control class instance +Dim lIndexOfNames As Long ' Index in ElementNames array. Used to access _ControlCache +Dim vControl As Variant ' Alias of _ControlCache entry +Dim i As Long +Const cstThisSub = "SFDocuments.Form.Controls" +Const cstSubArgs = "[ControlName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(ControlName) Or IsEmpty(ControlName) Then ControlName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING) Then GoTo Finally + End If + +Try: + ' Collect all control names if not yet done + If UBound(_ControlNames) < 0 Then + _ControlNames = _Form.getElementNames() + ' Remove all subforms from the list + For i = 0 To UBound(_ControlNames) + ' Subforms have no ClassId property + If Not ScriptForge.SF_Session.HasUnoProperty(_Form.getByName(_ControlNames(i)), "ClassId") Then _ControlNames(i) = "" + Next i + _ControlNames = ScriptForge.SF_Array.TrimArray(_ControlNames) + ' Size the cache accordingly + If UBound(_ControlNames) >= 0 Then + ReDim _ControlCache(0 To UBound(_ControlNames)) + End If + End If + + ' Return the list of controls or a FormControl instance + If Len(ControlName) = 0 Then + Controls = _ControlNames + + Else + + If Not _Form.hasByName(ControlName) Then GoTo CatchNotFound + lIndexOfNames = ScriptForge.SF_Array.IndexOf(_ControlNames, ControlName, CaseSensitive := True) + ' Reuse cache when relevant + vControl = _ControlCache(lIndexOfNames) + + If IsEmpty(vControl) Then + ' Create the new form control class instance + Set oControl = New SF_FormControl + With oControl + ._Name = ControlName + Set .[Me] = oControl + Set .[_Parent] = [Me] + Set ._ParentForm = [Me] + ._IndexOfNames = lIndexOfNames + ._FormName = _Name + ' Get model and view of the current control + Set ._ControlModel = _Form.getByName(ControlName) + ._Initialize() + End With + Else + Set oControl = vControl + End If + + Set Controls = oControl + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING, _Form.getElementNames()) + GoTo Finally +End Function ' SFDocuments.SF_Form.Controls + +REM ----------------------------------------------------------------------------- +Public Function GetDatabase(Optional ByVal User As Variant _ + , Optional ByVal Password As Variant _ + ) As Object +''' Returns a Database instance (service = SFDatabases.Database) giving access +''' to the execution of SQL commands on the database defined and/or stored in +''' the actual Base document +''' Each main form has its own database connection, except within Base documents where +''' they all share the same connection +''' Args: +''' User, Password: the login parameters as strings. Defaults = "" +''' Returns: +''' A SFDatabases.Database instance or Nothing +''' Example: +''' Dim myDb As Object +''' Set myDb = oForm.GetDatabase() + +Dim FSO As Object ' Alias for SF_FileSystem +Dim sUser As String ' Alias for User +Dim sPassword As String ' Alias for Password +Const cstThisSub = "SFDocuments.Form.GetDatabase" +Const cstSubArgs = "[User=""""], [Password=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set GetDatabase = Nothing + +Check: + If IsMissing(User) Or IsEmpty(User) Then User = "" + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(User, "User", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + End If + +Try: + ' Adjust connection arguments + If Len(User) = 0 Then + If ScriptForge.SF_Session.HasUnoProperty(_Form, "User") Then sUser = _Form.User Else sUser = "" + Else + sUser = User + End If + If Len(sUser) + Len(Password) = 0 Then + If ScriptForge.SF_Session.HasUnoProperty(_Form, "Password") Then sPassword = _Form.Password Else sPassword = Password + End If + + ' Connect to database, avoiding multiple requests + If IsNull(_Database) Then ' 1st connection request from the current form instance + If _FormType = ISBASEFORM Then + ' Fetch the shared connection + Set _Database = [_Parent].GetDatabase(User, Password) + ElseIf _FormType = ISSUBFORM Then + Set _Database = [_Parent].GetDatabase() ' Recursive call, climb the tree + ElseIf Len(_Form.DataSourceName) = 0 Then ' There is no database linked with the form + ' Return Nothing + Else + ' Check if DataSourceName is a file or a registered name and create database instance accordingly + Set FSO = ScriptForge.SF_FileSystem + If FSO.FileExists(FSO._ConvertFromUrl(_Form.DataSourceName)) Then + Set _Database = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database" _ + , _Form.DataSourceName, , , sUser, sPassword) + Else + Set _Database = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database" _ + , , _Form.DataSourceName, , sUser, sPassword) + End If + If IsNull(_Database) Then GoTo CatchConnect + End If + Else + EndIf + +Finally: + Set GetDatabase = _Database + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchConnect: + ScriptForge.SF_Exception.RaiseFatal(DBCONNECTERROR, "User", User, "Password", Password, [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Form.GetDatabase + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' oDlg.GetProperty("Caption") + +Const cstThisSub = "SFDocuments.Form.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Form service as an array + + Methods = Array( _ + "Activate" _ + , "CloseForm" _ + , "Controls" _ + , "GetDatabase" _ + , "MoveFirst" _ + , "MoveLast" _ + , "MoveNew" _ + , "MoveNext" _ + , "MovePrevious" _ + , "Requery" _ + , "SubForms" _ + ) + +End Function ' SFDocuments.SF_Form.Methods + +REM ----------------------------------------------------------------------------- +Public Function MoveFirst() As Boolean +''' The cursor is (re)positioned on the first row +''' Args: +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveFirst() + +Dim bMoveFirst As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.MoveFirst" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveFirst = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + bMoveFirst = .first() + End With + +Finally: + MoveFirst = bMoveFirst + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveFirst + +REM ----------------------------------------------------------------------------- +Public Function MoveLast() As Boolean +''' The cursor is (re)positioned on the last row +''' Args: +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveLast() + +Dim bMoveLast As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.MoveLast" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveLast = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + bMoveLast = .last() + End With + +Finally: + MoveLast = bMoveLast + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveLast + +REM ----------------------------------------------------------------------------- +Public Function MoveNew() As Boolean +''' The cursor is (re)positioned in the new record area +''' Args: +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveNew() + +Dim bMoveNew As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.MoveNew" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveNew = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + .last() ' To simulate the behaviour in the UI + .moveToInsertRow() + End With + bMoveNew = True + +Finally: + MoveNew = bMoveNew + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveNew + +REM ----------------------------------------------------------------------------- +Public Function MoveNext(Optional ByVal Offset As Variant) As Boolean +''' The cursor is (re)positioned on the next row +''' Args: +''' Offset: The number of records to go forward (default = 1) +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveNext() + +Dim bMoveNext As Boolean ' Return value +Dim lOffset As Long ' Alias of Offset +Const cstThisSub = "SFDocuments.Form.MoveNext" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveNext = False + +Check: + If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Finally + End If +Try: + lOffset = CLng(Offset) ' To be sure to have the right argument type + With _Form + If lOffset = 1 Then bMoveNext = .next() Else bMoveNext = .relative(lOffset) + End With + +Finally: + MoveNext = bMoveNext + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveNext + +REM ----------------------------------------------------------------------------- +Public Function MovePrevious(Optional ByVal Offset As Variant) As Boolean +''' The cursor is (re)positioned on the previous row +''' Args: +''' Offset: The number of records to go backward (default = 1) +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MovePrevious() + +Dim bMovePrevious As Boolean ' Return value +Dim lOffset As Long ' Alias of Offset +Const cstThisSub = "SFDocuments.Form.MovePrevious" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMovePrevious = False + +Check: + If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Finally + End If +Try: + lOffset = CLng(Offset) ' To be sure to have the right argument type + With _Form + If lOffset = 1 Then bMovePrevious = .previous() Else bMovePrevious = .relative(-lOffset) + End With + +Finally: + MovePrevious = bMovePrevious + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MovePrevious + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Form class as an array + + Properties = Array( _ + "AllowDeletes" _ + , "AllowInserts" _ + , "AllowUpdates" _ + , "BaseForm" _ + , "Bookmark" _ + , "CurrentRecord" _ + , "Filter" _ + , "LinkChildFields" _ + , "LinkParentFields" _ + , "Name" _ + , "OnApproveCursorMove" _ + , "OnApproveParameter" _ + , "OnApproveReset" _ + , "OnApproveRowChange" _ + , "OnApproveSubmit" _ + , "OnConfirmDelete" _ + , "OnCursorMoved" _ + , "OnErrorOccurred" _ + , "OnLoaded" _ + , "OnReloaded" _ + , "OnReloading" _ + , "OnResetted" _ + , "OnRowChanged" _ + , "OnUnloaded" _ + , "OnUnloading" _ + , "OrderBy" _ + , "Parent" _ + , "RecordSource" _ + , "XForm" _ + ) + +End Function ' SFDocuments.SF_Form.Properties + +REM ----------------------------------------------------------------------------- +Public Function Requery() As Boolean +''' Reload from the database the actual data into the form +''' The cursor is (re)positioned on the first row +''' Args: +''' Returns: +''' True if requery is successful +''' Example: +''' myForm.Requery() + +Dim bRequery As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.Requery" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRequery = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + If .isLoaded() Then .reload() Else .load() + End With + bRequery = True + +Finally: + Requery = bRequery + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.Requery + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Form.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Subforms(Optional ByVal Subform As Variant) As Variant +''' Return either +''' - the list of the subforms contained in the actual form or subform instance +''' - a SFDocuments.Form object based on its name or its index in the alphabetic list of subforms +''' Args: +''' Subform: a subform stored in the parent form given by its name or its index +''' When absent, the list of available subforms is returned +''' To get the first (unique ?) subform stored in the parent form, set Subform = 0 +''' Exceptions: +''' SUBFORMNOTFOUNDERROR Subform not found +''' Returns: +''' A zero-based array of strings if Subform is absent +''' An instance of the SF_Form class if Subform exists +''' Example: +''' Dim myForm As Object, myList As Variant, mySubform As Object +''' myList = myForm.Subforms() +''' Set mySubform = myForm.Subforms("mySubform") + +Dim oSubform As Object ' The new Form class instance +Dim oXSubform As Object ' com.sun.star.form.XForm +Dim vSubformNames As Variant ' Array of subform names +Dim i As Long +Const cstDrawPage = 0 ' Only 1 drawpage in a Writer document + +Const cstThisSub = "SFDocuments.Form.Subforms" +Const cstSubArgs = "[Subform=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Subform) Or IsEmpty(Subform) Then Subform = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Subform, "Subform", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + +Try: + ' Collect all control names and retain only the subforms + vSubformNames = _Form.getElementNames() + For i = 0 To UBound(vSubformNames) + Set oSubform = _Form.getByName(vSubformNames(i)) + ' Subforms are the only control types having no ClassId property + If ScriptForge.SF_Session.HasUnoProperty(oSubform, "ClassId") Then vSubformNames(i) = "" + Next i + vSubformNames = ScriptForge.SF_Array.TrimArray(vSubformNames) + + If Len(Subform) = 0 Then ' Return the list of valid subform names + Subforms = vSubformNames + Else + If VarType(Subform) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Array.Contains(vSubformNames, Subform, CaseSensitive := True) Then GoTo CatchNotFound + Set oXSubform = _Form.getByName(Subform) + Else ' Find the form by index + If Subform < 0 Or Subform > UBound(vSubformNames) Then GoTo CatchNotFound + Set oXSubform = _Form.getByName(vSubformNames(Subform)) + End If + ' Create the new Form class instance + Set oSubform = SF_Register._NewForm(oXSubform) + With oSubform + Set .[_Parent] = [Me] + ._FormType = ISSUBFORM + Set ._Component = _Component + Set ._FormDocument = _FormDocument + ._SheetName = _SheetName + ._FormDocumentName = _FormDocumentName + Set ._Database = _Database + ._Initialize() + End With + Set Subforms = oSubform + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(SUBFORMNOTFOUNDERROR, Subform, _Name) + GoTo Finally +End Function ' SFDocuments.SF_Form.Subforms + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDocuments.SF_Form._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnApproveCursorMove") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveParameter") + _GetListener = "XDatabaseParameterListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveRowChange") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveSubmit") + _GetListener = "XSubmitListener" + Case UCase("OnConfirmDelete") + _GetListener = "XConfirmDeleteListener" + Case UCase("OnCursorMoved"), UCase("OnRowChanged") + _GetListener = "XRowSetListener" + Case UCase("OnErrorOccurred") + _GetListener = "XSQLErrorListener" + Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") + _GetListener = "XLoadListener" + End Select + +End Function ' SFDocuments.SF_Form._GetListener + +REM ----------------------------------------------------------------------------- +Private Sub _GetParents() +''' When the current instance is created top-down, the parents are completely defined +''' and nothing should be done in this method +''' When the a class instance is created in a (form/control) event, it is the opposite +''' The current method rebuilds the missing members in the instance from the bottom +''' Members potentially to collect are: +''' - _FormType +''' - [_Parent], the immediate parent: a form or a document instance +''' + Only when the _FormType is a main form +''' - _SheetName (Calc only) +''' - _FormDocumentName (Base only) +''' - _FormDocument, the topmost form collection +''' - _Component, the containing document +''' They must be identified only starting from the _Form UNO object +''' +''' The method is called from the _Initialize() method at instance creation + +Dim oParent As Object ' Successive bottom-up parents +Dim sType As String ' UNO object type +Dim sPersistentName As String ' The Obj... name of a Base form +Dim iLevel As Integer ' When = 1 => first parent +Dim oSession As Object : Set oSession = ScriptForge.SF_Session + + On Local Error GoTo Finally ' Being probably called from events, this method should avoid failures + ' When the form type is known, the upper part of the branch is not scanned + If _FormType <> ISUNDEFINED Then GoTo Finally + +Try: + ' The whole branch is scanned bottom-up + If oSession.HasUnoProperty(_Form, "Parent") Then Set oParent = _Form.Parent Else Set oParent = Nothing + _FormType = ISUNDEFINED + iLevel = 1 + + Do While Not IsNull(oParent) + sType = SF_Session.UnoObjectType(oParent) + Select Case sType + ' Collect at each level the needed info + Case "com.sun.star.comp.forms.ODatabaseForm" ' The parent _Form of a subform + If iLevel = 1 Then + _FormType = ISSUBFORM + Set [_Parent] = SF_Register._NewForm(oParent) + ' Everything is in the parent, copy items and stop scan + [_Parent]._Initialize() ' Current method is called recursively here + With [_Parent] + _SheetName = ._SheetName + _FormDocumentName = ._FormDocumentName + Set _FormDocument = ._FormDocument + Set _Component = ._Component + End With + Exit Sub + End If + Case "com.sun.star.form.OFormsCollection" ' The collection of forms inside a drawpage + Case "SwXTextDocument" ' The parent document: a Writer document or a Base form document + If oParent.Identifier = "com.sun.star.sdb.FormDesign" Then + sPersistentName = ScriptForge._GetPropertyValue(oParent.Args, "HierarchicalDocumentName") + ElseIf oParent.Identifier = "com.sun.star.text.TextDocument" Then + _FormType = ISDOCFORM + Set [_Parent] = ScriptForge.SF_Services.CreateScriptService("SFDocuments.Document", oParent) + Set _Component = [_Parent]._Component + End If + Case "ScModelObj" ' The parent document: a Calc document + _FormType = ISCALCFORM + Set [_Parent] = ScriptForge.SF_Services.CreateScriptService("SFDocuments.Document", oParent) + Set _Component = oParent + ' The triggered form event is presumed to be located in the (drawpage of the) active sheet + _SheetName = [_Parent].XSpreadsheet("~") + Case "com.sun.star.comp.dba.ODatabaseDocument" ' The Base document + _FormType = ISBASEFORM + Set [_Parent] = ScriptForge.SF_Services.CreateScriptService("SFDocuments.Document", oParent) + Set _Component = oParent + If IsNull([_Parent]._FormDocuments) Then Set [_Parent]._FormDocuments = _Component.getFormDocuments() + Set _FormDocument = [_Parent]._FindByPersistentName([_Parent]._FormDocuments, sPersistentName) + _FormDocumentName = _FormDocument.HierarchicalName + Case Else + End Select + If oSession.HasUnoProperty(oParent, "Parent") Then Set oParent = oParent.Parent Else Set oParent = Nothing + iLevel = iLevel + 1 + Loop + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_Form._GetParents + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Achieve the creation of a SF_Form instance +''' - complete the missing private members +''' - store the new instance in the cache + + _GetParents() + _CacheIndex = SF_Register._AddFormToCache(_Form, [Me]) + +End Sub ' SFDocuments.SF_Form._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbError As Boolean) As Boolean +''' Return True if the Form is still open +''' If dead the actual instance is disposed +''' and the execution is cancelled when pbError = True (default) +''' Args: +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value +Dim sName As String ' Alias of _Name +Dim sId As String ' Alias of FileIdent + +Check: + On Local Error GoTo Catch ' Anticipate DisposedException errors or alike + If IsMissing(pbError) Then pbError = True + +Try: + ' At main form termination, all database connections are lost + bAlive = Not IsNull(_Form) + If Not bAlive Then GoTo Catch + +Finally: + _IsStillAlive = bAlive + Exit Function +Catch: + bAlive = False + On Error GoTo 0 + ' Keep error message elements before disposing the instance + sName = _SheetName & _FormDocumentName ' At least one of them is a zero-length string + sName = Iif(Len(sName) > 0, "[" & sName & "].", "") & _Name + If Not IsNull(_Component) Then sId = _Component.Location Else sId = "" + ' Dispose the actual forms instance + Dispose() + ' Display error message + If pbError Then ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, sName, sId) + GoTo Finally +End Function ' SFDocuments.SF_Form._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Static oSession As Object ' Alias of SF_Session +Dim vBookmark As Variant ' Form bookmark +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDocuments.Form.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + _PropertyGet = Empty + If Not _IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("AllowDeletes") + If Not IsNull(_Form) Then _PropertyGet = _Form.AllowDeletes + Case UCase("AllowInserts") + If Not IsNull(_Form) Then _PropertyGet = _Form.AllowInserts + Case UCase("AllowUpdates") + If Not IsNull(_Form) Then _PropertyGet = _Form.AllowUpdates + Case UCase("BaseForm") + _PropertyGet = _FormDocumentName + Case UCase("Bookmark") + If IsNull(_Form) Then + _PropertyGet = 0 + Else + On Local Error Resume Next ' Disable error handler because bookmarking does not always react well in events ... + If _Form.IsBookmarkable Then vBookmark = _Form.getBookmark() Else vBookmark = Nothing + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error Goto Catch Else On Local Error Goto 0 + If IsNull(vBookmark) Then Goto Catch + _PropertyGet = vBookmark + End If + Case UCase("CurrentRecord") + If IsNull(_Form) Then _PropertyGet = 0 Else _PropertyGet = _Form.Row + Case UCase("Filter") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = _Form.Filter + Case UCase("LinkChildFields") + If IsNull(_Form) Or _FormType <> ISSUBFORM Then _PropertyGet = Array() Else _PropertyGet = _Form.DetailFields + Case UCase("LinkParentFields") + If IsNull(_Form) Or _FormType <> ISSUBFORM Then _PropertyGet = Array() Else _PropertyGet = _Form.MasterFields + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = SF_Register._GetEventScriptCode(_Form, psProperty, _Name) + Case UCase("OrderBy") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = _Form.Order + Case UCase("Parent") + _PropertyGet = [_Parent] + Case UCase("RecordSource") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = _Form.Command + Case UCase("XForm") + Set _PropertyGet = _Form + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Dim oDatabase As Object ' Database class instance +Dim lCommandType As Long ' Record source type: 0 = Table, 1 = Query, 2 = SELECT +Dim sCommand As String ' Record source +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Form.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("AllowDeletes") + If Not ScriptForge.SF_Utils._Validate(pvValue, "AllowDeletes", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not IsNull(_Form) Then + _Form.AllowDeletes = pvValue + _Form.reload() + End If + Case UCase("AllowInserts") + If Not ScriptForge.SF_Utils._Validate(pvValue, "AllowInserts", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not IsNull(_Form) Then + _Form.AllowInserts = pvValue + _Form.reload() + End If + Case UCase("AllowUpdates") + If Not ScriptForge.SF_Utils._Validate(pvValue, "AllowUpdates", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not IsNull(_Form) Then + _Form.AllowUpdates = pvValue + _Form.reload() + End If + Case UCase("Bookmark") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Bookmark", Array(ScriptForge.V_NUMERIC, ScriptForge.V_OBJECT)) Then GoTo Finally + If Not IsNull(pvValue) And Not IsNull(_Form) Then bSet = _Form.moveToBookmark(pvValue) + Case UCase("CurrentRecord") + If Not ScriptForge.SF_Utils._Validate(pvValue, "CurrentRecord", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not IsNull(_Form) Then bSet = _Form.absolute(pvValue) + Case UCase("Filter") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Filter", V_STRING) Then GoTo Finally + If Not IsNull(_Form) Then + With _Form + If Len(pvValue) > 0 Then + Set oDatabase = GetDatabase() + If Not IsNull(oDatabase) Then .Filter = oDatabase._ReplaceSquareBrackets(pvValue) Else .Filter = pvValue + Else + .Filter = "" + End If + .ApplyFilter = True + .reload() + End With + End If + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then Goto Finally + If Not IsNull(_Form) Then + bSet = SF_Register._RegisterEventScript(_Form _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + , _Name _ + ) + End If + Case UCase("OrderBy") + If Not ScriptForge.SF_Utils._Validate(pvValue, "OrderBy", V_STRING) Then GoTo Finally + If Not IsNull(_Form) Then + With _Form + If Len(pvValue) > 0 Then + Set oDatabase = GetDatabase() + If Not IsNull(oDatabase) Then .Order = oDatabase._ReplaceSquareBrackets(pvValue) Else .Order = pvValue + Else + .Order = "" + End If + .reload() + End With + End If + Case UCase("RecordSource") + If Not ScriptForge.SF_Utils._Validate(pvValue, "RecordSource", V_STRING) Then GoTo Finally + If Not IsNull(_Form) And Len(pvValue) > 0 Then + Set oDatabase = GetDatabase() + If Not IsNull(oDatabase) Then + With oDatabase + If ScriptForge.SF_Array.Contains(.Tables, pvValue, CaseSensitive := True) Then + sCommand = pvValue + lCommandType = com.sun.star.sdb.CommandType.TABLE + ElseIf ScriptForge.SF_Array.Contains(.Queries, pvValue, CaseSensitive := True) Then + sCommand = pvValue + lCommandType = com.sun.star.sdb.CommandType.QUERY + ElseIf ScriptForge.SF_String.StartsWith(pvValue, "SELECT", CaseSensitive := False) Then + sCommand = .ReplaceSquareBrackets(pvValue) + lCommandType = com.sun.star.sdb.CommandType.COMMAND + End If + _Form.Command = sCommand + _Form.CommandType = lCommandType + End With + End If + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Form]: Name" + +Dim sParent As String ' To recognize the parent + + sParent = _SheetName & _FormDocumentName ' At least one of them is a zero-length string + _Repr = "[Form]: " & Iif(Len(sParent) > 0, sParent & "...", "") & _Name + +End Function ' SFDocuments.SF_Form._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_FORM +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_FormControl.xba b/wizards/source/sfdocuments/SF_FormControl.xba new file mode 100644 index 000000000..a48c22b6c --- /dev/null +++ b/wizards/source/sfdocuments/SF_FormControl.xba @@ -0,0 +1,1888 @@ +<?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="SF_FormControl" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_FormControl +''' ================ +''' Manage the controls belonging to a form or subform stored in a document +''' Each instance of the current class represents a single control within a form, a subform or a tablecontrol +''' A prerequisite is that all controls within the same form, subform or tablecontrol must have +''' a unique name. This is also true for the individual radio buttons belonging to the same group. +''' A common group name must identify such a single group. +''' +''' The focus is clearly set on getting and setting the values displayed by the controls of the form, +''' not on their formatting. The latter is easily accessible via the XControlModel and XControlView +''' UNO objects. +''' Essentially a single property "Value" maps many alternative UNO properties depending each on +''' the control type. +''' +''' Service invocations: +''' Dim myForm As Object, myControl As Object +''' Set myForm = ... (read the comments in the SF_Form module) +''' Set myControl = myForm.Controls("myTextBox") +''' myControl.Value = "Current time = " & Now() +''' +''' REM the control is the subject of an event +''' Sub OnEvent(ByRef poEvent As Object) +''' Dim myControl As Object +''' Set myControl = CreateScriptService("SFDocuments.FormEvent", poEvent) +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_formcontrol.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const FORMCONTROLTYPEERROR = "FORMCONTROLTYPEERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be FORMCONTROL +Private ServiceName As String + +' Control naming and context +Private _Name As String +Private _IndexOfNames As Long ' Index in ElementNames array. Used to access SF_Form._ControlCache +Private _FormName As String ' Parent form name +Private _ParentForm As Object ' Parent form or subform instance +Private _ParentIsTable As Boolean ' True when parent is a table control + +' Control UNO references +Private _ControlModel As Object ' com.sun.star.awt.XControlModel +Private _ControlView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl + +' Control attributes +Private _ImplementationName As String +Private _ControlType As String ' One of the CTLxxx constants +Private _ClassId As Integer ' Numerical type of control + +' Cache storage for table controls +Private _ControlNames As Variant ' Array of control names +Private _ControlCache As Variant ' Array of control objects sorted like ElementNames of XControlModel + +REM ============================================================ MODULE CONSTANTS + +' ClassId +Private Const CTLBUTTON = "Button" ' 2 +Private Const CTLCHECKBOX = "CheckBox" ' 5 +Private Const CTLCOMBOBOX = "ComboBox" ' 7 +Private Const CTLCURRENCYFIELD = "CurrencyField" ' 18 +Private Const CTLDATEFIELD = "DateField" ' 15 +Private Const CTLFILECONTROL = "FileControl" ' 12 +Private Const CTLFIXEDTEXT = "FixedText" ' 10 +Private Const CTLFORMATTEDFIELD = "FormattedField" ' Idem TextField +Private Const CTLGROUPBOX = "GroupBox" ' 8 +Private Const CTLHIDDENCONTROL = "HiddenControl" ' 13 +Private Const CTLIMAGEBUTTON = "ImageButton" ' 4 +Private Const CTLIMAGECONTROL = "ImageControl" ' 14 +Private Const CTLLISTBOX = "ListBox" ' 6 +Private Const CTLNAVIGATIONBAR = "NavigationBar" ' 22 +Private Const CTLNUMERICFIELD = "NumericField" ' 17 +Private Const CTLPATTERNFIELD = "PatternField" ' 19 +Private Const CTLRADIOBUTTON = "RadioButton" ' 3 +Private Const CTLSCROLLBAR = "ScrollBar" ' 20 +Private Const CTLSPINBUTTON = "SpinButton" ' 21 +Private Const CTLTABLECONTROL = "TableControl" ' 11 +Private Const CTLTEXTFIELD = "TextField" ' 9 +Private Const CTLTIMEFIELD = "TimeField" ' 16 + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "FORMCONTROL" + ServiceName = "SFDocuments.FormControl" + _Name = "" + _IndexOfNames = -1 + _FormName = "" + _ParentIsTable = False + Set _ParentForm = Nothing + Set _ControlModel = Nothing + Set _ControlView = Nothing + _ImplementationName = "" + _ControlType = "" + _ClassId = 0 + _ControlNames = Array() + _ControlCache = Array() +End Sub ' SFDocuments.SF_FormControl Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_FormControl Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Parent]) And _IndexOfNames >= 0 Then [_Parent]._ControlCache(_IndexOfNames) = Empty + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_FormControl Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Action() As Variant +''' The Action property specifies the action triggered when the button is clicked +''' Accepted values: none, submitForm, resetForm, refreshForm, moveToFirst, moveToLast, +''' moveToNext, moveToPrev, saveRecord, moveToNew, deleteRecord, undoRecord + Action = _PropertyGet("Action", "") +End Property ' SFDocuments.SF_FormControl.Action (get) + +REM ----------------------------------------------------------------------------- +Property Let Action(Optional ByVal pvAction As Variant) +''' Set the updatable property Action + _PropertySet("Action", pvAction) +End Property ' SFDocuments.SF_FormControl.Action (let) + +REM ----------------------------------------------------------------------------- +Property Get Caption() As Variant +''' The Caption property refers to the text associated with the control + Caption = _PropertyGet("Caption", "") +End Property ' SFDocuments.SF_FormControl.Caption (get) + +REM ----------------------------------------------------------------------------- +Property Let Caption(Optional ByVal pvCaption As Variant) +''' Set the updatable property Caption + _PropertySet("Caption", pvCaption) +End Property ' SFDocuments.SF_FormControl.Caption (let) + +REM ----------------------------------------------------------------------------- +Property Get ControlSource() As Variant +''' The ControlSource property specifies the rowset field mapped onto the actual control + ControlSource = _PropertyGet("ControlSource", "") +End Property ' SFDocuments.SF_FormControl.ControlSource (get) + +REM ----------------------------------------------------------------------------- +Property Get ControlType() As String +''' Return the type of the actual control: "CheckBox", "TextField", "DateField", ... + ControlType = _PropertyGet("ControlType") +End Property ' SFDocuments.SF_FormControl.ControlType + +REM ----------------------------------------------------------------------------- +Property Get Default() As Variant +''' The Default property specifies whether a command button is the default (OK) button. + Default = _PropertyGet("Default", False) +End Property ' SFDocuments.SF_FormControl.Default (get) + +REM ----------------------------------------------------------------------------- +Property Let Default(Optional ByVal pvDefault As Variant) +''' Set the updatable property Default + _PropertySet("Default", pvDefault) +End Property ' SFDocuments.SF_FormControl.Default (let) + +REM ----------------------------------------------------------------------------- +Property Get DefaultValue() As Variant +''' The DefaultValue property specifies how the control is initialized in a new record + DefaultValue = _PropertyGet("DefaultValue", Null) +End Property ' SFDocuments.SF_FormControl.DefaultValue (get) + +REM ----------------------------------------------------------------------------- +Property Let DefaultValue(Optional ByVal pvDefaultValue As Variant) +''' Set the updatable property DefaultValue + _PropertySet("DefaultValue", pvDefaultValue) +End Property ' SFDocuments.SF_FormControl.DefaultValue (let) + +REM ----------------------------------------------------------------------------- +Property Get Enabled() As Variant +''' The Enabled property specifies if the control is accessible with the cursor. + Enabled = _PropertyGet("Enabled", False) +End Property ' SFDocuments.SF_FormControl.Enabled (get) + +REM ----------------------------------------------------------------------------- +Property Let Enabled(Optional ByVal pvEnabled As Variant) +''' Set the updatable property Enabled + _PropertySet("Enabled", pvEnabled) +End Property ' SFDocuments.SF_FormControl.Enabled (let) + +REM ----------------------------------------------------------------------------- +Property Get Format() As Variant +''' The Format property specifies the format in which to display dates and times. + Format = _PropertyGet("Format", "") +End Property ' SFDocuments.SF_FormControl.Format (get) + +REM ----------------------------------------------------------------------------- +Property Let Format(Optional ByVal pvFormat As Variant) +''' Set the updatable property Format +''' NB: Format is read-only for formatted field controls + _PropertySet("Format", pvFormat) +End Property ' SFDocuments.SF_FormControl.Format (let) + +REM ----------------------------------------------------------------------------- +Property Get ListCount() As Long +''' The ListCount property specifies the number of rows in a list box or a combo box + ListCount = _PropertyGet("ListCount", 0) +End Property ' SFDocuments.SF_FormControl.ListCount (get) + +REM ----------------------------------------------------------------------------- +Property Get ListIndex() As Variant +''' The ListIndex property specifies which item is selected in a list box or combo box. +''' In case of multiple selection, the index of the first one is returned or only one is set + ListIndex = _PropertyGet("ListIndex", -1) +End Property ' SFDocuments.SF_FormControl.ListIndex (get) + +REM ----------------------------------------------------------------------------- +Property Let ListIndex(Optional ByVal pvListIndex As Variant) +''' Set the updatable property ListIndex + _PropertySet("ListIndex", pvListIndex) +End Property ' SFDocuments.SF_FormControl.ListIndex (let) + +REM ----------------------------------------------------------------------------- +Property Get ListSource() As Variant +''' The ListSource property specifies the data contained in a combobox or a listbox +''' as a zero-based array of string values + ListSource = _PropertyGet("ListSource", "") +End Property ' SFDocuments.SF_FormControl.ListSource (get) + +REM ----------------------------------------------------------------------------- +Property Let ListSource(Optional ByVal pvListSource As Variant) +''' Set the updatable property ListSource + _PropertySet("ListSource", pvListSource) +End Property ' SFDocuments.SF_FormControl.ListSource (let) + +REM ----------------------------------------------------------------------------- +Property Get ListSourceType() As Variant +''' The ListSourceType property specifies the kind of data source used to fill the list data of a listbox or a combobox + ListSourceType = _PropertyGet("ListSourceType", "") +End Property ' SFDocuments.SF_FormControl.ListSourceType (get) + +REM ----------------------------------------------------------------------------- +Property Let ListSourceType(Optional ByVal pvListSourceType As Variant) +''' Set the updatable property ListSourceType + _PropertySet("ListSourceType", pvListSourceType) +End Property ' SFDocuments.SF_FormControl.ListSourceType (let) + +REM ----------------------------------------------------------------------------- +Property Get Locked() As Variant +''' The Locked property specifies if a control is read-only + Locked = _PropertyGet("Locked", False) +End Property ' SFDocuments.SF_FormControl.Locked (get) + +REM ----------------------------------------------------------------------------- +Property Let Locked(Optional ByVal pvLocked As Variant) +''' Set the updatable property Locked + _PropertySet("Locked", pvLocked) +End Property ' SFDocuments.SF_FormControl.Locked (let) + +REM ----------------------------------------------------------------------------- +Property Get MultiSelect() As Variant +''' The MultiSelect property specifies whether a user can make multiple selections in a listbox + MultiSelect = _PropertyGet("MultiSelect", False) +End Property ' SFDocuments.SF_FormControl.MultiSelect (get) + +REM ----------------------------------------------------------------------------- +Property Let MultiSelect(Optional ByVal pvMultiSelect As Variant) +''' Set the updatable property MultiSelect + _PropertySet("MultiSelect", pvMultiSelect) +End Property ' SFDocuments.SF_FormControl.MultiSelect (let) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual control + Name = _PropertyGet("Name") +End Property ' SFDocuments.SF_FormControl.Name + +REM ----------------------------------------------------------------------------- +Property Get OnActionPerformed() As Variant +''' Get the script associated with the OnActionPerformed event + OnActionPerformed = _PropertyGet("OnActionPerformed", "") +End Property ' SFDocuments.SF_FormControl.OnActionPerformed (get) + +REM ----------------------------------------------------------------------------- +Property Let OnActionPerformed(Optional ByVal pvOnActionPerformed As Variant) +''' Set the updatable property OnActionPerformed + _PropertySet("OnActionPerformed", pvOnActionPerformed) +End Property ' SFDocuments.SF_FormControl.OnActionPerformed (let) + +REM ----------------------------------------------------------------------------- +Property Get OnAdjustmentValueChanged() As Variant +''' Get the script associated with the OnAdjustmentValueChanged event + OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged", "") +End Property ' SFDocuments.SF_FormControl.OnAdjustmentValueChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnAdjustmentValueChanged(Optional ByVal pvOnAdjustmentValueChanged As Variant) +''' Set the updatable property OnAdjustmentValueChanged + _PropertySet("OnAdjustmentValueChanged", pvOnAdjustmentValueChanged) +End Property ' SFDocuments.SF_FormControl.OnAdjustmentValueChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveAction() As Variant +''' Get the script associated with the OnApproveAction event + OnApproveAction = _PropertyGet("OnApproveAction", "") +End Property ' SFDocuments.SF_FormControl.OnApproveAction (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveAction(Optional ByVal pvOnApproveAction As Variant) +''' Set the updatable property OnApproveAction + _PropertySet("OnApproveAction", pvOnApproveAction) +End Property ' SFDocuments.SF_FormControl.OnApproveAction (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant +''' Get the script associated with the OnApproveReset event + OnApproveReset = _PropertyGet("OnApproveReset", "") +End Property ' SFDocuments.SF_FormControl.OnApproveReset (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveReset(Optional ByVal pvOnApproveReset As Variant) +''' Set the updatable property OnApproveReset + _PropertySet("OnApproveReset", pvOnApproveReset) +End Property ' SFDocuments.SF_FormControl.OnApproveReset (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveUpdate() As Variant +''' Get the script associated with the OnApproveUpdate event + OnApproveUpdate = _PropertyGet("OnApproveUpdate", "") +End Property ' SFDocuments.SF_FormControl.OnApproveUpdate (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveUpdate(Optional ByVal pvOnApproveUpdate As Variant) +''' Set the updatable property OnApproveUpdate + _PropertySet("OnApproveUpdate", pvOnApproveUpdate) +End Property ' SFDocuments.SF_FormControl.OnApproveUpdate (let) + +REM ----------------------------------------------------------------------------- +Property Get OnChanged() As Variant +''' Get the script associated with the OnChanged event + OnChanged = _PropertyGet("OnChanged", "") +End Property ' SFDocuments.SF_FormControl.OnChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnChanged(Optional ByVal pvOnChanged As Variant) +''' Set the updatable property OnChanged + _PropertySet("OnChanged", pvOnChanged) +End Property ' SFDocuments.SF_FormControl.OnChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant +''' Get the script associated with the OnErrorOccurred event + OnErrorOccurred = _PropertyGet("OnErrorOccurred", "") +End Property ' SFDocuments.SF_FormControl.OnErrorOccurred (get) + +REM ----------------------------------------------------------------------------- +Property Let OnErrorOccurred(Optional ByVal pvOnErrorOccurred As Variant) +''' Set the updatable property OnErrorOccurred + _PropertySet("OnErrorOccurred", pvOnErrorOccurred) +End Property ' SFDocuments.SF_FormControl.OnErrorOccurred (let) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant +''' Get the script associated with the OnFocusGained event + OnFocusGained = _PropertyGet("OnFocusGained", "") +End Property ' SFDocuments.SF_FormControl.OnFocusGained (get) + +REM ----------------------------------------------------------------------------- +Property Let OnFocusGained(Optional ByVal pvOnFocusGained As Variant) +''' Set the updatable property OnFocusGained + _PropertySet("OnFocusGained", pvOnFocusGained) +End Property ' SFDocuments.SF_FormControl.OnFocusGained (let) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant +''' Get the script associated with the OnFocusLost event + OnFocusLost = _PropertyGet("OnFocusLost", "") +End Property ' SFDocuments.SF_FormControl.OnFocusLost (get) + +REM ----------------------------------------------------------------------------- +Property Let OnFocusLost(Optional ByVal pvOnFocusLost As Variant) +''' Set the updatable property OnFocusLost + _PropertySet("OnFocusLost", pvOnFocusLost) +End Property ' SFDocuments.SF_FormControl.OnFocusLost (let) + +REM ----------------------------------------------------------------------------- +Property Get OnItemStateChanged() As Variant +''' Get the script associated with the OnItemStateChanged event + OnItemStateChanged = _PropertyGet("OnItemStateChanged", "") +End Property ' SFDocuments.SF_FormControl.OnItemStateChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnItemStateChanged(Optional ByVal pvOnItemStateChanged As Variant) +''' Set the updatable property OnItemStateChanged + _PropertySet("OnItemStateChanged", pvOnItemStateChanged) +End Property ' SFDocuments.SF_FormControl.OnItemStateChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant +''' Get the script associated with the OnKeyPressed event + OnKeyPressed = _PropertyGet("OnKeyPressed", "") +End Property ' SFDocuments.SF_FormControl.OnKeyPressed (get) + +REM ----------------------------------------------------------------------------- +Property Let OnKeyPressed(Optional ByVal pvOnKeyPressed As Variant) +''' Set the updatable property OnKeyPressed + _PropertySet("OnKeyPressed", pvOnKeyPressed) +End Property ' SFDocuments.SF_FormControl.OnKeyPressed (let) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant +''' Get the script associated with the OnKeyReleased event + OnKeyReleased = _PropertyGet("OnKeyReleased", "") +End Property ' SFDocuments.SF_FormControl.OnKeyReleased (get) + +REM ----------------------------------------------------------------------------- +Property Let OnKeyReleased(Optional ByVal pvOnKeyReleased As Variant) +''' Set the updatable property OnKeyReleased + _PropertySet("OnKeyReleased", pvOnKeyReleased) +End Property ' SFDocuments.SF_FormControl.OnKeyReleased (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant +''' Get the script associated with the OnMouseDragged event + OnMouseDragged = _PropertyGet("OnMouseDragged", "") +End Property ' SFDocuments.SF_FormControl.OnMouseDragged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseDragged(Optional ByVal pvOnMouseDragged As Variant) +''' Set the updatable property OnMouseDragged + _PropertySet("OnMouseDragged", pvOnMouseDragged) +End Property ' SFDocuments.SF_FormControl.OnMouseDragged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant +''' Get the script associated with the OnMouseEntered event + OnMouseEntered = _PropertyGet("OnMouseEntered", "") +End Property ' SFDocuments.SF_FormControl.OnMouseEntered (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseEntered(Optional ByVal pvOnMouseEntered As Variant) +''' Set the updatable property OnMouseEntered + _PropertySet("OnMouseEntered", pvOnMouseEntered) +End Property ' SFDocuments.SF_FormControl.OnMouseEntered (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant +''' Get the script associated with the OnMouseExited event + OnMouseExited = _PropertyGet("OnMouseExited", "") +End Property ' SFDocuments.SF_FormControl.OnMouseExited (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseExited(Optional ByVal pvOnMouseExited As Variant) +''' Set the updatable property OnMouseExited + _PropertySet("OnMouseExited", pvOnMouseExited) +End Property ' SFDocuments.SF_FormControl.OnMouseExited (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant +''' Get the script associated with the OnMouseMoved event + OnMouseMoved = _PropertyGet("OnMouseMoved", "") +End Property ' SFDocuments.SF_FormControl.OnMouseMoved (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseMoved(Optional ByVal pvOnMouseMoved As Variant) +''' Set the updatable property OnMouseMoved + _PropertySet("OnMouseMoved", pvOnMouseMoved) +End Property ' SFDocuments.SF_FormControl.OnMouseMoved (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant +''' Get the script associated with the OnMousePressed event + OnMousePressed = _PropertyGet("OnMousePressed", "") +End Property ' SFDocuments.SF_FormControl.OnMousePressed (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMousePressed(Optional ByVal pvOnMousePressed As Variant) +''' Set the updatable property OnMousePressed + _PropertySet("OnMousePressed", pvOnMousePressed) +End Property ' SFDocuments.SF_FormControl.OnMousePressed (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant +''' Get the script associated with the OnMouseReleased event + OnMouseReleased = _PropertyGet("OnMouseReleased", "") +End Property ' SFDocuments.SF_FormControl.OnMouseReleased (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseReleased(Optional ByVal pvOnMouseReleased As Variant) +''' Set the updatable property OnMouseReleased + _PropertySet("OnMouseReleased", pvOnMouseReleased) +End Property ' SFDocuments.SF_FormControl.OnMouseReleased (let) + +REM ----------------------------------------------------------------------------- +Property Get OnResetted() As Variant +''' Get the script associated with the OnResetted event + OnResetted = _PropertyGet("OnResetted", "") +End Property ' SFDocuments.SF_FormControl.OnResetted (get) + +REM ----------------------------------------------------------------------------- +Property Let OnResetted(Optional ByVal pvOnResetted As Variant) +''' Set the updatable property OnResetted + _PropertySet("OnResetted", pvOnResetted) +End Property ' SFDocuments.SF_FormControl.OnResetted (let) + +REM ----------------------------------------------------------------------------- +Property Get OnTextChanged() As Variant +''' Get the script associated with the OnTextChanged event + OnTextChanged = _PropertyGet("OnTextChanged", "") +End Property ' SFDocuments.SF_FormControl.OnTextChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnTextChanged(Optional ByVal pvOnTextChanged As Variant) +''' Set the updatable property OnTextChanged + _PropertySet("OnTextChanged", pvOnTextChanged) +End Property ' SFDocuments.SF_FormControl.OnTextChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnUpdated() As Variant +''' Get the script associated with the OnUpdated event + OnUpdated = _PropertyGet("OnUpdated", "") +End Property ' SFDocuments.SF_FormControl.OnUpdated (get) + +REM ----------------------------------------------------------------------------- +Property Let OnUpdated(Optional ByVal pvOnUpdated As Variant) +''' Set the updatable property OnUpdated + _PropertySet("OnUpdated", pvOnUpdated) +End Property ' SFDocuments.SF_FormControl.OnUpdated (let) + +REM ----------------------------------------------------------------------------- +Property Get Parent() As Object +''' Return the Parent form or [table]control object of the actual control + Parent = _PropertyGet("Parent", Nothing) +End Property ' SFDocuments.SF_FormControl.Parent + +REM ----------------------------------------------------------------------------- +Property Get Picture() As Variant +''' The Picture property specifies a bitmap or other type of graphic to be displayed on the specified control + Picture = _PropertyGet("Picture", "") +End Property ' SFDocuments.SF_FormControl.Picture (get) + +REM ----------------------------------------------------------------------------- +Property Let Picture(Optional ByVal pvPicture As Variant) +''' Set the updatable property Picture + _PropertySet("Picture", pvPicture) +End Property ' SFDocuments.SF_FormControl.Picture (let) + +REM ----------------------------------------------------------------------------- +Property Get Required() As Variant +''' A control is said Required when it must not contain a null value + Required = _PropertyGet("Required", False) +End Property ' SFDocuments.SF_FormControl.Required (get) + +REM ----------------------------------------------------------------------------- +Property Let Required(Optional ByVal pvRequired As Variant) +''' Set the updatable property Required + _PropertySet("Required", pvRequired) +End Property ' SFDocuments.SF_FormControl.Required (let) + +REM ----------------------------------------------------------------------------- +Property Get Text() As Variant +''' The Text property specifies the actual content of the control like it is displayed on the screen + Text = _PropertyGet("Text", "") +End Property ' SFDocuments.SF_FormControl.Text (get) + +REM ----------------------------------------------------------------------------- +Property Get TipText() As Variant +''' The TipText property specifies the text that appears in a screentip when you hold the mouse pointer over a control + TipText = _PropertyGet("TipText", "") +End Property ' SFDocuments.SF_FormControl.TipText (get) + +REM ----------------------------------------------------------------------------- +Property Let TipText(Optional ByVal pvTipText As Variant) +''' Set the updatable property TipText + _PropertySet("TipText", pvTipText) +End Property ' SFDocuments.SF_FormControl.TipText (let) + +REM ----------------------------------------------------------------------------- +Property Get TripleState() As Variant +''' The TripleState property specifies how a check box will display Null values +''' When True, the control will cycle through states for Yes, No, and Null values. The control appears dimmed (grayed) when its Value property is set to Null. +''' When False, the control will cycle through states for Yes and No values. Null values display as if they were No values. + TripleState = _PropertyGet("TripleState", False) +End Property ' SFDocuments.SF_FormControl.TripleState (get) + +REM ----------------------------------------------------------------------------- +Property Let TripleState(Optional ByVal pvTripleState As Variant) +''' Set the updatable property TripleState + _PropertySet("TripleState", pvTripleState) +End Property ' SFDocuments.SF_FormControl.TripleState (let) + +REM ----------------------------------------------------------------------------- +Property Get Value() As Variant +''' The Value property specifies the data contained in the control + Value = _PropertyGet("Value", Empty) +End Property ' SFDocuments.SF_FormControl.Value (get) + +REM ----------------------------------------------------------------------------- +Property Let Value(Optional ByVal pvValue As Variant) +''' Set the updatable property Value + _PropertySet("Value", pvValue) +End Property ' SFDocuments.SF_FormControl.Value (let) + +REM ----------------------------------------------------------------------------- +Property Get Visible() As Variant +''' The Visible property specifies if the control is accessible with the cursor. + Visible = _PropertyGet("Visible", True) +End Property ' SFDocuments.SF_FormControl.Visible (get) + +REM ----------------------------------------------------------------------------- +Property Let Visible(Optional ByVal pvVisible As Variant) +''' Set the updatable property Visible + _PropertySet("Visible", pvVisible) +End Property ' SFDocuments.SF_FormControl.Visible (let) + +REM ----------------------------------------------------------------------------- +Property Get XControlModel() As Object +''' The XControlModel property returns the model UNO object of the control + XControlModel = _PropertyGet("XControlModel", Nothing) +End Property ' SFDocuments.SF_FormControl.XControlModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XControlView() As Object +''' The XControlView property returns the view UNO object of the control + XControlView = _PropertyGet("XControlView", Nothing) +End Property ' SFDocuments.SF_FormControl.XControlView (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Controls(Optional ByVal ControlName As Variant) As Variant +''' Return either +''' - the list of the controls contained in the actual table control +''' - a Form Control object based on its name +''' Args: +''' ControlName: a valid control name as a case-sensitive string. If absent the list is returned +''' Returns: +''' A zero-base array of strings if ControlName is absent +''' An instance of the SF_FormControl class if ControlName exists +''' Exceptions: +''' ControlName is invalid +''' Example: +''' Dim myGrid As Object, myList As Variant, myControl As Object +''' Set myGrid = myForm.Controls("myTableControl") +''' myList = myGrid.Controls() +''' Set myControl = myGrid.Controls("myCheckBox") + +Dim oControl As Object ' The new control class instance +Dim lIndexOfNames As Long ' Index in ElementNames array. Used to access _ControlCache +Dim vControl As Variant ' Alias of _ControlCache entry +Dim oView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Dim i As Long +Const cstThisSub = "SFDocuments.FormControl.Controls" +Const cstSubArgs = "[ControlName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set Controls = Nothing + +Check: + If IsMissing(ControlName) Or IsEmpty(ControlName) Then ControlName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTABLECONTROL Then GoTo Catch + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING) Then GoTo Finally + End If + +Try: + ' Collect all control names if not yet done + If UBound(_ControlNames) < 0 Then + _ControlNames = _ControlModel.getElementNames() + If UBound(_ControlNames) >= 0 Then + ReDim _ControlCache(0 To UBound(_ControlNames)) + End If + End If + + ' Return the list of controls or a FormControl instance + If Len(ControlName) = 0 Then + Controls = _ControlNames + + Else + + If Not _ControlModel.hasByName(ControlName) Then GoTo CatchNotFound + lIndexOfNames = ScriptForge.SF_Array.IndexOf(_ControlNames, ControlName, CaseSensitive := True) + ' Reuse cache when relevant + vControl = _ControlCache(lIndexOfNames) + + If IsEmpty(vControl) Then + ' Not in cache => Create the new form control class instance + Set oControl = New SF_FormControl + With oControl + ._Name = ControlName + Set .[Me] = oControl + Set .[_Parent] = [Me] + ._ParentIsTable = True + ._IndexOfNames = lIndexOfNames + ._FormName = _FormName + Set ._ParentForm = _ParentForm + ' Get model and view of the current control + Set ._ControlModel = _ControlModel.getByName(ControlName) + ._ImplementationName = ._ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? + ' Bypass to find the control view: cannot be done from the top component + If Not IsNull(_ControlView) Then ' Anticipate absence of ControlView in table controls when edit mode + For i = 0 to _ControlView.getCount() - 1 + Set oView = _ControlView.GetByIndex(i) + If Not IsNull(oView) Then + If oView.getModel.Name = ControlName Then + Set ._ControlView = oView + Exit For + End If + End If + Next i + End If + ._Initialize() + End With + Else + Set oControl = vControl + End If + + Set Controls = oControl + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING, _ControlModel.getElementNames()) + GoTo Finally +End Function ' SFDocuments.SF_FormControl.Controls + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myControl.GetProperty("MyProperty") + +Dim vDefault As Variant ' Default value when property not applicable on control type +Const cstThisSub = "SFDocuments.FormControl.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + ' FormControl properties are far from applicable to all control types + ' Getting a property must never abort to not interfere with the Basic IDE watch function + ' Hence a default value must be provided + Select Case UCase(PropertyName) + Case UCase("Default") : vDefault = False + Case UCase("DefaultValue") : vDefault = Null + Case UCase("Enabled") : vDefault = False + Case UCase("ListCount") : vDefault = 0 + Case UCase("ListIndex") : vDefault = -1 + Case UCase("Locked") : vDefault = False + Case UCase("MultiSelect") : vDefault = False + Case UCase("Parent") : vDefault = Nothing + Case UCase("Required") : vDefault = False + Case UCase("TripleState") : vDefault = False + Case UCase("Value") : vDefault = Empty + Case UCase("Visible") : vDefault = True + Case UCase("XControlModel") : vDefault = Nothing + Case UCase("XControlView") : vDefault = Nothing + Case Else : vDefault = "" + End Select + + GetProperty = _PropertyGet(PropertyName, vDefault) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_FormControl.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the FormControl service as an array + + Methods = Array( _ + "AddSubNode" _ + , "AddSubTree" _ + , "CreateRoot" _ + , "FindNode" _ + , "SetFocus" _ + , "WriteLine" _ + ) + +End Function ' SFDocuments.SF_FormControl.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the FormControl class as an array + + Properties = Array( _ + "Action" _ + , "Cancel" _ + , "Caption" _ + , "ControlSource" _ + , "ControlType" _ + , "Default" _ + , "DefaultValue" _ + , "Enabled" _ + , "Format" _ + , "ListCount" _ + , "ListIndex" _ + , "ListSource" _ + , "ListSourceType" _ + , "Locked" _ + , "MultiSelect" _ + , "Name" _ + , "OnActionPerformed" _ + , "OnAdjustmentValueChanged" _ + , "OnApproveAction" _ + , "OnApproveReset" _ + , "OnApproveUpdate" _ + , "OnChanged" _ + , "OnErrorOccurred" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnItemStateChanged" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "OnResetted" _ + , "OnTextChanged" _ + , "OnUpdated" _ + , "Parent" _ + , "Picture" _ + , "Required" _ + , "Text" _ + , "TipText" _ + , "TripleState" _ + , "Value" _ + , "Visible" _ + , "XControlModel" _ + , "XControlView" _ + ) + +End Function ' SFDocuments.SF_FormControl.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetFocus() As Boolean +''' Set the focus on the current Control instance +''' Probably called from after an event occurrence +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' Dim oDoc As Object, oForm As Object, oControl As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", ThisComponent) +''' Set oForm = oDoc.Forms(0) +''' Set oControl = oForm.Controls("thisControl") +''' oControl.SetFocus() + +Dim bSetFocus As Boolean ' Return value +Dim iColPosition As Integer ' Position of control in table +Dim oTableModel As Object ' XControlModel of parent table +Dim oControl As Object ' com.sun.star.awt.XControlModel +Dim i As Integer, j As Integer +Const cstThisSub = "SFDocuments.FormControl.SetFocus" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSetFocus = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _ParentForm._IsStillAlive() Then GoTo Finally + End If + +Try: + If Not IsNull(_ControlView) Then + If _ParentIsTable Then ' setFocus() method does not work on controlviews in table control ?!? + ' Find the column position of the current instance in the parent table control + iColPosition = -1 + Set oTableModel = [_Parent]._ControlModel + j = -1 + For i = 0 To oTableModel.Count - 1 + Set oControl = oTableModel.getByIndex(i) + If Not oControl.Hidden Then j = j + 1 ' Skip hidden columns + If oControl.Name = _Name Then + iColPosition = j + Exit For + End If + Next i + If iColPosition >= 0 Then + [_Parent]._ControlView.setFocus() 'Set first focus on table control itself + [_Parent]._ControlView.setCurrentColumnPosition(iColPosition) 'Deprecated but no alternative found + End If + Else + _ControlView.setFocus() + End If + bSetFocus = True + End If + bSetFocus = True + +Finally: + SetFocus = bSetFocus + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFControls.SF_FormControl.SetFocus + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.FormControl.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_FormControl.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FormatsList() As Variant +''' Return the allowed format entries as a zero-based array for Date and Time control types + +Dim vFormats() As Variant ' Return value + + Select Case _ControlType + Case CTLDATEFIELD + vFormats = Array( _ + "Standard (short)" _ + , "Standard (short YY)" _ + , "Standard (short YYYY)" _ + , "Standard (long)" _ + , "DD/MM/YY" _ + , "MM/DD/YY" _ + , "YY/MM/DD" _ + , "DD/MM/YYYY" _ + , "MM/DD/YYYY" _ + , "YYYY/MM/DD" _ + , "YY-MM-DD" _ + , "YYYY-MM-DD" _ + ) + Case CTLTIMEFIELD + vFormats = Array( _ + "24h short" _ + , "24h long" _ + , "12h short" _ + , "12h long" _ + ) + Case Else + vFormats = Array() + End Select + + _FormatsList = vFormats + +End Function ' SFDocuments.SF_FormControl._FormatsList + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDocuments.SF_FormControl._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnActionPerformed") + _GetListener = "XActionListener" + Case UCase("OnAdjustmentValueChanged") + _GetListener = "XAdjustmentListener" + Case UCase("OnApproveAction") + _GetListener = "XApproveActionListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveUpdate"), UCase("OnUpdated") + _GetListener = "XUpdateListener" + Case UCase("OnChanged") + _GetListener = "XChangeListener" + Case UCase("OnErrorOccurred") + _GetListener = "XErrorListener" + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnItemStateChanged") + _GetListener = "XItemListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case UCase("OnTextChanged") + _GetListener = "XTextListener" + End Select + +End Function ' SFDocuments.SF_FormControl._GetListener + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Complete the object creation process: +''' - Initialization of private members +''' - Collection of specific attributes +''' - Synchronization with parent form instance + +Dim vControlTypes As Variant ' Array of control types ordered by the ClassId property of XControlModel - 2 +Const acHiddenControl = 13 ' Class Id of an hidden control: has no ControlView + + vControlTypes = array( CTLBUTTON _ + , CTLRADIOBUTTON _ + , CTLIMAGEBUTTON _ + , CTLCHECKBOX _ + , CTLLISTBOX _ + , CTLCOMBOBOX _ + , CTLGROUPBOX _ + , CTLTEXTFIELD _ + , CTLFIXEDTEXT _ + , CTLTABLECONTROL _ + , CTLFILECONTROL _ + , CTLHIDDENCONTROL _ + , CTLIMAGECONTROL _ + , CTLDATEFIELD _ + , CTLTIMEFIELD _ + , CTLNUMERICFIELD _ + , CTLCURRENCYFIELD _ + , CTLPATTERNFIELD _ + , CTLSCROLLBAR _ + , CTLSPINBUTTON _ + , CTLNAVIGATIONBAR _ + ) + +Try: + ' _implementationName is set elsewhere for controls in table control + If Len(_ImplementationName) = 0 Then _ImplementationName = ScriptForge.SF_Session.UnoObjectType(_ControlModel) + _ClassId = _ControlModel.ClassId + + ' Identify the control type, ignore subforms and pay attention to formatted fields + If ScriptForge.SF_Session.HasUnoproperty(_ControlModel, "ClassId") Then ' All control types have a ClassId property except subforms + _ControlType = vControlTypes(_ClassId - 2) + ' Formatted fields belong to the TextField family + If _ControlType = CTLTEXTFIELD Then + If _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper" _ + Or _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper_ForcedFormatted" _ + Or _ImplementationName = "com.sun.star.form.component.FormattedField" Then ' When in table control + _ControlType = CTLFORMATTEDFIELD + End If + End If + Else + Exit Sub ' Ignore subforms, should not happen + End If + + With [_Parent] + ' Set control view if not set yet + If IsNull(_ControlView) Then + If _ClassId > 0 And _ClassId <> acHiddenControl Then ' No view on hidden controls + If IsNull(._FormDocument) Then ' Usual document + Set _ControlView = ._Component.CurrentController.getControl(_ControlModel) + Else ' Base form document + Set _ControlView = ._FormDocument.Component.CurrentController.getControl(_ControlModel) + End If + End If + End If + End With + + ' Store the SF_FormControl object in the parent cache + Set _Parent._ControlCache(_IndexOfNames) = [Me] + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_FormControl._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _ListboxBound() As Boolean +''' Return True if the actual control, which is a listbox, has a bound column +''' Called before setting the value of a listbox, i.e. the value to be rewritten in the underlying table data +''' The existence of a bound column is derived from the comparison between StringItemList and ValueItemList +''' String ... : the strings displayed in the list box +''' Value ... : the database values +''' If they are different, then there is a bound column + +Dim bListboxBound As Boolean ' Return value +Dim vValue() As Variant ' Alias of the control model ValueItemList +Dim vString() As Variant ' Alias of the control model StringItemList +Dim i As Long + + bListboxBound = False + + With _ControlModel + If Not IsNull(.ValueItemList) _ + And .DataField <> "" _ + And Not IsNull(.BoundField) _ + And ScriptForge.SF_Array.Contains(Array( _ + com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + ), .ListSourceType) Then + If IsArray(.ValueItemList) Then + vValue = .ValueItemList + vString = .StringItemList + For i = 0 To UBound(vValue) + If VarType(vValue(i)) <> VarType(vString(i)) Then + bListboxBound = True + ElseIf vValue(i) <> vString(i) Then + bListboxBound = True + End If + If bListboxBound Then Exit For + Next i + End If + End If + End With + + _ListboxBound = bListboxBound + +End Function ' _ListboxBound V0.9.0 + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvDefault As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property +''' pvDefault: the value returned when the property is not applicable on the control's type +''' Getting a non-existing property for a specific control type should +''' not generate an error to not disrupt the Basic IDE debugger + +Dim vGet As Variant ' Return value +Static oSession As Object ' Alias of SF_Session +Dim vSelection As Variant ' Alias of Model.SelectedItems or Model.Selection +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim vDate As Variant ' Date after conversion from com.sun.star.util.Date or com.sun.star.util.Time +Dim vValues As Variant ' Array of listbox values +Dim oControlEvents As Object ' com.sun.star.container.XNameContainer +Dim sEventName As String ' Internal event name +Const cstUnoUrl = ".uno:FormController/" +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDocuments.FormControl.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _ParentForm._IsStillAlive() Then GoTo Finally + + If IsMissing(pvDefault) Or IsEmpty(pvDefault) Then pvDefault = Null + _PropertyGet = pvDefault + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("Action") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "ButtonType") Then + Select Case _ControlModel.ButtonType + Case com.sun.star.form.FormButtonType.PUSH : _PropertyGet = "none" + Case com.sun.star.form.FormButtonType.SUBMIT : _PropertyGet = "submitForm" + Case com.sun.star.form.FormButtonType.RESET : _PropertyGet = "resetForm" + Case com.sun.star.form.FormButtonType.URL + ' ".uno:FormController/moveToFirst" + If Left(_ControlModel.TargetURL, Len(cstUnoUrl)) = cstUnoUrl Then + _PropertyGet = Mid(_ControlModel.TargetURL, Len(cstUnoUrl) + 1) + ElseIf Left(_ControlModel.TargetURL, 4) = "http" Then + _PropertyGet = "openWebPage" + ElseIf Left(_ControlModel.TargetURL, 4) = "file" Then + _PropertyGet ="openDocument" + End If + End Select + End If + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If oSession.HasUNOProperty(_ControlModel, "Label") Then _PropertyGet = _ControlModel.Label + Case Else : GoTo CatchType + End Select + Case UCase("ControlSource") + Select Case _ControlType + Case CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFORMATTEDFIELD, CTLIMAGECONTROL, CTLLISTBOX _ + , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLRADIOBUTTON, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "DataField") Then _PropertyGet = _ControlModel.DataField + Case Else : GoTo CatchType + End Select + Case UCase("ControlType") + _PropertyGet = _ControlType + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _PropertyGet = _ControlModel.DefaultButton + Case Else : GoTo CatchType + End Select + Case UCase("DefaultValue") + Select Case _ControlType + Case CTLCHECKBOX, CTLRADIOBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultState") Then _PropertyGet = _ControlModel.DefaultState + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultText") Then _PropertyGet = _ControlModel.DefaultText + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultValue") Then _PropertyGet = _ControlModel.DefaultValue + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultDate") Then + If Not IsEmpty(_ControlModel.DefaultDate) Then + With _ControlModel.DefaultDate + vDate = DateSerial(.Year, .Month, .Day) + End With + _PropertyGet = vDate + End If + End If + Case CTLFORMATTEDFIELD + If oSession.HasUNOProperty(_ControlModel, "EffectiveDefault") Then _PropertyGet = _ControlModel.EffectiveDefault + Case CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "DefaultSelection") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + vList = _ControlModel.DefaultSelection + If IsArray(vList) Then + If UBound(vList) >= LBound(vList) Then ' Is array initialized ? + lIndex = UBound(_ControlModel.StringItemList) + If vList(0) >= 0 And vList(0) <= lIndex Then _PropertyGet = _ControlModel.StringItemList(vList(0)) + ' Only first default value is considered + End If + End If + End If + Case CTLSPINBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultSpinValue") Then _PropertyGet = _ControlModel.DefaultSpinValue + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultTime") Then + If Not IsEmpty(_ControlModel.DefaultTime) Then + With _ControlModel.DefaultTime + vDate = TimeSerial(.Hours, .Minutes, .Seconds) + End With + _PropertyGet = vDate + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _PropertyGet = _ControlModel.Enabled + End Select + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then _PropertyGet = _FormatsList()(_ControlModel.DateFormat) + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then _PropertyGet = _FormatsList()(_ControlModel.TimeFormat) + Case CTLFORMATTEDFIELD + If oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") And oSession.HasUNOProperty(_ControlModel, "FormatKey") Then + _PropertyGet = _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListCount") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "StringItemList") Then _PropertyGet = UBound(_ControlModel.StringItemList) + 1 + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + Select Case _ControlType + Case CTLCOMBOBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + _PropertyGet = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, _ControlModel.Text, CaseSensitive := True) + End If + Case CTLLISTBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + vSelection = _ControlModel.SelectedItems + If UBound(vSelection) >= 0 Then _PropertyGet = vSelection(0) + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "ListSource") Then + With com.sun.star.form.ListSourceType + Select Case _ControlModel.ListSourceType + Case .VALUELIST _ + , .TABLEFIELDS + If IsArray(_ControlModel.StringItemList) Then vValues = _ControlModel.StringItemList Else vValues = Array(_ControlModel.StringItemList) + Case .TABLE _ + , .QUERY _ + , .SQL _ + , .SQLPASSTHROUGH + If IsArray(_ControlModel.ListSource) Then vValues = _ControlModel.ListSource Else vValues = Array(_ControlModel.ListSource) + End Select + End With + _PropertyGet = Join(vValues, ";") + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListSourceType") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "ListSourceType") Then _PropertyGet = _ControlModel.ListSourceType + Case Else : GoTo CatchType + End Select + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLIMAGECONTROL _ + , CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _PropertyGet = _ControlModel.ReadOnly + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + _PropertyGet = _ControlModel.MultiSelection + ElseIf oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: gridcontrols only TBC ?? + _PropertyGet = _ControlModel.MultiSelectionSimpleMode + End If + Case Else : GoTo CatchType + End Select + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset"), UCase("OnApproveUpdate") _ + , UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained"), UCase("OnFocusLost") _ + , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted") _ + , UCase("OnTextChanged"), UCase("OnUpdated") + If IsNull(_ControlModel) Then _PropertyGet = "" Else _PropertyGet = SF_Register._GetEventScriptCode(_ControlModel, psProperty, _Name) + Case UCase("Parent") + Set _PropertyGet = [_Parent] + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGEBUTTON, CTLIMAGECONTROL + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _PropertyGet = ScriptForge.SF_FileSystem._ConvertFromUrl(_ControlModel.ImageURL) + Case Else : GoTo CatchType + End Select + Case UCase("Required") + Select Case _ControlType + Case CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLIMAGECONTROL, CTLLISTBOX, CTLNUMERICFIELD _ + , CTLPATTERNFIELD, CTLRADIOBUTTON, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUnoProperty(_ControlModel, "InputRequired") Then _PropertyGet = _ControlModel.InputRequired + Case Else : GoTo CatchType + End Select + Case UCase("Text") + Select Case _ControlType + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "Date") _ + And oSession.HasUNOProperty(_ControlModel, "FormatKey") _ + And oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") Then + If Not IsEmpty(_ControlModel.Date) Then + With _ControlModel.Date + vDate = DateSerial(.Year, .Month, .Day) + End With + _PropertyGet = Format(vDate, _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString) + End If + End If + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "Text") Then + If Not IsEmpty(_ControlModel.Time) Then + With _ControlModel.Time + vDate = TimeSerial(.Hours, .Minutes, .Seconds) + End With + _PropertyGet = Format(vDate, "HH:MM:SS") + End If + End If + Case CTLCOMBOBOX, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLPATTERNFIELD, CTLTEXTFIELD + If oSession.HasUnoProperty(_ControlModel, "Text") Then _PropertyGet = _ControlModel.Text + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _PropertyGet = _ControlModel.HelpText + End Select + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _PropertyGet = _ControlModel.TriState + Case Else : GoTo CatchType + End Select + Case UCase("Value") ' Default values are set here by control type, not in the 2nd argument (pvDefault) + vGet = pvDefault + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + vGet = False + If oSession.HasUnoProperty(_ControlModel, "Toggle") Then + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = _ControlModel.State Else vGet = 2 + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String + If oSession.HasUnoProperty(_ControlModel, "Text") Then vGet = _ControlModel.Text Else vGet = "" + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If oSession.HasUnoProperty(_ControlModel, "Value") Then vGet = _ControlModel.Value Else vGet = 0 + Case CTLDATEFIELD 'Date + vGet = CDate(1) + If oSession.HasUnoProperty(_ControlModel, "Date") Then + If VarType(_ControlModel.Date) = ScriptForge.V_OBJECT Then ' com.sun.star.util.Date + With _ControlModel.Date + vDate = DateSerial(.Year, .Month, .Day) + End With + vGet = vDate + Else ' .Date = Empty + End If + End If + Case CTLFORMATTEDFIELD 'String or numeric + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then vGet = _ControlModel.EffectiveValue Else vGet = "" + Case CTLHIDDENCONTROL 'String + If oSession.HasUnoProperty(_ControlModel, "HiddenValue") Then vGet = _ControlModel.HiddenValue Else vGet = "" + Case CTLLISTBOX 'String or array of strings depending on MultiSelection + ' StringItemList is the list of the items displayed in the box + ' ValueItemList is the list of the values in the underlying database field + ' SelectedItems is the list of the indexes in StringItemList of the selected items + ' It can go beyond the limits of StringItemList + ' It can contain multiple values even if the listbox is not multiselect + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _ + And oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + vSelection = _ControlModel.SelectedItems + ' The list of allowed values depends on the existence of a bound column + If _ListBoxBound() Then vList = _ControlModel.ValueItemList Else vList = _ControlModel.StringItemList + If _ControlModel.MultiSelection Then vValues = Array() + For i = 0 To UBound(vSelection) + lIndex = vSelection(i) + If lIndex >= 0 And lIndex <= UBound(vList) Then + If Not _ControlModel.MultiSelection Then + vValues = vList(lIndex) + Exit For + End If + vValues = ScriptForge.SF_Array.Append(vValues, vList(lIndex)) + End If + Next i + vGet = vValues + Else + vGet = "" + End If + Case CTLRADIOBUTTON 'Boolean + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) Else vGet = False + Case CTLSCROLLBAR 'Numeric + vGet = 0 + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then + If Not IsEmpty(_ControlModel.ScrollValue) Then vGet = _ControlModel.ScrollValue + End If + Case CTLSPINBUTTON + If oSession.HasUnoProperty(_ControlModel, "SpinValue") Then vGet = _ControlModel.SpinValue Else vGet = 0 + Case CTLTIMEFIELD + vGet = CDate(0) + If oSession.HasUnoProperty(_ControlModel, "Time") Then + If VarType(_ControlModel.Time) = ScriptForge.V_OBJECT Then ' com.sun.star.Util.Time + With _ControlModel.Time + vDate = TimeSerial(.Hours, .Minutes, .Seconds) + End With + vGet = vDate + Else ' .Time = Empty + End If + End If + Case Else : GoTo CatchType + End Select + _PropertyGet = vGet + Case UCase("Visible") + If oSession.HasUnoMethod(_ControlView, "isVisible") Then _PropertyGet = CBool(_ControlView.isVisible()) + Case UCase("XControlModel") + Set _PropertyGet = _ControlModel + Case UCase("XControlView") + Set _PropertyGet = _ControlView + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + GoTo Finally +End Function ' SFDocuments.SF_FormControl._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim sFormName As String ' Full form identification for error messages +Dim vSet As Variant ' Value to set in UNO model or view property +Dim vActions As Variant ' Action property: list of available actions +Dim sAction As String ' A single action +Dim vFormats As Variant ' Format property: output of _FormatsList() +Dim iFormat As Integer ' Format property: index in vFormats +Dim vSelection As Variant ' Alias of Model.SelectedItems +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim oDatabase As Object ' The database object related to the parent form of the control instance +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.FormControl.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _ParentForm._IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("Action") + Select Case _ControlType + Case CTLBUTTON + vActions = Array("none", "submitForm", "resetForm", "refreshForm", "moveToFirst", "moveToLast", "moveToNext", "moveToPrev" _ + , "saveRecord", "moveToNew", "deleteRecord", "undoRecord") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Action", ScriptForge.V_STRING, vActions) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "ButtonType") Then + sAction = vActions(ScriptForge.SF_Array.IndexOf(vActions, pvValue, CaseSensitive := False)) + _ControlModel.TargetURL = "" + Select Case sAction + Case "none" : vSet = com.sun.star.form.FormButtonType.PUSH + Case "submitForm" : vSet = com.sun.star.form.FormButtonType.SUBMIT + Case "resetForm" : vSet = com.sun.star.form.FormButtonType.RESET + Case Else + vSet = com.sun.star.form.FormButtonType.URL + _ControlModel.TargetURL = ".uno:FormController/" & sAction + End Select + _ControlModel.ButtonType = vSet + End If + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Caption", V_STRING) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "Label") Then _ControlModel.Label = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Default", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _ControlModel.DefaultButton = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If Not ScriptForge.SF_Utils._Validate(pvValue, "Enabled", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _ControlModel.Enabled = pvValue + End Select + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD, CTLTIMEFIELD + vFormats = _FormatsList() + If Not ScriptForge.SF_Utils._Validate(pvValue, "Format", V_STRING, vFormats) Then GoTo Finally + iFormat = ScriptForge.SF_Array.IndexOf(vFormats, pvValue, CaseSensitive := False) + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then + _ControlModel.DateFormat = iFormat + ElseIf oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then + _ControlModel.TimeFormat = iFormat + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListIndex", ScriptForge.V_NUMERIC) Then GoTo Finally + Select Case _ControlType + Case CTLCOMBOBOX + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + If pvValue >= 0 And pvValue <= UBound(_ControlModel.StringItemList) Then _ControlModel.Text = _ControlModel.StringItemList(CInt(pvValue)) + End If + Case CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") Then _ControlModel.SelectedItems = Array(CInt(pvValue)) + Case Else : GoTo CatchType + End Select + Case UCase("ListSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "ListSource") Then + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then Goto Finally + With com.sun.star.form.ListSourceType + Select Case _ControlModel.ListSourceType + Case .QUERY _ + , .TABLE _ + , .TABLEFIELDS + Set oDatabase = _ParentForm.GetDatabase() + If _ControlModel.ListSourceType = .QUERY Then vList = oDatabase.Queries Else vList = oDatabase.Tables + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING, vList) Then Goto Finally + If _ControlType = CTLCOMBOBOX Then _ControlModel.ListSource = pvValue Else _ControlModel.ListSource = Array(pvValue) + _ControlModel.refresh() + Case .SQL + Set oDatabase = _ParentForm.GetDatabase() + If _ControlType = CTLCOMBOBOX Then _ControlModel.ListSource = oDatabase._ReplaceSquareBrackets(pvValue) Else _ControlModel.ListSource = Array(oDatabase._ReplaceSquareBrackets(pvValue)) + _ControlModel.refresh() + Case .VALUELIST ' ListBox only ! + _ControlModel.ListSource = Split(pvValue, ";") + _ControlModel.StringItemList = _ControlModel.ListSource + Case .SQLPASSTHROUGH + If _ControlType = CTLCOMBOBOX Then _ControlModel.ListSource = pvValue Else _ControlModel.ListSource = Array(pvValue) + _ControlModel.refresh() + End Select + End With + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListSourceType") + With com.sun.star.form.ListSourceType + Select Case _ControlType + Case CTLCOMBOBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListSourceType", ScriptForge.V_NUMERIC, Array( _ + .TABLE _ + , .QUERY _ + , .SQL _ + , .SQLPASSTHROUGH _ + , .TABLEFIELDS _ + )) Then GoTo Finally + Case CTLLISTBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListSourceType", ScriptForge.V_NUMERIC, Array( _ + .VALUELIST _ + , .TABLE _ + , .QUERY _ + , .SQL _ + , .SQLPASSTHROUGH _ + , .TABLEFIELDS _ + )) Then GoTo Finally + Case Else : GoTo CatchType + End Select + End With + If oSession.HasUnoProperty(_ControlModel, "ListSourceType") Then _ControlModel.ListSourceType = pvValue + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLIMAGECONTROL _ + , CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Locked", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _ControlModel.ReadOnly = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "MultiSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then _ControlModel.MultiSelection = pvValue + If oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then _ControlModel.MultiSelectionSimpleMode = pvValue + If oSession.HasUnoProperty(_ControlModel, "SelectedItems") Then + ' Cancel selections when MultiSelect becomes False + If Not pvValue And UBound(_ControlModel.SelectedItems) > 0 Then + lIndex = _ControlModel.SelectedItems(0) + _ControlModel.SelectedItems = Array(lIndex) + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset"), UCase("OnApproveUpdate") _ + , UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained"), UCase("OnFocusLost") _ + , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted") _ + , UCase("OnTextChanged"), UCase("OnUpdated") + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then Goto Finally + If Not IsNull(_ControlModel) Then + bSet = SF_Register._RegisterEventScript(_ControlModel _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + , _Name _ + ) + End If + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGEBUTTON, CTLIMAGECONTROL + If Not ScriptForge.SF_Utils._ValidateFile(pvValue, "Picture") Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _ControlModel.ImageURL = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue) + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If Not ScriptForge.SF_Utils._Validate(pvValue, "TipText", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _ControlModel.HelpText = pvValue + End Select + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "TripleState", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _ControlModel.TriState = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Value") + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Toggle") And oSession.HasUnoProperty(_ControlModel, "State") Then + _ControlModel.State = Iif(pvValue, 1, 0) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(ScriptForge.V_BOOLEAN, ScriptForge.V_NUMERIC), Array(0, 1, 2, True, False)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then + If VarType(pvValue) = ScriptForge.V_BOOLEAN Then pvValue = Iif(pvValue, 1, 0) + _ControlModel.State = pvValue + End If + Case CTLCOMBOBOX + If oSession.HasUnoProperty(_ControlModel, "Text") And oSession.HasUnoProperty(_ControlModel, "StringItemList") Then + If pvValue <> "" Then + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING, _ControlModel.StringItemList) Then Goto Finally + End If + _ControlModel.Text = pvValue + End If + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Value") Then _ControlModel.Value = pvValue + Case CTLDATEFIELD 'Date + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Date") Then + Set vSet = New com.sun.star.util.Date + vSet.Year = Year(pvValue) + vSet.Month = Month(pvValue) + vSet.Day = Day(pvValue) + _ControlModel.Date = vSet + End If + Case CTLFILECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Text") Then _ControlModel.Text = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue) + Case CTLFORMATTEDFIELD 'String or numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then _ControlModel.EffectiveValue = pvValue + Case CTLHIDDENCONTROL 'String + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "HiddenValue") Then _ControlModel.HiddenValue = pvValue + Case CTLLISTBOX 'String or number - Only a single value may be set + ' StringItemList is the list of the items displayed in the box + ' ValueItemList is the list of the values in the underlying database field + ' SelectedItems is the list of the indexes in StringItemList of the selected items + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") Then + ' Setting the value on a listbox is allowed only if single value and value in the list + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + ' The list of allowed values depends on the existence of a bound column + If _ListboxBound() Then vList = _ControlModel.ValueItemList Else vList = _ControlModel.StringItemList + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", , vList) Then GoTo Finally + _ControlModel.SelectedItems = Array(ScriptForge.SF_Array.IndexOf(vList, pvValue, CaseSensitive := True)) + End If + Case CTLPATTERNFIELD, CTLTEXTFIELD 'String + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Text") Then _ControlModel.Text = pvValue + Case CTLRADIOBUTTON 'Boolean + ' A group of radio buttons is presumed sharing the same GroupName + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then _ControlModel.State = Iif(pvValue, 1, 0) + Case CTLSCROLLBAR 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMin") Then + If pvValue < _ControlModel.ScrollValueMin Then pvValue = _ControlModel.ScrollValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMax") Then + If pvValue > _ControlModel.ScrollValueMax Then pvValue = _ControlModel.ScrollValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then _ControlModel.ScrollValue = pvValue + Case CTLSPINBUTTON 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "SpinValueMin") Then + If pvValue < _ControlModel.SpinValueMin Then pvValue = _ControlModel.SpinValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "SpinValueMax") Then + If pvValue > _ControlModel.SpinValueMax Then pvValue = _ControlModel.SpinValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "SpinValue") Then _ControlModel.SpinValue = pvValue + Case CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Time") Then + Set vSet = New com.sun.star.util.Time + vSet.Hours = Hour(pvValue) + vSet.Minutes = Minute(pvValue) + vSet.Seconds = Second(pvValue) + _ControlModel.Time = vSet + End If + Case Else : GoTo CatchType + End Select + ' FINAL COMMITMENT + If oSession.HasUNOMethod(_ControlModel, "commit") Then _ControlModel.commit() ' f.i. checkboxes have no commit method ?? + Case UCase("Visible") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Visible", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoMethod(_ControlView, "setVisible") Then + If pvValue Then _ControlModel.EnableVisible = True + _ControlView.setVisible(pvValue) + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bSet = False + GoTo Finally +CatchType: + If Len(_ParentForm._FormDocumentName) > 0 Then sFormName = _ParentForm._FormDocumentName & "." Else sFormName = "" + ScriptForge.SF_Exception.RaiseFatal(FORMCONTROLTYPEERROR, _Name, sFormName & _FormName, _ControlType, psProperty) + GoTo Finally +End Function ' SFDocuments.SF_FormControl._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[FORMCONTROL]: Name, Type (formname) + _Repr = "[FORMCONTROL]: " & _Name & ", " & _ControlType & " (" & _FormName & ")" + +End Function ' SFDocuments.SF_FormControl._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_FORMCONTROL +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Register.xba b/wizards/source/sfdocuments/SF_Register.xba new file mode 100644 index 000000000..5baf37afb --- /dev/null +++ b/wizards/source/sfdocuments/SF_Register.xba @@ -0,0 +1,546 @@ +<?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="SF_Register" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ================================================================= DEFINITIONS + +''' Strategy for management of Form and FormControl events: +''' ------------------------------------------------------ +''' At the contrary of Dialogs and DialogControls, which are always started from some code, +''' Forms and FormControls will be initiated most often by the user, even if the SFDocuments library +''' allows to start forms programmatically +''' +''' For Forms started programmatically, the corresponding objects are built top-down +''' Event management of forms and their controls requires to being able to rebuild Form +''' and FormControl objects bottom-up +''' +''' To avoid multiple rebuilds requested by multiple events, +''' 1. The active form objects are cached in a global array of _FormCache types +''' 2. FormControl objects are cached in Form objects +''' 3. The bottom-up rebuild is executed only once, at instance creation + +Type _FormCache + Terminated As Boolean + XUnoForm As Object + BasicForm As Object +End Type + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Document", "SFDocuments.SF_Register._NewDocument") ' Reference to the function initializing the service + .RegisterService("Base", "SFDocuments.SF_Register._NewDocument") ' Same reference, distinction is made inside the function + .RegisterService("Calc", "SFDocuments.SF_Register._NewDocument") ' Same reference, distinction is made inside the function + .RegisterService("Writer", "SFDocuments.SF_Register._NewDocument") ' Same reference, distinction is made inside the function + .RegisterEventManager("DocumentEvent", "SFDocuments.SF_Register._EventManager") ' Reference to the events manager + .RegisterEventManager("FormEvent", "SFDocuments.SF_Register._FormEventManager")' Reference to the form and controls events manager + End With + +End Sub ' SFDocuments.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _AddFormToCache(ByRef pvUnoForm As Object _ + , ByRef pvBasicForm As Object _ + ) As Long +''' Add a new entry in the cache array with the references of the actual Form +''' If relevant, the last entry of the cache is reused. +''' The cache is located in the global _SF_ variable +''' Args: +''' pvUnoForm: com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +''' pvBasicForm: its corresponding Basic object +''' Returns: +''' The index of the new or modified entry + +Dim vCache As New _FormCache ' Entry to be added +Dim lIndex As Long ' UBound of _SF_.SFForms +Dim vCacheArray As Variant ' Alias of _SF_.SFForms + +Try: + vCacheArray = _SF_.SFForms + + If IsEmpty(vCacheArray) Then vCacheArray = Array() + lIndex = UBound(vCacheArray) + If lIndex < LBound(vCacheArray) Then + ReDim vCacheArray(0 To 0) + lIndex = 0 + ElseIf Not vCacheArray(lIndex).Terminated Then ' Often last entry can be reused + lIndex = lIndex + 1 + ReDim Preserve vCacheArray(0 To lIndex) + End If + + With vCache + .Terminated = False + Set .XUnoForm = pvUnoForm + Set .BasicForm = pvBasicForm + End With + Set vCacheArray(lIndex) = vCache + + _SF_.SFForms = vCacheArray + +Finally: + _AddFormToCache = lIndex + Exit Function +End Function ' SFDocuments.SF_Register._AddFormToCache + +REM ----------------------------------------------------------------------------- +Private Sub _CleanCacheEntry(ByVal plIndex As Long) +''' Clean the plIndex-th entry in the Forms cache +''' Args: +''' plIndex: must fit within the actual boundaries of the cache, otherwise the request is ignored + +Dim vCache As New _FormCache ' Cleaned entry + + With _SF_ + If Not IsArray(.SFForms) Then Exit Sub + If plIndex < LBound(.SFForms) Or plIndex > UBound(.SFForms) Then Exit Sub + + With vCache + .Terminated = True + Set .XUnoForm = Nothing + Set .BasicForm = Nothing + End With + .SFForms(plIndex) = vCache + End With + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_Register._CleanCacheEntry + +REM ----------------------------------------------------------------------------- +Public Function _EventManager(Optional ByRef pvArgs As Variant) As Object +''' Returns a Document, Calc or Base object corresponding with the active component +''' which triggered the event in argument +''' This method should be triggered only thru the invocation of CreateScriptService +''' Args: +''' pvEvent: com.sun.star.document.DocumentEvent +''' Returns: +''' the output of a Document, Calc, ... service or Nothing +''' Example: +''' Sub TriggeredByEvent(ByRef poEvent As Object) +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.DocumentEvent", poEvent) +''' If Not IsNull(oDoc) Then +''' ' ... (a valid document has been identified) +''' End Sub + +Dim oSource As Object ' Return value +Dim vEvent As Variant ' Alias of pvArgs(0) + + ' Never abort while an event is processed + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Finally + Set oSource = Nothing + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vEvent = pvArgs(0) Else Set vEvent = Empty + If VarType(vEvent) <> ScriptForge.V_OBJECT Then GoTo Finally + +Try: + If ScriptForge.SF_Session.UnoObjectType(vEvent) = "com.sun.star.document.DocumentEvent" Then + Set oSource = SF_Register._NewDocument(vEvent.Source) + End If + +Finally: + Set _EventManager = oSource + Exit Function +End Function ' SFDocuments.SF_Register._EventManager + +REM ----------------------------------------------------------------------------- +Private Function _FindFormInCache(ByRef poForm As Object) As Object +''' Find the Form based on its XUnoForm +''' The Form must not be terminated +''' Returns: +''' The corresponding Basic Form part or Nothing + +Dim oBasicForm As Object ' Return value +Dim oCache As _FormCache ' Entry in the cache + + Set oBasicForm = Nothing + +Try: + With _SF_ + If Not IsEmpty(.SFForms) Then + For Each oCache In .SFForms + If EqualUnoObjects(poForm, oCache.XUnoForm) And Not oCache.Terminated Then + Set oBasicForm = oCache.BasicForm + Exit For + End If + Next oCache + End If + End With + +Finally: + Set _FindFormInCache = oBasicForm + Exit Function +End Function ' SFDocuments.SF_Register._FindFormInCache + +REM ----------------------------------------------------------------------------- +Public Function _FormEventManager(Optional ByRef pvArgs As Variant) As Object +''' Returns a Form or FormControl object corresponding with the form or control +''' which triggered the event in argument +''' This method should be triggered only thru the invocation of CreateScriptService +''' Args: +''' pvEvent: com.sun.star.lang.EventObject +''' Returns: +''' the output of a Form, FormControl service or Nothing +''' Example: +''' Sub TriggeredByEvent(ByRef poEvent As Object) +''' Dim oForm As Object +''' Set oForm = CreateScriptService("SFDocuments.FormEvent", poEvent) +''' If Not IsNull(oForm) Then +''' ' ... (a valid form or subform has been identified) +''' End Sub + +Dim oSource As Object ' Return value +Dim vEvent As Variant ' Alias of pvArgs(0) +Dim oControlModel As Object ' com.sun.star.awt.XControlModel +Dim oParent As Object ' com.sun.star.form.OGridControlModel or com.sun.star.comp.forms.ODatabaseForm +Dim sParentType As String ' "com.sun.star.form.OGridControlModel" or "com.sun.star.comp.forms.ODatabaseForm" +Dim oSFParent As Object ' The parent as a ScriptForge instance: SF_Form or SF_FormControl +Dim oSFForm As Object ' The grand-parent SF_Form instance +Dim oSession As Object : Set oSession = ScriptForge.SF_Session + + ' Never abort while an event is processed + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Finally + Set oSource = Nothing + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vEvent = pvArgs(0) Else Set vEvent = Empty + If VarType(vEvent) <> ScriptForge.V_OBJECT Then GoTo Finally + +Try: + If oSession.HasUnoProperty(vEvent, "Source") Then + + ' FORM EVENT + If oSession.UnoObjectType(vEvent.Source) = "com.sun.star.comp.forms.ODatabaseForm" Then + Set oSource = SF_Register._NewForm(vEvent.Source, pbForceInit := True) + + ' CONTROL EVENT + Else + ' A SF_FormControl instance is always created from its parent, either a form, a subform or a table control + Set oControlModel = vEvent.Source.Model ' The event source is a control view com.sun.star.awt.XControl + Set oParent = oControlModel.Parent + sParentType = oSession.UnoObjectType(oParent) + Select Case sParentType + Case "com.sun.star.form.OGridControlModel" + Set oSFForm = SF_Register._NewForm(oParent.Parent, pbForceInit := True) + Set oSFParent = oSFForm.Controls(oParent.Name) + Case "com.sun.star.comp.forms.ODatabaseForm" + Set oSFParent = SF_Register._NewForm(oParent, pbForceInit := True) + End Select + ' The final instance is derived from its parent instance + Set oSource = oSFParent.Controls(oControlModel.Name) + + End If + + End If + +Finally: + Set _FormEventManager = oSource + Exit Function +End Function ' SFDocuments.SF_Register._FormEventManager + +REM ----------------------------------------------------------------------------- +Public Function _GetEventScriptCode(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psName As String _ + ) As String +''' Extract from the parent of poObject the Basic script linked to psEvent. +''' Helper function common to forms and form controls +''' Args: +''' poObject: a com.sun.star.form.XForm or XControl object +''' psEvent: the "On..." name of the event +''' psName: the name of the object to be identified from the parent object +''' Returns: +''' The script to trigger when psEvent occurs +''' See Scripting Framework URI Specification : https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification + +Dim vEvents As Variant ' List of available events in the parent object + ' Array of com.sun.star.script.ScriptEventDescriptor +Dim sEvent As String ' The targeted event name +Dim oParent As Object ' The parent object +Dim lIndex As Long ' The index of the targeted event in the events list of the parent object +Dim sName As String ' The corrected UNO event name +Dim i As Long + + _GetEventScriptCode = "" + On Local Error GoTo Catch + If Not ScriptForge.SF_Session.HasUnoMethod(poObject, "getParent") Then GoTo Finally + +Try: + ' Find form index i.e. find control via getByIndex() + ' The name is known (= psName) but getByIndex() is not in the same sequence as getElementNames() + Set oParent = poObject.getParent() + lIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Then + lIndex = i + Exit For + End If + Next i + If lIndex < 0 Then GoTo Finally ' Not found, should not happen + + ' Find script triggered by event + vEvents = oParent.getScriptEvents(lIndex) ' Returns an array + ' Fix historical typo error + sEvent = Replace(LCase(Mid(psEvent, 3, 1)) & Mid(psEvent, 4), "errorOccurred", "errorOccured") + For i = 0 To UBound(vEvents) + If vEvents(i).EventMethod = sEvent Then + _GetEventScriptCode = vEvents(i).ScriptCode + Exit For + End If + Next i + +Finally: + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Register._GetEventScriptCode + +REM ----------------------------------------------------------------------------- +Public Function _NewDocument(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the (super) SF_Document class or of one of its subclasses (SF_Calc, ...) +' Args: +''' WindowName: see the definition of WindowName in the description of the UI service +''' If absent, the document is presumed to be in the active window +''' If WindowName is an object, it must be a component +''' (com.sun.star.lang.XComponent or com.sun.star.comp.dba.ODatabaseDocument) +''' Returns: the instance or Nothing + +Dim oDocument As Object ' Return value +Dim oSuperDocument As Object ' Companion superclass document +Dim vWindowName As Variant ' Alias of pvArgs(0) +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Dim oUi As Object ' "UI" service +Dim bFound As Boolean ' True if the document is found on the desktop + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) ' Needed when _NewDocument called from _EventManager + If UBound(pvArgs) >= 0 Then vWindowName = pvArgs(0) Else vWindowName = "" + If Not ScriptForge.SF_Utils._Validate(vWindowName, "WindowName", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally + Set oDocument = Nothing + +Try: + Set oUi = ScriptForge.SF_Services.CreateScriptService("UI") + Select Case VarType(vWindowName) + Case V_STRING + If Len(vWindowName) > 0 Then + bFound = False + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + vWindow = oUi._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the argument ? + If (Len(.WindowFileName) > 0 And .WindowFileName = ScriptForge.SF_FileSystem._ConvertToUrl(vWindowName)) _ + Or (Len(.WindowName) > 0 And .WindowName = vWindowName) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = vWindowName) Then + bFound = True + Exit Do + End If + End With + Loop + Else + bFound = True + vWindow = oUi._IdentifyWindow(StarDesktop.CurrentComponent) + End If + Case ScriptForge.V_OBJECT ' com.sun.star.lang.XComponent + bFound = True + vWindow = oUi._IdentifyWindow(vWindowName) + End Select + + If bFound And Not IsNull(vWindow.Frame) And Len(vWindow.DocumentType) > 0 Then + ' Create the right subclass and associate to it a new instance of the superclass + Select Case vWindow.DocumentType + Case "Base" + Set oDocument = New SF_Base + Set oSuperDocument = New SF_Document + Set oDocument.[_Super] = oSuperDocument ' Now both super and subclass are twinned + Set oSuperDocument.[_SubClass] = oDocument + Case "Calc" + Set oDocument = New SF_Calc + Set oSuperDocument = New SF_Document + Set oDocument.[_Super] = oSuperDocument ' Now both super and subclass are twinned + Set oSuperDocument.[_SubClass] = oDocument + Case "Writer" + Set oDocument = New SF_Writer + Set oSuperDocument = New SF_Document + Set oDocument.[_Super] = oSuperDocument ' Now both super and subclass are twinned + Set oSuperDocument.[_SubClass] = oDocument + Case Else ' Only superclass + Set oDocument = New SF_Document + Set oSuperDocument = oDocument + End Select + With oDocument ' Initialize attributes of subclass + Set .[Me] = oDocument + Set ._Component = vWindow.Component + ' Initialize specific attributes + Select Case vWindow.DocumentType + Case "Base" + Set ._DataSource = ._Component.DataSource + Case Else + End Select + End With + With oSuperDocument ' Initialize attributes of superclass + Set .[Me] = oSuperDocument + Set ._Component = vWindow.Component + Set ._Frame = vWindow.Frame + ._WindowName = vWindow.WindowName + ._WindowTitle = vWindow.WindowTitle + ._WindowFileName = vWindow.WindowFileName + ._DocumentType = vWindow.DocumentType + End With + End If + +Finally: + Set _NewDocument = oDocument + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Register._NewDocument + +REM ----------------------------------------------------------------------------- +Public Function _NewForm(ByRef poForm As Object _ + , Optional pbForceInit As Boolean _ + ) As Object +''' Returns an existing or a new SF_Form instance based on the argument +''' If the instance is new (not found in cache), the minimal members are initialized +''' Args: +''' poForm: com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +''' pbForceInit: when True, initialize the form instance. Default = False +''' Returns: +''' A SF_Form instance + +Dim oForm As Object ' Return value + +Try: + Set oForm = SF_Register._FindFormInCache(poForm) + If IsNull(oForm) Then ' Not found + If IsMissing(pbForceInit) Or IsEmpty(pbForceInit) Then pbForceInit = False + Set oForm = New SF_Form + With oForm + ._Name = poForm.Name + Set .[Me] = oForm + Set ._Form = poForm + If pbForceInit Then ._Initialize() + End With + End If + +Finally: + Set _NewForm = oForm + Exit Function +End Function ' SFDocuments.SF_Register._NewForm + +REM ----------------------------------------------------------------------------- +Public Function _RegisterEventScript(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psListener As String _ + , ByVal psScriptCode As String _ + , ByVal psName As String _ + ) As Boolean +''' Register a script event (psEvent) to poObject (Form, SubForm or Control) +''' Args: +''' poObject: a com.sun.star.form.XForm or XControl object +''' psEvent: the "On..." name of the event +''' psListener: the listener name corresponding with the event +''' psScriptCode: The script to trigger when psEvent occurs +''' See Scripting Framework URI Specification : https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' psName: the name of the object to associate with the event +''' Returns: +''' True when successful + +Dim oEvent As Object ' com.sun.star.script.ScriptEventDescriptor +Dim sEvent As String ' The targeted event name +Dim oParent As Object ' The parent object +Dim lIndex As Long ' The index of the targeted event in the events list of the parent object +Dim sName As String ' The corrected UNO event name +Dim i As Long + + _RegisterEventScript = False + On Local Error GoTo Catch + If Not ScriptForge.SF_Session.HasUnoMethod(poObject, "getParent") Then GoTo Finally + +Try: + ' Find object's internal index i.e. how to reach it via getByIndex() + Set oParent = poObject.getParent() + lIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Then + lIndex = i + Exit For + End If + Next i + If lIndex < 0 Then GoTo Finally ' Not found, should not happen + + ' Fix historical typo error + sEvent = Replace(LCase(Mid(psEvent, 3, 1)) & Mid(psEvent, 4), "errorOccurred", "errorOccured") + ' Apply new script code. Erasing it is done with a specific UNO method + If psScriptCode = "" Then + oParent.revokeScriptEvent(lIndex, psListener, sEvent, "") + Else + Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor") + With oEvent + .ListenerType = psListener + .EventMethod = sEvent + .ScriptType = "Script" ' Better than "Basic" + .ScriptCode = psScriptCode + End With + oParent.registerScriptEvent(lIndex, oEvent) + End If + _RegisterEventScript = True + +Finally: + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Register._RegisterEventScript + +REM ============================================== END OF SFDOCUMENTS.SF_REGISTER +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Writer.xba b/wizards/source/sfdocuments/SF_Writer.xba new file mode 100644 index 000000000..eded35de9 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Writer.xba @@ -0,0 +1,635 @@ +<?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="SF_Writer" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Writer +''' ========= +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' managing and manipulating LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the SF_Document module. +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Writer, SF_Base, ... +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties. +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The SF_Writer module is focused on : +''' TBD +''' +''' The current module is closely related to the "UI" service of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.CreateDocument("Writer", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.odt") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Writer", "Untitled 1") ' Default = ActiveWindow +''' ' or Set oDoc = CreateScriptService("SFDocuments.Writer", "Untitled 1") ' Untitled 1 is presumed a Writer document +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Definitions: +''' TBD +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/SF_Writer.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const WRITERFORMNOTFOUNDERROR = "WRITERFORMNOTFOUNDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private [_Super] As Object ' Document superclass, which the current instance is a subclass of +Private ObjectType As String ' Must be WRITER +Private ServiceName As String + +' Window component +Private _Component As Object ' com.sun.star.lang.XComponent + +REM ============================================================ MODULE CONSTANTS + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + Set [_Super] = Nothing + ObjectType = "WRITER" + ServiceName = "SFDocuments.Writer" + Set _Component = Nothing +End Sub ' SFDocuments.SF_Writer Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Writer Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Writer Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Forms(Optional ByVal Form As Variant) As Variant +''' Return either +''' - the list of the Forms contained in the form document +''' - a SFDocuments.Form object based on its name or its index +''' Args: +''' Form: a form stored in the document given by its name or its index +''' When absent, the list of available forms is returned +''' To get the first (unique ?) form stored in the form document, set Form = 0 +''' Exceptions: +''' WRITERFORMNOTFOUNDERROR Form not found +''' Returns: +''' A zero-based array of strings if Form is absent +''' An instance of the SF_Form class if Form exists +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.Forms() +''' Set myForm = oDoc.Forms("myForm") + +Dim oForm As Object ' The new Form class instance +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Dim oXForm As Object ' com.sun.star.form.XForm +Dim vFormNames As Variant ' Array of form names +Dim oForms As Object ' Forms collection +Const cstDrawPage = 0 ' Only 1 drawpage in a Writer document + +Const cstThisSub = "SFDocuments.Writer.Forms" +Const cstSubArgs = "[Form=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Form) Or IsEmpty(Form) Then Form = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + +Try: + ' Start from the document component and go down to forms + Set oForms = _Component.DrawPages(cstDrawPage).Forms + vFormNames = oForms.getElementNames() + + If Len(Form) = 0 Then ' Return the list of valid form names + Forms = vFormNames + Else + If VarType(Form) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Array.Contains(vFormNames, Form, CaseSensitive := True) Then GoTo CatchNotFound + Set oXForm = oForms.getByName(Form) + Else ' Find the form by index + If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound + Set oXForm = oForms.getByIndex(Form) + End If + ' Create the new Form class instance + Set oForm = SF_Register._NewForm(oXForm) + With oForm + Set .[_Parent] = [Me] + ._FormType = ISDOCFORM + Set ._Component = _Component + ._Initialize() + End With + Set Forms = oForm + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(WRITERFORMNOTFOUNDERROR, Form, _FileIdent()) +End Function ' SFDocuments.SF_Writer.Forms + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant _ + , Optional ObjectName As Variant _ + ) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' ObjectName: a sheet or range name +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Writer.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If IsMissing(ObjectName) Or IsEmpty(ObjectName) Then ObjectName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(ObjectName, "ObjectName", V_STRING) Then GoTo Catch + End If + +Try: + ' Superclass or subclass property ? + If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then + GetProperty = [_Super].GetProperty(PropertyName) + ElseIf Len(ObjectName) = 0 Then + GetProperty = _PropertyGet(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName, ObjectName) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Writer.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Writer service as an array + + Methods = Array( _ + "Forms" _ + , "PrintOut" _ + ) + +End Function ' SFDocuments.SF_Writer.Methods + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + , Optional ByVal PrintBackground As Variant _ + , Optional ByVal PrintBlankPages As Variant _ + , Optional ByVal PrintEvenPages As Variant _ + , Optional ByVal PrintOddPages As Variant _ + , Optional ByVal PrintImages As Variant _ + ) As Boolean +''' Send the content of the document to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' Args: +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' PrintBackground: print the background image when True (default) +''' PrintBlankPages: when False (default), omit empty pages +''' PrintEvenPages: print the left pages when True (default) +''' PrintOddPages: print the right pages when True (default) +''' PrintImages: print the graphic objects when True (default) +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("1-4;10;15-18", Copies := 2, PrintImages := False) + +Dim bPrint As Boolean ' Return value +Dim vPrintOptions As Variant ' com.sun.star.text.DocumentSettings + +Const cstThisSub = "SFDocuments.Writer.PrintOut" +Const cstSubArgs = "[Pages=""""], [Copies=1], [PrintBackground=True], [PrintBlankPages=False], [PrintEvenPages=True]" _ + & ", [PrintOddPages=True], [PrintImages=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + If IsMissing(PrintBackground) Or IsEmpty(PrintBackground) Then PrintBackground = True + If IsMissing(PrintBlankPages) Or IsEmpty(PrintBlankPages) Then PrintBlankPages = False + If IsMissing(PrintEvenPages) Or IsEmpty(PrintEvenPages) Then PrintEvenPages = True + If IsMissing(PrintOddPages) Or IsEmpty(PrintOddPages) Then PrintOddPages = True + If IsMissing(PrintImages) Or IsEmpty(PrintImages) Then PrintImages = True + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintBackground, "PrintBackground", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintBlankPages, "PrintBlankPages", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintEvenPages, "PrintEvenPages", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintOddPages, "PrintOddPages", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintImages, "PrintImages", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + vPrintOptions = _Component.createInstance("com.sun.star.text.DocumentSettings") + With vPrintOptions + .PrintPageBackground = PrintBackground + .PrintEmptyPages = PrintBlankPages + .PrintLeftPages = PrintEvenPages + .PrintRightPages = PrintOddPages + .PrintGraphics = PrintImages + .PrintDrawings = PrintImages + End With + + bPrint = [_Super].PrintOut(Pages, Copies, _Component) + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Writer.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Writer class as an array + + Properties = Array( _ + "CustomProperties" _ + , "Description" _ + , "DocumentProperties" _ + , "DocumentType" _ + , "ExportFilters" _ + , "ImportFilters" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw" _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "Keywords" _ + , "Readonly" _ + , "Subject" _ + , "Title" _ + , "XComponent" _ + ) + +End Function ' SFDocuments.SF_Writer.Properties + +REM ----------------------------------------------------------------------------- +Private Function SetProperty(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Writer.set" & psProperty + If IsMissing(pvValue) Then pvValue = Empty + 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("CustomProperties") + CustomProperties = pvValue + Case UCase("Description") + Description = pvValue + Case UCase("Keywords") + Keywords = pvValue + Case UCase("Subject") + Subject = pvValue + Case UCase("Title") + Title = pvValue + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Writer.SetProperty + +REM ======================================================= SUPERCLASS PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CustomProperties() As Variant + CustomProperties = [_Super].GetProperty("CustomProperties") +End Property ' SFDocuments.SF_Writer.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) + [_Super].CustomProperties = pvCustomProperties +End Property ' SFDocuments.SF_Writer.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant + Description = [_Super].GetProperty("Description") +End Property ' SFDocuments.SF_Writer.Description + +REM ----------------------------------------------------------------------------- +Property Let Description(Optional ByVal pvDescription As Variant) + [_Super].Description = pvDescription +End Property ' SFDocuments.SF_Writer.Description + +REM ----------------------------------------------------------------------------- +Property Get DocumentProperties() As Variant + DocumentProperties = [_Super].GetProperty("DocumentProperties") +End Property ' SFDocuments.SF_Writer.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String + DocumentType = [_Super].GetProperty("DocumentType") +End Property ' SFDocuments.SF_Writer.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get ExportFilters() As Variant + ExportFilters = [_Super].GetProperty("ExportFilters") +End Property ' SFDocuments.SF_Writer.ExportFilters + +REM ----------------------------------------------------------------------------- +Property Get ImportFilters() As Variant + ImportFilters = [_Super].GetProperty("ImportFilters") +End Property ' SFDocuments.SF_Writer.ImportFilters + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = [_Super].GetProperty("IsBase") +End Property ' SFDocuments.SF_Writer.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = [_Super].GetProperty("IsCalc") +End Property ' SFDocuments.SF_Writer.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = [_Super].GetProperty("IsDraw") +End Property ' SFDocuments.SF_Writer.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = [_Super].GetProperty("IsImpress") +End Property ' SFDocuments.SF_Writer.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = [_Super].GetProperty("IsMath") +End Property ' SFDocuments.SF_Writer.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = [_Super].GetProperty("IsWriter") +End Property ' SFDocuments.SF_Writer.IsWriter + +REM ----------------------------------------------------------------------------- +Property Get Keywords() As Variant + Keywords = [_Super].GetProperty("Keywords") +End Property ' SFDocuments.SF_Writer.Keywords + +REM ----------------------------------------------------------------------------- +Property Let Keywords(Optional ByVal pvKeywords As Variant) + [_Super].Keywords = pvKeywords +End Property ' SFDocuments.SF_Writer.Keywords + +REM ----------------------------------------------------------------------------- +Property Get Readonly() As Variant + Readonly = [_Super].GetProperty("Readonly") +End Property ' SFDocuments.SF_Writer.Readonly + +REM ----------------------------------------------------------------------------- +Property Get Subject() As Variant + Subject = [_Super].GetProperty("Subject") +End Property ' SFDocuments.SF_Writer.Subject + +REM ----------------------------------------------------------------------------- +Property Let Subject(Optional ByVal pvSubject As Variant) + [_Super].Subject = pvSubject +End Property ' SFDocuments.SF_Writer.Subject + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant + Title = [_Super].GetProperty("Title") +End Property ' SFDocuments.SF_Writer.Title + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) + [_Super].Title = pvTitle +End Property ' SFDocuments.SF_Writer.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant + XComponent = [_Super].GetProperty("XComponent") +End Property ' SFDocuments.SF_Writer.XComponent + +REM ========================================================== SUPERCLASS METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean + Activate = [_Super].Activate() +End Function ' SFDocuments.SF_Writer.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean + CloseDocument = [_Super].CloseDocument(SaveAsk) +End Function ' SFDocuments.SF_Writer.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object + Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) +End Function ' SFDocuments.SF_Writer.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function ExportAsPDF(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal Watermark As Variant _ + ) As Boolean + ExportAsPDF = [_Super].ExportAsPDF(FileName, Overwrite, Pages, Password, Watermark) +End Function ' SFDocuments.SF_Writer.ExportAsPDF + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean + RemoveMenu = [_Super].RemoveMenu(MenuHeader) +End Function ' SFDocuments.SF_Writer.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) + [_Super].RunCommand(Command, Args) +End Sub ' SFDocuments.SF_Writer.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean + Save = [_Super].Save() +End Function ' SFDocuments.SF_Writer.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Writer.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Writer.SaveCopyAs + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + ) As Boolean + SetPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat) +End Function ' SFDocuments.SF_Writer.SetPrinter + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Writer._FileIdent + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) + +Finally: + _IsStillAlive = bAlive + Exit Function +End Function ' SFDocuments.SF_Writer._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvArg As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + cstThisSub = "SFDocuments.Writer.get" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case psProperty + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Writer._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Writer instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DOCUMENT]: Type/File" + + _Repr = "[Writer]: " & [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Writer._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_WRITER +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/__License.xba b/wizards/source/sfdocuments/__License.xba new file mode 100644 index 000000000..47cca670f --- /dev/null +++ b/wizards/source/sfdocuments/__License.xba @@ -0,0 +1,26 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="__License" script:language="StarBasic" script:moduleType="normal"> +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + +</script:module>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/dialog.xlb b/wizards/source/sfdocuments/dialog.xlb new file mode 100644 index 000000000..62e84ea5c --- /dev/null +++ b/wizards/source/sfdocuments/dialog.xlb @@ -0,0 +1,3 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd"> +<library:library xmlns:library="http://openoffice.org/2000/library" library:name="SFDocuments" library:readonly="false" library:passwordprotected="false"/>
\ No newline at end of file diff --git a/wizards/source/sfdocuments/script.xlb b/wizards/source/sfdocuments/script.xlb new file mode 100644 index 000000000..ff4495124 --- /dev/null +++ b/wizards/source/sfdocuments/script.xlb @@ -0,0 +1,14 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd"> +<library:library xmlns:library="http://openoffice.org/2000/library" library:name="SFDocuments" library:readonly="false" library:passwordprotected="false"> + <library:element library:name="__License"/> + <library:element library:name="SF_Document"/> + <library:element library:name="SF_Calc"/> + <library:element library:name="SF_Register"/> + <library:element library:name="SF_Base"/> + <library:element library:name="SF_Form"/> + <library:element library:name="SF_FormControl"/> + <library:element library:name="SF_Writer"/> + <library:element library:name="SF_Chart"/> + <library:element library:name="SF_DocumentListener"/> +</library:library>
\ No newline at end of file |