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" Private Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" 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, ... Private _DocumentSettings As Object ' com.sun.star.XXX.DocumentSettings (XXX = sheet, text, drawing or presentation) ' 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 ' Cache for static toolbar descriptions Private _Toolbars As Object ' SF_Dictionary instance to hold toolbars stored in application or in document ' List of standard context menus Private _ContextMenus As Variant ' Array of ResourceURL strings ' Style descriptor Type StyleDescriptor Family As Object StyleName As String DisplayName As String IsUsed As Boolean BuiltIn As Boolean Category As String ParentStyle As String XStyle As Object End Type Private _StyleFamilies As Variant ' Array of available style families 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 _DocumentSettings = Nothing Set _DocumentProperties = Nothing Set _CustomProperties = Nothing Set _Toolbars = Nothing _ContextMenus = Array() _StyleFamilies = Array() 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 FileSystem() As String ''' Returns the root of the document's virtual file system ''' The "FileSystem" service may be used to explore it, as long as the document remains open ''' The property is not applicable to Base documents ''' Example: ''' Dim sRoot As String, FSO ''' sRoot = oDoc.FileSystem ''' Set FSO = CreateScriptService("FileSystem") ''' MsgBox FSO.FolderExists(FSO.BuildPath(sRoot, "Pictures")) FileSystem = _PropertyGet("FileSystem") End Property ' SFDocuments.SF_Document.FileSystem 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 IsAlive() As Boolean IsAlive = _PropertyGet("IsAlive") End Property ' SFDocuments.SF_Document.IsAlive 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 IsFormDocument() As Boolean IsFormDocument = _PropertyGet("IsFormDocument") End Property ' SFDocuments.SF_Document.IsFormDocument 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 StyleFamilies() As Variant ''' Returns the list of available style families, as an array of strings StyleFamilies = _PropertyGet("StyleFamilies") End Property ' SFDocuments.SF_Document.StyleFamilies 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 ----------------------------------------------------------------------------- Property Get XDocumentSettings() As Variant ''' Gives access to a bunch of additional properties, specific to the document's type, about the document ''' Returns Nothing or a com.sun.star.XXX.DocumentSettings, XXX = text, sheet, drawing or presentation. XDocumentSettings = _PropertyGet("XDocumentSettings") End Property ' SFDocuments.SF_Document.XDocumentSettings 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) If .IsMinimized Then .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 = Not _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: On Local Error GoTo 0 GoTo Finally End Function ' SFDocuments.SF_Document.CloseDocument REM ----------------------------------------------------------------------------- Public Function ContextMenus(Optional ByVal ContextMenuName As Variant _ , Optional ByVal SubmenuChar As Variant _ ) As Variant ''' Returns either a list of the available ContextMenu names in the actual document ''' or a SFWidgets.ContextMenu object instance. ''' Args: ''' ContextMenuName: the usual name of one of the available ContextMenus ''' SubmenuChar: Delimiter used in menu trees ''' Returns: ''' A zero-based array of ContextMenu names when there is no argument, ''' or a new ContextMenu object instance from the SFWidgets library. Const cstThisSub = "SFDocuments.Document.ContextMenus" Const cstSubArgs = "[ContextMenuName=""""], [SubmenuChar="">""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(ContextMenuName) Or IsEmpty(ContextMenuName) Then ContextMenuName = "" If IsMissing(SubmenuChar) Or IsEmpty(SubmenuChar) Then SubmenuChar = ">" If UBound(_ContextMenus) < 0 Then _ContextMenus = _ListContextMenus() If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If VarType(ContextMenuName) = V_STRING Then If Len(ContextMenuName) > 0 Then If Not ScriptForge.SF_Utils._Validate(ContextMenuName, "ContextMenuName", V_STRING, _ContextMenus) Then GoTo Finally End If Else If Not ScriptForge.SF_Utils._Validate(ContextMenuName, "ContextMenuName", V_STRING) Then GoTo Finally ' Manage here the VarType error End If If Not ScriptForge.SF_Utils._Validate(SubmenuChar, "SubmenuChar", V_STRING) Then GoTo Finally End If Try: If Len(ContextMenuName) = 0 Then ContextMenus = _ContextMenus Else ContextMenus = CreateScriptService("SFWidgets.ContextMenu" _ , _Component _ , "private:resource/popupmenu/" & LCase(ContextMenuName) _ , SubmenuChar) End If Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Document.ContextMenus 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", Array(V_STRING, ScriptForge.V_NUMERIC)) 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 Sub DeleteStyles(Optional ByVal Family As Variant _ , Optional ByRef StylesList As Variant _ ) ''' Delete a single style or an array of styles given by their name(s) ''' within a specific styles family. ''' Only user-defined styles may be deleted. Built-in styles are ignored. ''' Args: ''' Family: one of the style families present in the actual document, as a case-sensitive string ''' StylesList: a single style name as a string or an array of style names. ''' The style names may be localized or not. ''' The StylesList is typically the output of the execution of a Styles() method. ''' Returns: ''' Examples: ''' ' Remove all unused styles ''' Const family = "ParagraphStyles" ''' doc.DeleteStyles(family, doc.Styles(family, Used := False, UserDefined := True)) Dim oFamily As Object ' Style names container Dim vStylesList As Variant ' Alias of StylesList Dim sStyle As String ' A single style name Const cstThisSub = "SFDocuments.Document.DeleteStyles" Const cstSubArgs = "Family, StylesList" 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 UBound(_StyleFamilies) < 0 Then _StyleFamilies = _Component.getStyleFamilies().getElementNames() If Not ScriptForge.SF_Utils._Validate(Family, "Family", V_STRING, _StyleFamilies) Then GoTo Finally If IsArray(StylesList) Then If Not ScriptForge.SF_Utils._ValidateArray(StylesList, "StylesList", 1, V_STRING, True) Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(StylesList, "StylesList", V_STRING) Then GoTo Finally End If End If Try: Set oFamily = _GetStyleFamily(Family) If Not IsNull(oFamily) Then With oFamily If Not IsArray(StylesList) Then vStylesList = Array(StylesList) Else vStylesList = StylesList For Each sStyle In vStylesList If .hasByName(sStyle) Then .removeByName(sStyle) Next sStyle End With End If Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally End Sub ' SFDocuments.SF_Document.DeleteStyles REM ----------------------------------------------------------------------------- Public Sub Echo(Optional ByVal EchoOn As Variant _ , Optional ByVal Hourglass As Variant _ ) ''' While a script is executed any display update resulting from that execution ''' is done immediately. ''' For performance reasons it might be an advantage to differ the display updates ''' up to the end of the script. ''' This is where pairs of Echo() methods to set and reset the removal of the ''' immediate updates may be beneficial. ''' Optionally the actual mouse pointer can be modified to the image of an hourglass. ''' Args: ''' EchoOn: when False, the display updates are suspended. Default = True. ''' Multiple calls with EchoOn = False are harmless. ''' Hourglass: when True, the mouse pointer is changed to an hourglass. Default = False. ''' The mouse pointer needs to be inside the actual document's window. ''' Note that it is very likely that at the least manual movement of the mouse, ''' the operating system or the LibreOffice process will take back the control ''' of the mouse icon and its usual behaviour. ''' Returns: ''' Examples: ''' oDoc.Echo(False, Hourglass := True) ''' ' ... "long-lasting" script ... ''' oDoc.Echo() ' Reset to normal Dim oContainer As Object ' com.sun.star.awt.XWindow Dim lPointer As Long ' com.sun.star.awt.SystemPointer constant Dim oPointer As Object ' com.sun.star.awt.Pointer Const cstThisSub = "SFDocuments.Document.Echo" Const cstSubArgs = "[EchoOn=True], [Hourglass=False]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(EchoOn) Or IsEmpty(EchoOn) Then EchoOn = True If IsMissing(Hourglass) Or IsEmpty(Hourglass) Then Hourglass = False If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not SF_Utils._Validate(EchoOn, "EchoOn", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not SF_Utils._Validate(Hourglass, "Hourglass", ScriptForge.V_BOOLEAN) Then GoTo Finally End If Try: With _Component Set oContainer = .CurrentController.Frame.GetContainerWindow() Set oPointer = CreateUnoService("com.sun.star.awt.Pointer") With com.sun.star.awt.SystemPointer If Hourglass Then lPointer = .WAIT Else lPointer = .ARROW End With oPointer.setType(lPointer) ' Mouse icon is set when controller is unlocked If Not EchoOn Then oContainer.setPointer(oPointer) .lockControllers() Else ' EchoOn = True Do While .hasControllersLocked() .unlockControllers() Loop oContainer.setPointer(oPointer) End If End With Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally End Sub ' SFDocuments.SF_Document.Echo 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 Select Case _DocumentType ' Disguise form documents as a Writer document Case "FormDocument" : sFilter = "Writer_pdf_Export" Case Else : sFilter = LCase(_DocumentType) & "_pdf_Export" End Select ' 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" _ , "ContextMenus" _ , "CreateMenu" _ , "Echo" _ , "DeleteStyles" _ , "ExportAsPDF" _ , "ImportStylesFromFile" _ , "PrintOut" _ , "RemoveMenu" _ , "RunCommand" _ , "Save" _ , "SaveAs" _ , "SaveCopyAs" _ , "SetPrinter" _ , "Styles" _ , "Toolbars" _ , "XStyle" _ ) 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" _ , "FileSystem" _ , "ImportFilters" _ , "IsAlive" _ , "IsBase" _ , "IsCalc" _ , "IsDraw" _ , "IsFormDocument" _ , "IsImpress" _ , "IsMath" _ , "IsWriter" _ , "Keywords" _ , "Readonly" _ , "StyleFamilies" _ , "Subject" _ , "Title" _ , "XComponent" _ , "XDocumentSettings" _ ) 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 Then If IsArray(Args(0)) Then vArgs = Args(0) End If 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, True) 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 ----------------------------------------------------------------------------- Public Function Styles(Optional ByVal Family As Variant _ , Optional ByVal NamePattern As variant _ , Optional ByVal Used As variant _ , Optional ByVal UserDefined As Variant _ , Optional ByVal ParentStyle As Variant _ , Optional ByVal Category As Variant _ ) As Variant ''' Returns an array of style names matching the filters given in argument ''' Args: ''' Family: one of the style families present in the actual document, as a case-sensitive string ''' NamePattern: a filter on the style names, as a case-sensitive string pattern ''' Admitted wildcard are: the "?" represents any single character ''' the "*" represents zero, one, or multiple characters ''' The names include the internal and localized names. ''' Used: when True, the style must be used in the document ''' When absent, the argument is ignored. ''' UserDefined: when True, the style must have been added by the user, either in the document or its template ''' When absent, the argument is ignored. ''' ParentStyle: when present, only the children of the given, localized or not, parent style name are retained ''' Category: a case-insensitive string: TEXT, CHAPTER, LIST, INDEX, EXTRA, HTML ''' For their respective meanings, read https://api.libreoffice.org/docs/idl/ref/namespacecom_1_1sun_1_1star_1_1style_1_1ParagraphStyleCategory.html ''' The argument is ignored when the Family is not = "ParagraphStyles". ''' Returns: ''' An array of style localized names ''' An error is raised when the Family does not exist. ''' The returned array may be empty. ''' Example: ''' Dim vStyles As Variant ''' vStyles = doc.Styles("ParagraphStyles") ' All styles in the family ''' vStyles = doc.Styles("ParagraphStyles", "H*") ' Heading, Heading 1, ... ''' vStyles = doc.Styles("ParagraphStyles", Used := False, UserDefined := True) ''' ' All user-defined styles that are not used ''' vStyles = doc.Styles("ParagraphStyles", ParentStyle := "Standard") ''' ' All styles derived from the "Default Paragraph Style" Dim vStyles As Variant ' Return value Dim sStyle As String ' A single style name Dim oFamily As Object ' Style names container Dim oStyle As Object ' _StyleDescriptor Dim oParentStyle As Object ' _StyleDescriptor Dim bValid As Boolean ' When True, a given style passes the filter Dim i As Integer Const cstCategories = "TEXT,CHAPTER,LIST,INDEX,EXTRA,HTML" Const cstThisSub = "SFDocuments.Document.Styles" Const cstSubArgs = "Family, [NamePattern=""*""], [Used=True|False], [UserDefined=True|False], ParentStyle = """"" _ & ", [Category=""""|""TEXT""|""CHAPTER""|""LIST""|""INDEX""|""EXTRA""|""HTML""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch vStyles = Array() Check: If IsMissing(NamePattern) Or IsEmpty(NamePattern) Then NamePattern = "" If IsMissing(Used) Then Used = Empty If IsMissing(UserDefined) Then UserDefined = Empty If IsMissing(ParentStyle) Or IsEmpty(ParentStyle) Then ParentStyle = "" If IsMissing(Category) Or IsEmpty(Category) Then Category = "" If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If UBound(_StyleFamilies) < 0 Then _StyleFamilies = _Component.getStyleFamilies().getElementNames() If Not ScriptForge.SF_Utils._Validate(Family, "Family", V_STRING, _StyleFamilies) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(NamePattern, "NamePattern", V_STRING) Then GoTo Finally If Not IsEmpty(Used) Then If Not ScriptForge.SF_Utils._Validate(Used, "Used", ScriptForge.V_BOOLEAN) Then GoTo Finally End If If Not IsEmpty(UserDefined) Then If Not ScriptForge.SF_Utils._Validate(UserDefined, "UserDefined", ScriptForge.V_BOOLEAN) Then GoTo Finally End If If Not ScriptForge.SF_Utils._Validate(ParentStyle, "ParentStyle", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Category, "Category", V_STRING, Split("," & cstCategories, ",")) Then GoTo Finally End If Try: Set oFamily = _GetStyleFamily(Family) If Not IsNull(oFamily) Then ' Load it with the complete list of styles in the family vStyles = oFamily.getElementNames() ' Scan the list and retain those passing the filter For i = 0 To UBound(vStyles) sStyle = vStyles(i) Set oStyle = _GetStyle(oFamily, sStyle) If Not IsNull(oStyle) Then With oStyle ' Pattern ? bValid = ( Len(NamePattern) = 0 ) If Not bValid Then bValid = ScriptForge.SF_String.IsLike(.DisplayName, NamePattern, CaseSensitive := True) ' Used ? If bValid And Not IsEmpty(Used) Then bValid = ( Used = .IsUsed ) ' User defined ? If bValid And Not IsEmpty(UserDefined) Then bValid = ( UserDefined = Not .BuiltIn ) ' Parent style ? If bValid And Len(ParentStyle) > 0 Then Set oParentStyle = _GetStyle(oFamily, .ParentStyle) bValid = Not IsNull(oParentStyle) ' The child has a parent If bValid Then bValid = ( ParentStyle = oParentStyle.DisplayName Or ParentStyle = oParentStyle.StyleName) End If ' Category ? If bValid And Len(Category) > 0 Then bValid = ( UCase(Category) = .Category ) If bValid Then vStyles(i) = .DisplayName Else vStyles(i) = "" End With Else vStyles(i) = "" End If Next i ' Reject when not valid vStyles = ScriptForge.SF_Array.TrimArray(vStyles) End If Finally: Styles = vStyles ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Document.Styles REM ----------------------------------------------------------------------------- Public Function Toolbars(Optional ByVal ToolbarName As Variant) As Variant ''' Returns either a list of the available toolbar names in the actual document ''' or a Toolbar object instance. ''' Args: ''' ToolbarName: the usual name of one of the available toolbars ''' Returns: ''' A zero-based array of toolbar names when the argument is absent, ''' or a new Toolbar object instance from the SF_Widgets library. Const cstThisSub = "SFDocuments.Document.Toolbars" Const cstSubArgs = "[ToolbarName=""""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(ToolbarName) Or IsEmpty(ToolbarName) Then ToolbarName = "" If IsNull(_Toolbars) Then _Toolbars = ScriptForge.SF_UI._ListToolbars(_Component) If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If VarType(ToolbarName) = V_STRING Then If Len(ToolbarName) > 0 Then If Not ScriptForge.SF_Utils._Validate(ToolbarName, "ToolbarName", V_STRING, _Toolbars.Keys()) Then GoTo Finally End If Else If Not ScriptForge.SF_Utils._Validate(ToolbarName, "ToolbarName", V_STRING) Then GoTo Finally ' Manage here the VarType error End If End If Try: If Len(ToolbarName) = 0 Then Toolbars = _Toolbars.Keys() Else Toolbars = CreateScriptService("SFWidgets.Toolbar", _Toolbars.Item(ToolbarName)) End If Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Document.Toolbars REM ----------------------------------------------------------------------------- Public Function XStyle(Optional ByVal Family As Variant _ , Optional ByVal StyleName As variant _ ) As Object ''' Returns a com.sun.star.style.Style UNO object corresponding with the arguments ''' Args: ''' Family: one of the style families present in the actual document, as a not case-sensitive string ''' StyleName: one of the styles present in the given family, as a case-sensitive string ''' The StyleName may be localized or not. ''' Returns: ''' A com.sun.star.style.XStyle UNO object or one of its descendants, ''' like com.sun.star.style.CellStyle or com.sun.star.style.ParagraphStyle etc. ''' An error is raised when the Family does not exist. ''' Nothing is returned when the StyleName does not exist in the given Family. ''' Example: ''' Dim oStyle As Object ''' Set oStyle = doc.XStyle("ParagraphStyle", "Heading 2") Dim oXStyle As Object ' Return value Dim oFamily As Object ' Style names container Const cstThisSub = "SFDocuments.Document.XStyle" Const cstSubArgs = "Family, StyleName" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Set oXStyle = Nothing Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If UBound(_StyleFamilies) < 0 Then _StyleFamilies = _Component.getStyleFamilies().getElementNames() If Not ScriptForge.SF_Utils._Validate(Family, "Family", V_STRING, _StyleFamilies) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(StyleName, "StyleName", V_STRING) Then GoTo Finally End If Try: Set oFamily = _GetStyleFamily(Family) If Not IsNull(oFamily) Then If oFamily.hasByName(StyleName) Then Set oXStyle = oFamily.getByName(StyleName) End If Finally: Set XStyle = oXStyle ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Document.XStyle 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 ' OS notation is used to avoid presence of "%nn" in error messages and wrong parameter substitutions _FileIdent = Iif(Len(_WindowFileName) > 0, 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 = ScriptForge.SF_Utils._GetPropertyValue(vFilter, "DocumentService") If sType = sIdentifier Then lFlags = ScriptForge.SF_Utils._GetPropertyValue(vFilter, "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 _GetStyle(ByRef poFamily As Object _ , Optional ByVal pvDisplayName As Variant _ , Optional ByVal pvStyleIndex As Variant _ ) As Object ''' Returns the style descriptor of the style passed as argument in the given family ''' Args: ''' poFamily: a com.sun.star.container.XNameContainer/XStyleFamily object ''' pvDisplayName: case-sensitive string, localized style name as visible in the user interface ''' pvStyleIndex: index of the style in the family, as an integer ''' Exactly 1 out of the last 2 arguments must be supplied ''' Returns: ''' A StyleDescriptor object or Nothing Dim oStyleDescriptor ' Return value Dim oStyle As Object ' com.sun.star.style.XStyle and variants Dim bFound As Boolean ' When True, the style has been found in the family Dim vCategories As Variant ' Array of category constants Dim iCategory As Integer ' Index of vCategories Dim oSession As Object : Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") Dim i As Integer Const cstCAT0 = "TEXT" ' is applied to styles that are used for common text Const cstCAT1 = "CHAPTER" ' is applied to styles that are used as headings Const cstCAT2 = "LIST" ' is applied to styles that are used in numberings and lists Const cstCAT3 = "INDEX" ' is applied to styles that are used in indexes Const cstCAT4 = "EXTRA" ' is applied to styles that are used in special regions like headers, footers, and footnote text Const cstCAT5 = "HTML" ' is applied to styles that are used to support HTML Const cstCAT = cstCAT0 & "," & cstCAT1 & "," & cstCAT2 & "," & cstCAT3 & "," & cstCAT4 & "," & cstCAT5 On Local Error GoTo Catch Set oStyleDescriptor = Nothing Check: If IsNull(poFamily) Then GoTo Catch If IsMissing(pvDisplayName) Or IsEmpty(pvDisplayName) Then pvDisplayName = "" If IsMissing(pvStyleIndex) Or IsEmpty(pvStyleIndex) Then pvStyleIndex = -1 Try: ' Find style corresponding with the given display name With poFamily If Len(pvDisplayName) > 0 Then bFound = .hasByName(pvDisplayName) ' hasByName searches both for Name and DisplayName attributes here If bFound Then Set oStyle = .getByName(pvDisplayName) Else GoTo Catch ElseIf pvStyleIndex >= 0 And pvStyleIndex < .Count Then Set oStyle = .getByIndex(pvStyleIndex) Else GoTo Catch ' Should not happen End If End With ' Setup the style descriptor Set oStyleDescriptor = New StyleDescriptor With oStyleDescriptor Set .Family = poFamily .StyleName = oStyle.Name .DisplayName = oStyle.DisplayName .IsUsed = oStyle.isInUse .BuiltIn = Not oStyle.isUserDefined() .Category = "" If oSession.HasUnoProperty(oStyle, "Category") Then vCategories = Split(cstCAT, ",") iCategory = oStyle.Category If iCategory >= 0 And iCategory <= UBound(vCategories) Then .Category = vCategories(iCategory) End If .ParentStyle = oStyle.ParentStyle Set .XStyle = oStyle End With Finally: Set _GetStyle = oStyleDescriptor Exit Function Catch: Set oStyleDescriptor = Nothing GoTo Finally End Function ' SFDocuments.SF_Document._GetStyle REM ----------------------------------------------------------------------------- Private Function _GetStyleFamily(ByVal psFamilyName As String) As Object ''' Returns the style names container corresponding with the argument ''' Args: ''' psFamilyName: CellStyles, CharacterStyles, FrameStyles, GraphicsStyles, ListStyles, ''' NumberingStyles, PageStyles, ParagraphStyles, TableStyles ''' Returns: ''' A com.sun.star.container.XNameContainer/XStyleFamily object or Nothing Dim oFamily As Object ' Return value Dim oFamilies As Object ' com.sun.star.container.XNameAccess Dim iIndex As Integer ' Index in vFamilies of the given argument On Local Error GoTo Catch Set oFamily = Nothing Try: Set oFamilies = _Component.getStyleFamilies() If UBound(_StyleFamilies) < 0 Then _StyleFamilies = oFamilies.getElementNames() ' oFamilies.hasByName()/getByName() not used here to admit not case-sensitive family names iIndex = ScriptForge.SF_Array.IndexOf(_StyleFamilies, psFamilyName, CaseSensitive := False) If iIndex >= 0 Then Set oFamily = oFamilies.getByName(_StyleFamilies(iIndex)) Finally: Set _GetStyleFamily = oFamily Exit Function Catch: Set oFamily = Nothing GoTo Finally End Function ' SFDocuments.SF_Document._GetStyleFamily REM ----------------------------------------------------------------------------- Public Sub _ImportStylesFromFile(Optional FileName As Variant _ , Optional ByRef Families As Variant _ , Optional ByVal Overwrite As variant _ ) As Variant ''' Load all the styles belonging to one or more style families from a closed file ''' into the actual document. The actual document must be a Calc or a Writer document. ''' Are always imported together: ''' ParagraphStyles and CharacterStyles ''' NumberingStyles and ListStyles ''' Args: ''' FileName: the file from which to load the styles in the FileSystem notation. ''' The file is presumed to be of the same document type as the actual document ''' Families: one of the style families present in the actual document, as a case-sensitive string ''' or an array of such strings. Default = all families ''' Overwrite: when True, the actual styles may be overwritten. Default = False ''' Returns: ''' Exceptions: ''' UNKNOWNFILEERROR The given file name does not exist ''' Example: ''' oDoc.ImportStylesFromFile("C:\...\abc.odt", Families := "ParagraphStyles", Overwrite := True) Dim vFamilies As Variant ' Alias of Families Dim oFamilies As Object ' com.sun.star.container.XNameAccess Dim vOptions As Variant ' Array of property values Dim bAll As Boolean ' When True, ALL style families are considered Dim sName As String ' A single name in vOptions Dim FSO As Object : Set FSO = ScriptForge.SF_FileSystem Dim i As Integer Const cstThisSub = "SFDocuments.Document.ImportStylesFromFile" Const cstSubArgs = "FileName, [Families], [Overwrite=False]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(Families) Or IsEmpty(Families) Then Families = "" If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False Set oFamilies = _Component.getStyleFamilies() If UBound(_StyleFamilies) < 0 Then _StyleFamilies = oFamilies.getElementNames() If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName", False) Then GoTo Finally If IsArray(Families) Then If Not ScriptForge.SF_Utils._ValidateArray(Families, "Families", 1, V_STRING, True) Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(Families, "Families", V_STRING, ScriptForge.SF_Array.Append(_StyleFamilies, "")) Then GoTo Finally End If If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally End If If Not FSO.FileExists(FileName) Then GoTo CatchNotExists If IsArray(Families) Then vFamilies = Families Else bAll = ( Len(Families) = 0 ) ' When Families is absent (= ""), all families should be considered vFamilies = Array(Families) End If Try: With ScriptForge.SF_Utils Set vOptions = _Component.getStyleFamilies().getStyleLoaderOptions ' By default, all style families are imported (True) If Not bAll Then For i = 0 To UBound(vOptions) vOptions(i).Value = False Next i For i = LBound(vFamilies) To UBound(vFamilies) Select Case UCase(vFamilies(i)) Case "PARAGRAPHSTYLES", "CHARACTERSTYLES" : sName = "TextStyles" Case "FRAMESTYLES" : sName = "FrameStyles" Case "PAGESTYLES" : sName = "PageStyles" Case "NUMBERINGSTYLES", "LISTSTYLES" : sName = "NumberingStyles" Case "CELLSTYLES" : sName = "PageStyles" Case Else : sName = "" End Select If Len(sName) > 0 Then Set vOptions = ._SetPropertyValue(vOptions, "Load" & sName, True) Next i End If vOptions = ._SetPropertyValue(vOptions, "OverwriteStyles", Overwrite) End With ' Finally, import oFamilies.loadStylesFromURL(FSO._ConvertToUrl(FileName), vOptions) Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally CatchNotExists: SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) GoTo Finally End Sub ' SFDocuments.SF_Document._ImportStylesFromFile 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 Function _ListContextMenus() As Variant ''' Returns an array of the usual names of the context menus available in the current document Dim vMenus As Variant ' Return value Dim vMenusObj As Variant ' Array of arrays of property values Dim oSupplier As Object ' /singletons/com.sun.star.ui.theModuleUIConfigurationManagerSupplier Dim sComponentType As String ' Argument to determine the system config manager, ex. "com.sun.star.text.TextDocument" Dim oUIConf As Object ' com.sun.star.ui.XUIConfigurationManager Dim i As Long On Local Error GoTo Catch vMenus = Array() Try: Set oSupplier = ScriptForge.SF_Utils._GetUNOService("ModuleUIConfigurationManagerSupplier") sComponentType = ScriptForge.SF_UI._GetConfigurationManager(_Component) Set oUIConf = oSupplier.getUIConfigurationManager(sComponentType) ' Discard menubar, statusbar, ... vMenusObj = oUIConf.getUIElementsInfo(com.sun.star.ui.UIElementType.POPUPMENU) ' Extract and sort the names ReDim vMenus(0 To UBound(vMenusObj)) For i = 0 To UBound(vMenusObj) vMenus(i) = Mid(vMenusObj(i)(0).Value, Len("private:resource/popupmenu/") + 1) Next i vMenus = ScriptForge.SF_Array.Unique(vMenus, CaseSensitive := True) Finally: _ListContextMenus = vMenus Exit Function Catch: On Local Error GoTo 0 GoTo Finally End Function ' SFDocuments.SF_Document._ListContextMenus 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 oTransient As Object ' com.sun.star.frame.TransientDocumentsDocumentContentFactory Dim oContent As Object ' com.sun.star.comp.ucb.TransientDocumentsContent Dim cstThisSub As String Const cstSubArgs = "" _PropertyGet = False Select Case _DocumentType Case "Base", "Calc", "FormDocument", "Writer" cstThisSub = "SFDocuments.SF_" & _DocumentType & ".get" & psProperty Case Else : cstThisSub = "SFDocuments.SF_Document.get" & psProperty End Select ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) If psProperty <> "IsAlive" Then If Not _IsStillAlive() Then GoTo Finally End If Select Case psProperty Case "CustomProperties" _CustomProperties = CreateScriptService("Dictionary", True) ' Always reload as updates could have been done manually by user ' (with case-sensitive comparison of keys) _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 "FileSystem" ' Natural choice would have been to use the component.RunTimeUID property ' However it is optional in the OfficeDocument service and not available for Base documents ' Below a more generic alternative derived from the get_document_uri() method found in apso.py Set oTransient = ScriptForge.SF_Utils._GetUnoService("TransientDocumentFactory") Set oContent = oTransient.createDocumentContent(_Component) _PropertyGet = oContent.getIdentifier().ContentIdentifier & "/" Case "ImportFilters" _PropertyGet = _GetFilterNames(False) Case "IsAlive" _PropertyGet = _IsStillAlive(False, False) Case "IsBase", "IsCalc", "IsDraw", "IsFormDocument", "IsImpress", "IsMath", "IsWriter" _PropertyGet = ( Mid(psProperty, 3) = _DocumentType ) Case "Keywords" _PropertyGet = Join(_Component.DocumentProperties.Keywords, ", ") Case "Readonly" _PropertyGet = _Component.isReadonly() Case "StyleFamilies" If UBound(_StyleFamilies) < 0 Then _StyleFamilies = _Component.getStyleFamilies().getElementNames() _PropertyGet = _StyleFamilies Case "Subject" _PropertyGet = _Component.DocumentProperties.Subject Case "Title" _PropertyGet = _Component.DocumentProperties.Title Case "XComponent" Set _PropertyGet = _Component Case "XDocumentSettings" With _Component If IsNull(_DocumentSettings) Then Select Case _DocumentType Case "Calc" : Set _DocumentSettings = .createInstance("com.sun.star.sheet.DocumentSettings") Case "Draw" : Set _DocumentSettings = .createInstance("com.sun.star.drawing.DocumentSettings") Case "FormDocument", "Writer" Set _DocumentSettings = .createInstance("com.sun.star.text.DocumentSettings") Case "Impress" : Set _DocumentSettings = .createInstance("com.sun.star.presentation.DocumentSettings") Case Else : Set _DocumentSettings = Nothing End Select End If Set _PropertyGet = _DocumentSettings End With 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