ristoi
General User
Joined: 25 Aug 2009
Posts: 24
Location: Järvenpää
|
 Posted: Tue Jul 13, 2010 12:31 pm Post subject: Macro for ISO formated dates for header in Calc |
 |
|
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
|
|
|
