OpenOffice.org Forum at OOoForum.orgThe OpenOffice.org Forum
 
 [Home]   [FAQ]   [Search]   [Memberlist]   [Usergroups]   [Register
 [Profile]   [Log in to check your private messages]   [Log in

Macro for ISO formated dates for header in Calc

 
Post new topic   Reply to topic    OOoForum.org Forum Index -> OpenOffice.org Code Snippets
View previous topic :: View next topic  
Author Message
ristoi
General User
General User


Joined: 25 Aug 2009
Posts: 26
Location: Järvenpää

PostPosted: Tue Jul 13, 2010 12:31 pm    Post subject: Macro for ISO formated dates for header in Calc Reply with quote

Here is macro which format dates to ISO format in header and footer of the Spreadsheet. This is for a kind of temporary use because such feature is on its way to Calc. But maybe somebody find out something to develope from here.

Regards
Risto


Code:

REM  *****  BASIC  *****
Option explicit

REM      ===================  Asentaminen ==================
REM
REM 1) Mukauta, Tallenna kohteeseen: OpenOffice.org, Tapahtumalle "Avaa asiakirja" määritä makro "Kutsu"
REM
REM Näin asennettuna makro päivittää säännönmukaiset päivämäärät tunnusalueilla laskentataulukkoa avattaessa
REM Säännöt:
REM A) Päivämäärää seuraa osion lopussa vain välilyönti: päivitetään aina ajankohdan päivämääräksi, jos ei jo ole
REM B) Päivämäärää seuraa osion lopussa tasan kaksi välilyöntiä: päivämäärä muunnetaan ISO päivämääräksi, jos tarpeen
REM HUOM: Tuotos on aina  merkkijono, vaikka aiemmin olisi ollut kenttä.
REM
REM
REM    ===================  Installation ==================
REM ...for update of spesific datevalues in Header/footer of Spreadsheets at opening
REM
REM 1) Tools - Customize - Event tab
REM 2) On Events Tab select bottom of tab Save In [OpenOffice.org]
REM 3)  Select [Open Document] item in Event List.
REM 4) At Assign: area click [Macro ...] button.
REM 5) Macro Name: Kutsu
REM 6) Click [OK]

REM Conditions for dates string update or  date field conversion to date string:
REM Date must locate almost last in the section (Left, Center, Right) only space or two spaces after it
REM If there is only one space after the date it is updated todays ISO date string if it is not todays date
REM If there is two spaces after the date it is only converted to ISO date format string

REM Käyttöikeudet: http://creativecommons.org/licenses/by/1.0/fi/
REM Saa siis käyttää vapaasti ja muunnella (RJ)

Sub Kutsu
'Titta "Kutsu"
ISOPvmTunnuksiin(ThisComponent)
REM tämä kutsuva rutiini tarvitaan, että päivitys toimisi.
End Sub

REM Kiitokset SetHeaderTextInSpreadSheet-rutiinista Andrew Pitonyakille
Sub ISOPvmTunnuksiin (Optional oDokum as Object)      '
REM Funktio ISOPvmTunnuksiin vaihtaa Calcin laskenta-asiakirjan (oDokum)
REM avoimen taulukkolehden sivutyylin ylä- ja alatunnusten päivämäärät ISO-muotoon,
REM jos niitä seuraa välilyönti tekstin lopussa.
REM Päivämäärän muotoilu siis säilyy, jos se on aivan tekstin viimeinen
REM tai sitä seuraa useampia merkkejä
REM (RJ)

DIM  oAsiak as Object, oLehti as Object, oStyyli as Object, oTunnus as Object
DIM oTyylit as Object
'DIM bOnMuutettu as Boolean
Dim s as String

    REM asetetaan argumenttien puuttuessa oletusarvot
   IF IsMissing(oDokum) then
      oAsiak = ThisComponent
   else
      oAsiak = oDokum
   EndIf
   'Titta oAsiak
     REM Tarkistetaan, onko Calcin asiakirja
     If NOT IsSpreadsheetDoc(oAsiak) then
     REM jos ei ole laskentataulukko, niin lopetetaan falsella
        ISOPvmTunnuksiin=false
        Exit Sub
     EndIf
     REM tästä jatkuu ikäänkuin Else
     '
     oLehti = oAsiak.CurrentController.getActiveSheet
     REM haetaan sivun tyyli
     oTyylit = oAsiak.StyleFamilies.getByName("PageStyles")
     oStyyli = oTyylit.getByName(oLehti.PageStyle)
     '
     REM seuraavat aiheuttavat vain turhaa muutosta?
     'oStyyli.HeaderOn = True
     'oStyyli.FooterOn = True
    REM funktio-kutsut hoitavat aukeaman oikean ja vasemman sivun sekä ylä- ja alatunnuksen
    REM arvot päivitetään vain jos on tarvetta, näin tulee vähemmän häiriötä käyttäjälle
     oTunnus = oStyyli.RightPageHeaderContent
     IF MuuttuikoTekstit(oTunnus) then oStyyli.RightPageHeaderContent = oTunnus
     oTunnus = oStyyli.LeftPageHeaderContent
     IF MuuttuikoTekstit(oTunnus) then oStyyli.LeftPageHeaderContent = oTunnus
     oTunnus = oStyyli.RightPageFooterContent
     IF MuuttuikoTekstit(oTunnus) then oStyyli.RightPageFooterContent = oTunnus
     oTunnus = oStyyli.LeftPageFooterContent
     IF MuuttuikoTekstit(oTunnus) then oStyyli.LeftPageFooterContent = oTunnus
     'Titta "Hei, ISOPvmTunnuksiin suoritettiin"
End Sub 'ISOPvmTunnuksiin

Function sISOKorvausehdotus (byVal sMj as String) as String
REM sISOKorvausehdotus-funktio muodostaa sMj-merkkijonon pohjalta uuden merkkijonon
REM jossa lopussa sijaitseva päivämäärä on muunnettu ISO-päivämääräksi tietyillä ehdoilla.
REM Ehto 1: viimeinen merkki päivämäärään jälkeen on välilyönti: päivitetään aina, jos nyt on uudempi päiväys.
REM Ehto 2: kaksi viimeistä merkkiä päivämäärään jälkeen on välilyöntejä: ainoastaan ISO-muunnos
REM

DIM lPaikka as Long
DIM tTemp as Date
DIM sTilap as String, sPVMosat() as String
DIM bOnJoISO as Boolean, bNyt as Boolean
   REM virheenkäsittely pyrkii vain ohittamaan ongelman palauttaen argumentin
'   ON LOCAL ERROR GOTO Ulos:
   'lTpituus = Len(sTurvaus)
   lPaikka = Len(sMj)
   
   If lPaikka > 10 then
      If NOT (Mid(sMj,lPaikka) = " ") then
         REM ei ole "turvamerkitty"
         sISOKorvausehdotus = sMj
         Exit Function   
      elseIF Mid(sMj,lPaikka-1,2) = "  " then
         REM vaihdetaan vain ei-ISO-päivämäärä ISOksi
         lPaikka = lPaikka - 11
         bNyt = false
      else
         REM valmistellaan päivämäärän päivittämistä ajankohtaiseksi mikäli tarpeen
         lPaikka = lPaikka - 10
         bNyt = true
      EndIf
      
      sTilap = Mid(sMj,lPaikka,10)        'Mahdollinen päivämäärä jonossa
      If(IsDate(sTilap)) then
         tTemp = Datevalue(sTilap)
      else
         sISOKorvausehdotus = sMj
         Exit Function
      EndIf
      
      sPVMosat = Split(sTilap, "-")
      If UBound(sPVMosat)=2 then
         IF (Len(sPVMosat(0))=4 AND Len(sPVMosat(1))=2 AND Len(sPVMosat(2))=2) then
            bOnJoISO = true
          EndIf
      EndIf
      
      If tTemp > 1000 AND NOT bOnJoISO then
         REM muutetaan ei-ISO-päiväys ISO-muotoon miltei riippumatta arvosta
         Mid sMj, lPaikka, 10, Format(tTemp, "YYYY-MM-DD")
      EndIf
      If tTemp < Datevalue(Now()) AND bNyt then
         REM ehdot ovat täyttyneet, päivitetään ISO-päiväys
         Mid sMj, lPaikka, 10, Format(Now(), "YYYY-MM-DD")
      EndIf
      
   EndIf
   Ulos:
   sISOKorvausehdotus = sMj            'Palautetaan joko muutettu arvo tai muuttamaton
End Function  'sISOKorvausehdotus

REM by A. Pitonyak
Function IsSpreadsheetDoc(oDoc) As Boolean
  Dim s$ : s$ = "com.sun.star.sheet.SpreadsheetDocument"
  On Local Error GoTo NODOCUMENTTYPE
  IsSpreadsheetDoc = oDoc.SupportsService(s$)
  NODOCUMENTTYPE:
  If Err <> 0 Then
     IsSpreadsheetDoc = False
    Resume GOON
    GOON:
  End If
End Function



Function MuuttuikoTekstit (oYATunnus as Object)
REM rutiini toimii välivaiheena, jotta voidaan käsitellä eri osiot
'DIM oTunnus as Object         'Tilapäinen olio
DIM bMuutos as Boolean         'Muutoslippu

   'oTunnus = oYATunnus
   REM lippu bMuutos saa arvon true jos yksikin muutos on tehty
   IF MuutettiinkoTeksti(oYATunnus.LeftText) then bMuutos = true
   IF MuutettiinkoTeksti(oYATunnus.CenterText) then bMuutos = true
   IF MuutettiinkoTeksti(oYATunnus.RightText) then bMuutos = true
      
   MuuttuikoTekstit = bMuutos         'Palautetaan muutostieto
 
End Function 'MuuttuikoTekstit

Function MuutettiinkoTeksti(oText as Object)
REM jos funtiossa muutetaan 1. argumentin arvoa, palautetaan true 
DIM s as String

  REM käydään tutkimassa, saadaanko alkuperäisestä eroavaa korvausehdotusta
  s = sISOKorvausehdotus(oText.getString())
 
     REM jos merkkijonot eroavat
   IF s<>oText.string then
      REM tehdään muutos
         oText.setString(s)
      MuutettiinkoTeksti = true
   else
      MuutettiinkoTeksti = false      'Ei muutosta, palautetaan false
   EndIf
End Function 'MuutettiinkoTeksti
Back to top
View user's profile Send private message
Display posts from previous:   
Post new topic   Reply to topic    OOoForum.org Forum Index -> OpenOffice.org Code Snippets All times are GMT - 8 Hours
Page 1 of 1

 
Jump to:  
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum


Powered by phpBB © 2001, 2005 phpBB Group