LibreOffice-Forum

Code: Alles auswählen

  
    ...

    ' get active component
    oComp = StarDesktop.CurrentComponent

    ' macro run from blank Desktop
>>     If oComp.supportsService(_
         "com.sun.star.frame.StartModule" ) Then   
    ' exit without action
      Exit Sub
      End If
   ....

Code: Alles auswählen

Dim oDoc as Object
	oDoc= ThisComponent

Code: Alles auswählen

' Eine Möglichkeit
Stardesktop.Frames.getByIndex(0)

' Oder über eine Schleife über alle Indizes mit Abfrage des Dokuments-Titles
For i = 0 To Stardesktop.Frames.Count
	if Stardesktop.Frames.getByIndex(i).Title = "Unbenannt 1 - LibreOffice Calc" Then ...
Next i

Code: Alles auswählen

REM  *****  BASIC  *****

Sub Main

End Sub

    'Copyright (c) 2006 Winfried Rohr, re-Solutions Software Test Engineering
    'mailto: ooo@re-solutions.de  Untere Zahlbacher Strasse 18, D-55131 Mainz

    'This program is free software; you can redistribute it and/or modify it under
    'the terms of the GNU General Public License as published by the Free Software
    'Foundation; either version 2 of the License, or (at your option) any later
    'version.

    'This program 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. See the GNU General Public License for more details.

    'You should have received a copy of the GNU General Public License along with
    'this program; if not, write to the Free Software Foundation, Inc., 59 Temple
    'Place, Suite 330, Boston, MA 02111-1307 USA
    ' ========================================================================

    ' make a copy of actual loaded document
    ' append date and time string to filename
    ' and store in same location
    ' notice if already exists

    ' =====
    ' Texte fuer Nachrichten
    '
    ' Nachricht1
    CONST cDokGefunden = "Dokument ist bereits vorhanden:"
    'CONST cDokGefunden = "Document found at location"
    CONST cNoNewCopy = "Es wurde keine Kopie erzeugt!"
    'CONST cNoNewCopy = "No new copy was made!"

    'Nachricht2
    CONST cNoLoc = "Dokument noch nicht gespeichert (keine URL gefunden)"
    'CONST cNoLoc = "Document was not saved yet (could not find an URL)"
    CONST cSaveAndRerun = "Erst sichern, dann Makro eventl. erneut abrufen"
    'CONST cSaveAndRerun = "Save first, then run this macro again to make a copy"

    'Nachricht3
    CONST cRunInBase = "Keine Funktion in OOo BASE"
    'CONST cRunInBase = "No function in OOo BASE"
    CONST cDontWork = "Makro beendet"
    ' CONST cDontWork = "Macro finished"

    'Nachrichten des ErrHandlers
    CONST cErrInLine = "Fehler in Zeile: "
    'CONST cErrInLine = "Error in line: "
    CONST cErrNo = "Fehler-Nr. "
    'CONST cErrNo = "Error-No. "
    CONST cErrMod = "Fehler in Makro"
    'CONST cErrMod = "Error in macro"
    ' =====

    Sub makeCopy()
    sMakroName = "makeCopy "
'    sMakroVersion = "2006-05-20"
	If NOT Globalscope.BasicLibraries.IsLibraryLoaded("Tools") Then
   		Globalscope.BasicLibraries.LoadLibrary("Tools")
	End If

    ' try to catch errors and display a message
    On Local Error GoTo ErrHandler

    ' =====
    ' MAIN
    ' =====

    ' get active component
    oComp = StarDesktop.CurrentComponent

    ' macro run from blank Desktop
      If oComp.supportsService(_
         "com.sun.star.frame.StartModule" ) Then   
    ' exit without action
      Exit Sub
      End If

    ' macro run from Basic IDE
      If oComp.supportsService(_
         "com.sun.star.script.BasicIDE" ) Then   
    ' exit without action
      Exit Sub
      End If

    ' macro run from Base main window
    'Nachricht3
      If oComp.supportsService(_
         "com.sun.star.sdb.OfficeDatabaseDocument" ) Then
        msgbox cRunInBase & chr(13) &_'          cDontWork , 64 , sMakroName & sMakroVersion
    Exit Sub
    End If
    
    oDok = ThisComponent

    'XXX warning
    'XXX code will fail on next statement, if no document is loaded
    ' check if file was stored
    If oDok.hasLocation() then
       
       ' check if HELP window is in foreground
       If Instr( oDok.getLocation() , "vnd.sun.star.help:" ) then
          '      msgbox "HELP window in foreground"

       ' exit without action
       Exit Sub
       End if

       ' yes, make a copy
       ' compose additional data to create alternative name for file
       ' here: datestamp in ISO format used (good for sorting)

       xFile = "E:\LibreOffice-Backup\" & FileNameoutofPath(oDok.title,) & "_" & format(now(),"YYYYMMDD-hhmmss") & ".ods"
       sFileURL=converttourl( xFile )

'        sFileURL = oDok.getURL() & "_" & cDateToISO( Now() )

       ' check if such a file exist
       if FileExists( sFileURL ) then
          ' yes there is one
          ' issue a message to inform user
          msgbox cDokGefunden & chr(13) &_
             sFileURL & chr(13) & _
             cNoCopyMade ,_
             64 ,sMakroName & sMakroVersion
       else
          ' check if we have rights to save there under this name
          ' how    ???
          ' can save with new name   

          '## note: no checking on length of filename
          '##       restricted on some platforms
          '##       untested _ not sure what will happen
          oDok.StoreToURL( sFileURL , Array() )
       end if


    Else

       ' no filename by now - cannot do a thing
       msgbox cNoLoc & chr(13) &_
          cSaveAndRerun , 64 , sMakroName & sMakroVersion

    End If


    Exit sub
    ' =====
    ' =====
    ErrHandler:
    MsgBox _
       cErrInLine & Erl & _
       CHR(10) & cErrNo & Err & ": " & Error$ ,, _
       cErrMod & sModulName & sModulVersion
    End Sub

Code: Alles auswählen

"YYYYMMDD-hhmmss"