OpenOffice.info

Code: Alles auswählen

    REM  *****  BASIC  *****
    '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 a date 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 makeDayCopy()
    sMakroName = "makeDayCopy "
    sMakroVersion = "2006-05-20"


    ' 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)
       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

Sub ReNummer_Speichern
   dim dummy()
   oDoc = ThisComponent
   oSheet = oDoc.Sheets.getByName("Tabelle1") 'Tabellenblattname
   oCell = oSheet.getCellRangeByName("A1") 'Zelle A1, in der Rechnungsnummer steht
   sReNummer = oCell.String  
   sLaufwerk = "C:/" 'Achtung: Für den Speicherort den Laufwerkspfad anpassen
   Filename = sReNummer
   neuerpfad = sLaufwerk + Filename + ".ods"
   dateiurl=converttourl(neuerpfad)
   odoc.storeAsUrl(dateiurl,dummy())
End Sub[