CB Repository

//Määritetään Date()-funktion palauttaman kuukauden nimilyhenteet taulukkoon
    Dim MonthName(12) As String
    MonthName(01) = "Jan"
    MonthName(02) = "Feb"
    MonthName(03) = "Mar"
    MonthName(04) = "Apr"
    MonthName(05) = "May"
    MonthName(06) = "Jun"
    MonthName(07) = "Jul"
    MonthName(08) = "Aug"
    MonthName(09) = "Sep"
    MonthName(10) = "Oct"
    MonthName(11) = "Nov"
    MonthName(12) = "Dec"
	
	
    
//Esimerkkiohjelma
    SCREEN 440,100
    Repeat
        v = Right(Date(),4)
        k = MonthNumber(Mid(Date(),4,3))
        p = Left(Date(),2)
        pvm$ = p+"."+k+"."+v
		
        Text 0,00, "Päivämäärä: "+pvm
        Text 0,15, "Päiviä 1.1." + v + " - " + pvm + ": " + CountDays(1,1,v, p,k,v)
        Text 0,30, "Päiviä " + pvm + " - " + "31.12." + v + ": " + CountDays(31,12,v, p,k,v)
        Text 0,45, "Päiviä kesäkuun alkuun: " + CountDays(1,6,v + (k >= 6), p,k,v)
        If IsIntercalaryYear(v) Then
            Text 0,60, "Nyt o"+"n karkausvuosi."
        Else
            Text 0,60, "Nyt ei ole karkausvuosi."
        End If
        Text 0,75, "Päiviä tässä kuussa: "+DaysInMonth(k,v)
        DrawScreen
    Forever

Function CountDays(d1,m1,y1, d2=0,m2=0,y2=0)
    'Oletusarvot toiselle päivämäärälle
    If d2=0 Then d2 = Left(Date(),2)
    If m2=0 Then m2 = MonthNumber(Mid(Date(),4,3))
    If y2=0 Then y2 = Right(Date(),4)
    
    'Tarkistetaan että päivämäärät ovat edes lähestulkoon oikein (päivien määrähän vaihtelee
    'kuukaudessa, eikä tätä huomioida VIELÄ tässä).
    If d1<1 Or d1>31 Or d2<1 Or d2>31 Then Return False
    If m1<1 Or m1>12 Or m2<1 Or m2>12 Then Return False
    'Vuodet jätetään tarkistamatta koska vuosi voi kasvaa miten suureksi vain ja negatiivinen
    'arvo tarkoittaa aikaa ennen ajanlaskun alkua.
    
    'Yksinkertaisin tapaus: kuukausi tai vuosi ei vaihdu päivämäärien välillä
    If m1=m2 And y1=y2 Then Return Abs(d1-d2)
    
    'Jos kuukaudet eivät ole samat tai vuodet eivät ole samat, lasketaan pitemmällä kaavalla.
    
    'Tarkistetaan, että päivämäärä d1.m1.y1 on "pienempi" kuin d2.m2.y2.
    'Jos ei ole, käännetään päivämäärät keskenään, jotta homma menisi varmasti oikein.
    If y1>y2 Or ((m1>m2 Or (d1>d2 And m1=m2)) And y1=y2) Then
        d3 = d1 : m3 = m1 : y3 = y1
        d1 = d2 : m1 = m2 : y1 = y2
        d2 = d3 : m2 = m3 : y2 = y3
    End If
    
    'Käydään läpi vuodet ja kuukaudet
    m = m1
    For y = y1 To y2
        Repeat
            'Lisätään laskuriin kukaudessa olevien päivien määrä,
            'ellei olla jo siinä kuussa, johon laskeminen tulee
            'päättää
            If m=m2 And y=y2 Then
                Return days + d2
            ElseIf m=m1 then
				days = days + DaysInMonth(m,y)-d1
			else
                days = days + DaysInMonth(m,y)
            End If
            m + 1
        Until m = 13
        m = 1
    Next y
    
End Function

Function MonthNumber(month$)
    If Len(month) <> 3 Then Return False
    For i = 1 To 12
        If Lower(month) = Lower(MonthName(i)) Then Return i
    Next i
End Function

Function DaysInMonth(m,y=-999999)

    'Tarkistetaan kuukauden oikeellisuus
    If m < 1 Or m > 12 Then Return False
    
    If m = 2 Then
        'Tarkistetaan karkausvuosi, jos vuosi on annettu
        If y<>-999999 And IsIntercalaryYear(y) Then
            Return 29
        Else
            Return 28
        End If
    End If
    
    'Kuukausi ei ole helmikuu, joten lasketaan päivien määrä normaalilla kaavalla.
    If m <= 7 Then
        Return (m Mod 2 = 0)*30 + (m Mod 2 <> 0)*31
    Else
        Return (m Mod 2 = 0)*31 + (m Mod 2 <> 0)*30
    End If
    
End Function

Function IsIntercalaryYear(y)
    Return (y Mod 4 = 0) And ((y Mod 100 <> 0) Or (y Mod 400 = 0))
End Function