Kirjoittaja: Antti Laaksonen
Kirjoitettu: 18.01.2008 – 18.01.2008
Tagit: koodi näytille, vinkki
Tämä VB6-ohjelma näyttää kalenterin Suomen käytäntöjen mukaisesti. Kalenterissa on esillä kerrallaan yhden vuoden yksi viikko. Kuukaudesta näkyvät päivien numerot ja viikonpäivät sekä viikkojen numerot. Kalenteria ohjataan nuolinäppäimillä: oikea ja vasen siirtyvät kuukauden eteen ja taakse ja ylös ja alas siirtyvät vuoden eteen ja taakse.
Ohjelmaan kuuluu joukko kalenteriin liittyviä apufunktioita, joista voi olla hyötyä muissakin ohjelmissa. VB sisältää valmiiksi hyvät keinot kalenterin käsittelyyn, mutta viikkojen numeroinnissa on yksi virhe. Joskus joulukuun viimeiset päivät kuuluvat VB:n mukaan viikkoon 53, vaikka ne todellisuudessa kuuluvat seuraavan vuoden viikkoon 1. Tämä virhe on korjattu funktiossa ViikonNumero.
Viikonpäivien nimet ja lyhenteet:
1. maanantai (ma)
2. tiistai (ti)
3. keskiviikko (ke)
4. torstai (to)
5. perjantai (pe)
6. lauantai (la)
7. sunnuntai (su)
Kuukausien nimet ja päivien määrät:
1. tammikuu (31)
2. helmikuu (28 tai 29)
3. maaliskuu (31)
4. huhtikuu (30)
5. toukokuu (31)
6. kesäkuu (30)
7. heinäkuu (31)
8. elokuu (31)
9. syyskuu (30)
10. lokakuu (31)
11. marraskuu (30)
12. joulukuu (31)
Helmikuussa on tavallisesti 28 päivää, mutta karkausvuonna siinä on 29 päivää. Karkausvuosia ovat 4:llä jaolliset vuodet, mutta jos vuosi on 100:lla jaollinen, se on karkausvuosi vain, jos se on myös 400:lla jaollinen. Tämän vuoksi esim. vuosi 2000 oli karkausvuosi, mutta vuosi 2100 ei ole karkausvuosi.
Suomessa vuoden ensimmäinen viikko sisältää vuoden ensimmäisen torstain. Tällöin vuodessa on toisinaan 53 viikkoa tutun 52:n sijasta. Viimeksi vuosina 1998 ja 2004 oli 53 viikkoa, seuraavaksi vuosina 2009, 2015 ja 2020 on 53 viikkoa.
Option Explicit
Dim nvuosi As Integer ' näytettävä vuosi
Dim nkuukausi As Integer ' näytettävä kuukausi
' palauttaa kuukauden nimen (esim. 1 = tammikuu)
Function KuukaudenNimi(kuukausi As Integer) As String
Dim nimet() As Variant
nimet = Array("tammi", "helmi", "maalis", "huhti", "touko", "kesä", _
"heinä", "elo", "syys", "loka", "marras", "joulu")
KuukaudenNimi = nimet(kuukausi - 1) & "kuu"
End Function
' palauttaa päivän nimen (esim. 1 = maanantai, lyhyesti ma)
Function PaivanNimi(paiva As Integer, Optional lyhyt As Boolean = False) As String
Dim nimet() As Variant
nimet = Array("maanantai", "tiistai", "keskiviikko", "torstai", _
"perjantai", "lauantai", "sunnuntai")
If lyhyt Then
PaivanNimi = Left(nimet(paiva - 1), 2)
Else
PaivanNimi = nimet(paiva - 1)
End If
End Function
' tutkii, onko vuosi karkausvuosi
Function Karkausvuosi(vuosi As Integer) As Boolean
If vuosi Mod 4 = 0 Then
If vuosi Mod 100 = 0 And vuosi Mod 400 <> 0 Then
Karkausvuosi = False
Else
Karkausvuosi = True
End If
Else
Karkausvuosi = False
End If
End Function
' palauttaa kuukauden päivien määrän
Function KuukaudenPaivat(vuosi As Integer, kuukausi As Integer) As Integer
Select Case kuukausi
Case 1, 3, 5, 7, 8, 10, 12
KuukaudenPaivat = 31
Case 4, 6, 9, 11
KuukaudenPaivat = 30
Case 2
If Karkausvuosi(vuosi) Then
KuukaudenPaivat = 29
Else
KuukaudenPaivat = 28
End If
End Select
End Function
' palauttaa viikon, johon annettu päivä kuuluu
Function ViikonNumero(vuosi As Integer, kuukausi As Integer, paiva As Integer) As Integer
ViikonNumero = DatePart("ww", DateSerial(vuosi, kuukausi, paiva), vbMonday, vbFirstFourDays)
' VB:n virheen korjaus
If ViikonNumero = 53 Then
If ViikonNumero(vuosi + 1, 1, 1) = 1 Then ViikonNumero = 1
End If
End Function
' palauttaa annetun päivän viikonpäivän
Function Viikonpaiva(vuosi As Integer, kuukausi As Integer, paiva As Integer) As Integer
Viikonpaiva = Weekday(DateSerial(vuosi, kuukausi, paiva), vbMonday)
End Function
Sub PiirraKalenteri(vuosi As Integer, kuukausi As Integer)
Cls
FontName = "Arial"
Dim i As Integer
' kuukausi ja vuosi
Print
FontBold = True
Print KuukaudenNimi(kuukausi) & " " & vuosi
FontBold = False
' otsikkorivi
Print
FontUnderline = True
FontItalic = True
Print "vko" & vbTab;
FontItalic = False
For i = 1 To 7
Print PaivanNimi(i, True) & vbTab;
Next
FontUnderline = False
Print
Dim paiva As Integer
paiva = 1
' ensimmäisen viikon numero
FontItalic = True
Print ViikonNumero(vuosi, kuukausi, 1) & vbTab;
FontItalic = False
' ensimmäisen viikon tyhjät päivät
For i = 2 To Viikonpaiva(vuosi, kuukausi, 1)
Print vbTab;
paiva = paiva + 1
Next
' kuukauden päivien tulostus
For i = 1 To KuukaudenPaivat(vuosi, kuukausi)
Print i & vbTab;
paiva = paiva + 1
' uudelle viikolle siirtyminen
If paiva = 8 Then
Print
paiva = 1
' uuden viikon viikon numero
If i < KuukaudenPaivat(vuosi, kuukausi) Then
FontItalic = True
Print ViikonNumero(vuosi, kuukausi, i + 1) & vbTab;
FontItalic = False
End If
End If
Next
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyLeft ' edellinen kuukausi
nkuukausi = nkuukausi - 1
If nkuukausi = 0 Then
nvuosi = nvuosi - 1
nkuukausi = 12
End If
PiirraKalenteri nvuosi, nkuukausi
Case vbKeyRight ' seuraava kuukausi
nkuukausi = nkuukausi + 1
If nkuukausi = 13 Then
nvuosi = nvuosi + 1
nkuukausi = 1
End If
PiirraKalenteri nvuosi, nkuukausi
Case vbKeyDown ' edellinen vuosi
nvuosi = nvuosi - 1
PiirraKalenteri nvuosi, nkuukausi
Case vbKeyUp ' seuraava vuosi
nvuosi = nvuosi + 1
PiirraKalenteri nvuosi, nkuukausi
End Select
End Sub
Private Sub Form_Load()
AutoRedraw = True
nvuosi = Year(Now)
nkuukausi = Month(Now)
PiirraKalenteri nvuosi, nkuukausi
End SubKoska mielestäni on turhaa laskea karkausvuosia "käsipelillä", niin tässä on vaihtoehtoinen toteutustapa.
Option Explicit
Public Enum TypeOfDay
[Long Day]
[Short Day]
End Enum
Public Enum TypeOfMonth
[Long Month]
[Short Month]
[Shortest Month]
End Enum
Private m_Date As Date
Public Function FinnishDay(ByVal MonthDate As Date, Optional ByVal DayType As TypeOfDay) As String
Dim strDay As String
' valitse ensin oikea päivä
Select Case WeekDay(MonthDate, vbMonday)
Case 1
strDay = "maanantai"
Case 2
strDay = "tiistai"
Case 3
strDay = "keskiviikko"
Case 4
strDay = "torstai"
Case 5
strDay = "perjantai"
Case 6
strDay = "lauantai"
Case 7
strDay = "sunnuntai"
End Select
' sen jälkeen palauta lopputulos halutussa muodossa
If DayType = [Long Day] Then
FinnishDay = strDay
Else
FinnishDay = Left$(strDay, 2)
End If
End Function
Public Function FinnishMonth(ByVal MonthDate As Date, Optional ByVal MonthType As TypeOfMonth) As String
Dim strMonth As String
' valitse ensin oikea kuukausi
Select Case Month(MonthDate)
Case 1
strMonth = "tammi"
Case 2
strMonth = "helmi"
Case 3
strMonth = "maalis"
Case 4
strMonth = "huhti"
Case 5
strMonth = "touko"
Case 6
strMonth = "kesä"
Case 7
strMonth = "heinä"
Case 8
strMonth = "elo"
Case 9
strMonth = "syys"
Case 10
strMonth = "loka"
Case 11
strMonth = "marras"
Case 12
strMonth = "joulu"
End Select
' sen jälkeen palauta lopputulos halutussa muodossa
If MonthType = [Long Month] Then
FinnishMonth = strMonth & "kuu"
ElseIf MonthType = [Shortest Month] Then
FinnishMonth = Left$(strMonth, 3)
Else
FinnishMonth = strMonth
End If
End Function
Public Function FinnishWeekDay(ByVal WeekDay As VbDayOfWeek, Optional ByVal DayType As TypeOfDay) As String
Dim strDay As String
' valitse ensin oikea päivä
Select Case WeekDay
Case vbMonday, vbUseSystemDayOfWeek
strDay = "maanantai"
Case vbTuesday
strDay = "tiistai"
Case vbWednesday
strDay = "keskiviikko"
Case vbThursday
strDay = "torstai"
Case vbFriday
strDay = "perjantai"
Case vbSaturday
strDay = "lauantai"
Case vbSunday
strDay = "sunnuntai"
End Select
' sen jälkeen palauta lopputulos halutussa muodossa
If DayType = [Long Day] Then
FinnishWeekDay = strDay
Else
FinnishWeekDay = Left$(strDay, 2)
End If
End Function
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyLeft Then
m_Date = DateAdd("m", -1, m_Date)
Me.Refresh
ElseIf KeyCode = vbKeyRight Then
m_Date = DateAdd("m", 1, m_Date)
Me.Refresh
ElseIf KeyCode = vbKeyUp Then
m_Date = DateAdd("yyyy", -1, m_Date)
Me.Refresh
ElseIf KeyCode = vbKeyDown Then
m_Date = DateAdd("yyyy", 1, m_Date)
Me.Refresh
End If
End Sub
Private Sub Form_Load()
m_Date = Now
Me.FontName = "Courier New"
If ScaleWidth < Me.TextWidth(String$(8, vbTab)) + 120 Then
Me.Width = Me.Width - Me.ScaleWidth + Me.TextWidth(String$(8, vbTab)) + 120
End If
End Sub
Private Sub Form_Paint()
Dim dtmA As Date, lngA As Long, strText As String
Cls
' kuukausi ja vuosi keskitettynä
strText = vbTab & vbTab & FinnishMonth(m_Date) & Str$(Year(m_Date))
Me.FontBold = True
Me.FontSize = Me.FontSize * 1.5
Me.CurrentX = 60
Me.CurrentY = 60
Print strText
Me.FontSize = Me.FontSize / 1.5
Me.FontBold = False
' viikonpäivien lyhyet nimet
strText = "vko" & vbTab & _
FinnishWeekDay(vbMonday, [Short Day]) & vbTab & _
FinnishWeekDay(vbTuesday, [Short Day]) & vbTab & _
FinnishWeekDay(vbWednesday, [Short Day]) & vbTab & _
FinnishWeekDay(vbThursday, [Short Day]) & vbTab & _
FinnishWeekDay(vbFriday, [Short Day]) & vbTab & _
FinnishWeekDay(vbSaturday, [Short Day]) & vbTab & _
FinnishWeekDay(vbSunday, [Short Day])
Me.CurrentX = 60
Me.CurrentY = Me.CurrentY + 60
Me.FontUnderline = True
Print strText
Me.FontUnderline = False
' viikon numero sekä päivien numerot:
' 1) laske tämän kuukauden ensimmäisen viikon numero
dtmA = DateSerial(Year(m_Date), Month(m_Date), 1)
lngA = ((DatePart("ww", dtmA, vbMonday)) Mod 52)
' 2) laske kyseisen viikon maanantaipäivä, olkoonkin se sitten vaikka edellisen kuun puolella!
dtmA = dtmA - WeekDay(dtmA, vbMonday) + 1
Do
' viikkonumero rivin alkuun
strText = lngA
' seuraavat seitsemän päivää
For dtmA = dtmA To dtmA + 6
' vertaillaan kuukautta: piirretään päivän numero vain jos kuukausi on sama
If Month(dtmA) = Month(m_Date) Then
strText = strText & vbTab & Day(dtmA)
Else
strText = strText & vbTab
End If
Next dtmA
' tulostetaan rivi
Me.CurrentX = 60
Print strText
' seuraava viikkonumero
lngA = (lngA Mod 52) + 1
Loop Until Month(DateAdd("m", -1, dtmA)) = Month(m_Date)
End Sub
Private Sub Form_Resize()
Me.Refresh
End SubKuten koodista voi päätellä, se luottaa täysin Date-muuttujaan ja siten VB:n natiiveihin päivämäärälaskelmiin.
Olen myös eri mieltä viikkonumeron bugista: teknisesti katsoen kyseessä on 53. viikko kuluvasta vuodesta. Jos funktio palauttaisi numeron 1, niin sitten tietyt kyseiselle viikolle viittaavat laskut menisivät poskelleen.
Miten selität sitten tämän?
MsgBox DatePart("ww", DateSerial(2007, 12, 31), vbMonday, vbFirstFourDays)
' tulos: 53
MsgBox DatePart("ww", DateSerial(2003, 12, 31), vbMonday, vbFirstFourDays)
' tulos: 1Vuonna 2007 31.12. oli maanantai ja VB:n mukaan se kuului viikkoon 53. Vuonna 2003 31.12. oli keskiviikko ja VB:n mukaan se kuului viikkoon 1.
Ongelma on näköjään tunnustettu täälläkin: http://support.microsoft.com/kb/200299