Detta är en nöt att knäcka för den kunnige - tänk på att det inte är VB utan äldre sort...

Mitt exempel ger mig Vecka 53 när jag anger 2002-12-30, men det skall vara vecka 1, finner ni felet?

<code>

'--- Functions
DEFINT A-Z
DECLARE SUB DayNrInYearY2k (indate$, ReturnDay$, Week$, WeekDay$, Month$)
DECLARE FUNCTION GetReturnPeriod$ (indate$, magtype%)

indate$ = "20031230"
per$ = 3
MagAddIntervall = VAL(per$)

PRINT
PRINT "F”rs„ljningsdag „r :"; indate$
PRINT "Returperiod f”r denna utg†va „r :" + GetReturnPeriod(indate$, MagAddIntervall)

SUB DayNrInYearY2k (indate$, ReturnDay$, Week$, WeekDay$, Month$)
'===================================================================
'1995-08-09 (PelleSoft(tm), All rights Reserved Inc. 1983-95(R)
'===================================================================
'Skickar in : {MMDD}
'Returnerar : ReturnDay$ Dagnummret p† †ret
' Week$ Veckonumret
' WeekDay$ Veckodagsnamnet
' Month$ M†nadsnamnet
'===================================================================

DIM Var(12)
Var(1) = 31: Var(2) = 28: Var(3) = 31: Var(4) = 30: Var(5) = 31: Var(6) = 30
Var(7) = 31: Var(8) = 31: Var(9) = 30: Var(10) = 31: Var(11) = 30: Var(12) = 31

IF LEN(indate$) > 6 THEN
year% = VAL(LEFT$(indate$, 4)) - 1 'Om 19xxxxxx
IF year% < 1910 THEN year% = 2000 + VAL(LEFT$(indate$, 2)) 'Om 2000 talet
Month% = VAL(MID$(indate$, 5, 2))
ELSE
year% = VAL(LEFT$(indate$, 2)) + 1900 - 1 'Om 9xxxxx
IF year% < 1910 THEN year% = 2000 + VAL(LEFT$(indate$, 2)) 'Om 2000 talet
Month% = VAL(MID$(indate$, 3, 2))
END IF

day% = VAL(RIGHT$(indate$, 2)) 'Tar ut dagen
IF (year% + 1) MOD 4 = 0 THEN Var(2) = 29 'Om skott†r

FOR a = 1 TO Month% 'Addera dagar i †ret
X = X + Var(a) 'till X
NEXT

X = X - (Var(Month%) - day%): ReturnDay% = X 'Ber„knar dagnr p† †ret
' Formel: [PRINT (31 + 28 + 31 + 30 + 31 + 30 + 31 + 31) - (31 - 4)]
'--- Kalkylerar veckodagen
XYear = year% + 1: XMon = Month%: IF Month% <= 2 THEN XMon = XMon + 12: XYear = XYear - 1 'Om jan eller Feb, ”vr m†nader ingen „ndring
DayOfWeek% = (day + XMon + XMon + INT((XMon + 1) * .6) + XYear + XYear \ 4 - XYear \ 100 + XYear \ 400 + 1) MOD 7: DayOfWeek% = DayOfWeek% + 1
WeekDay$ = MID$("S”ndag M†ndag Tisdag Onsdag TorsdagFredag L”rdag", (DayOfWeek%) * 7 - 6, 7)

'--- Kalkylerar m†naden
Month$ = MID$("Januari Februari Mars April Maj Juni Juli Augusti September Oktober November December", Month% * 10 - 9, 9)

'--- Kalkylerar veckan
'Kolla vilken dag som „r f”rsta dagen p† †ret f”r att f”rutse n„r dag 1
'i veckan egentligen b”rjar!

'--- Kalkylerar veckodagen f”r dag 1, m†nad 1, f”reg†ende †r
XYear = year + 1: XMon = 1: XDay = 1: IF XMon <= 2 THEN XMon = XMon + 12: XYear = XYear - 1'Om jan eller Feb, ”vr m†nader ingen „ndring
Result = (XDay + XMon + XMon + INT((XMon + 1) * .6) + XYear + XYear \ 4 - XYear \ 100 + XYear \ 400 + 1) MOD 7: Result = Result + 1

'S”n=1,M†n=2,Tis=3,Ons=4,Tor=5,Fre=6,L”r=7
IF Result = 1 THEN DaysInFirstWeek = 5 ' û Ok
IF Result = 2 THEN DaysInFirstWeek = 6 ' û Ok
IF Result = 3 THEN DaysInFirstWeek = 7 ' û Ok
IF Result = 4 THEN DaysInFirstWeek = 8 ' û Ok
IF Result = 5 THEN DaysInFirstWeek = 9 ' ' ok
IF Result = 6 THEN DaysInFirstWeek = 3 ' û Ok
IF Result = 7 THEN DaysInFirstWeek = 4 ' û Ok

'Om det „r 4 dagar eller mer i vecka1 blir det vecka 1
'annars blir det vecka 52 eller 53 i f”reg†ende †r beroende
'p† om Skott†r inf”ll f”reg†ende †r.

Week% = INT((ReturnDay% + DaysInFirstWeek) / 7)

IF Week% = 53 THEN
IF ((year% + 1) MOD 4) = 0 AND DaysInFirstWeek >= 4 THEN '
Week% = 1
ELSEIF ((year% + 1) MOD 4) <> 0 AND DaysInFirstWeek < 4 THEN '
Week% = 1
ELSEIF Week% = 53 AND (year% MOD 4) = 0 THEN '™vrigt om vecka 53 och f”rra †ret „r skott†r
Week% = 1
END IF
END IF

IF Week% = 0 THEN
IF (year% MOD 4) = 0 THEN 'Om †ret f”re „r skott†r
Week% = 53
ELSEIF Week% = 0 THEN '™vrigt- vecka 52
' hur m†nga dagar i veckan?
IF DaysInFirstWeek < 4 THEN
Week% = 53
ELSE
Week% = 52
END IF
END IF
END IF

'--- Formatterar week s† det blir '01' och inte '1 '
Week$ = RIGHT$("00" + LTRIM$(STR$(Week%)), 2)

'--- Formatterar dagnummret s† det blir '031' och inte '31 '
ReturnDay$ = RIGHT$("000" + LTRIM$(STR$(ReturnDay%)), 3)

indate$ = LTRIM$(STR$(year + 1)) + "-" + RIGHT$("00" + LTRIM$(STR$(Month%)), 2) + "-" + RIGHT$("00" + LTRIM$(STR$(day%)), 2)

END SUB

FUNCTION GetReturnPeriod$ (indate$, magtype)

DayNrInYearY2k indate$, ReturnDay$, Week$, WeekDay$, Month$

debug = 1

IF debug = 1 THEN
PRINT "Datum : "; indate$
PRINT "DagNr : "; ReturnDay$
PRINT "Vecka : "; Week$
PRINT "Dagnamn : "; WeekDay$
PRINT "M†nad : "; Month$
END IF

currweek = VAL(Week$) + magtype

'avrundar till j„mn h”gre vecka
IF currweek MOD 2 <> 0 THEN currweek = currweek + 1

' > †rets veckor
IF VAL(ReturnDay$) > 364 AND currweek < 50 THEN
diffweek = currweek
theYear = VAL(LEFT$(indate$, 4))
theYear = theYear + 1
theYear$ = RIGHT$("0000" + LTRIM$(STR$(theYear)), 4)
returnperiod$ = theYear$ + RIGHT$("00" + LTRIM$(STR$(diffweek)), 2)
ELSEIF currweek > 52 THEN
diffweek = currweek - 52
theYear = VAL(LEFT$(indate$, 4))
theYear = theYear + 1
theYear$ = RIGHT$("0000" + LTRIM$(STR$(theYear)), 4)
returnperiod$ = theYear$ + RIGHT$("00" + LTRIM$(STR$(diffweek)), 2)
ELSE
'
returnperiod$ = LEFT$(indate$, 4) + RIGHT$("00" + LTRIM$(STR$(currweek)), 2)
END IF

IF debug = 1 THEN
PRINT ""
PRINT "Ny vecka : "; currweek
PRINT "Period : "; returnperiod$
END IF

GetReturnPeriod$ = returnperiod$

END FUNCTION
</code>

Det finns ju bara 52 hela veckor sedan kallar man klämdagarna för vecka 53. Sedan börjar vecka 1 den första januari.

Slopa segmentet
IF Week% = 53 THEN
IF ((year% + 1) MOD 4) = 0 AND DaysInFirstWeek >= 4 THEN '
Week% = 1
ELSEIF ((year% + 1) MOD 4) <> 0 AND DaysInFirstWeek < 4 THEN '
Week% = 1
ELSEIF Week% = 53 AND (year% MOD 4) = 0 THEN '™vrigt om vecka 53 och f”rra †ret „r skott†r
Week% = 1
END IF
END IF

och skriv istället
IF Week%=53 then Week%=1

Så blir allt som heter vecka 53 vecka 1 istället.

/Elias

Men vissa år finns det ju vecka 53???

/Johan

Ja det finns det, exempelvis den 29 december 1998 är vecka 53. Det är först måndagen den 4/1-1999 som är vecka 1.

Jag tror inte det är bara att fixa utan här krävs lite tänka - vad skiljer från år 2001 som inte har skett sedan 1950 - för programmet fungerar perfekt fram till 2001 - där börjar strulet..

Nästa gång är 27/12 2004, då är det åxå 53 veckor. Därefter den 28/12 2009.

/Pelle

Usch, där gjorde jag bort mig rejält...

Prova detta (skall fungera i MS Basic 7.0 och liknande...)


'*********************************************************
Function FactorFrom1JanTheYear(Year As Long) As Long
'Returnerar faktorn för 1/1-Year
Dim firstDayThisYear%, datum As Long, intYear%

intYear = CInt(Year)

datum = Factor(Year, 1, 1)

'Kontrolera vilken veckodag som är första dagen på året...
firstDayThisYear = dayOfWeek(intYear, 1, 1)

'Är vecka 52 eller 53. Lägger till 7 dagar för gå till vecka 1.
If firstDayThisYear > 4 Then datum = datum + 7

'Flyttar datumet till Måndagen...
datum = datum - firstDayThisYear + 1

FactorFrom1JanTheYear = datum

End Function

Function GetWeekNr(inDate As String) As Long
Dim Year%, month%, dat%, temp$, lngFirstJan&, lngChosenDateValue&
Dim y&, m&, D&, startYear&

If CrackDate(inDate, Year, month, dat, 0, temp) = False Then
MsgBox "Ingen giltigt lngFirstJan är inmatat !", vbInformation, "Fel lngFirstJanformat !"
GoTo Exit_GetWeekNr:
End If

y = CLng(Year)
m = CLng(month)
D = CLng(dat)

startYear = y

lngChosenDateValue = Factor(y, m, D)

Do
'Sätter 'lngFirstJan' till Måndag,Vecka 1 år 'startYear' numeriskt.
lngFirstJan = FactorFrom1JanTheYear(startYear)

If lngChosenDateValue > lngFirstJan Then Exit Do

'Måste backa ett år...
startYear = startYear - 1
Loop

GetWeekNr = Int((lngChosenDateValue - lngFirstJan) / 7) + 1

'Här löser man problemet med bland annat att 2002-12-30 blir vecka 53 etc
If lngChosenDateValue >= FactorFrom1JanTheYear(startYear + 1) Then GetWeekNr = 1

Exit_GetWeekNr:

End Function
Function CrackDate(inDate As String, Year%, month%, dat%, format%, RetDatum$) As Boolean
'Denna funktion returenerar False om Variablen 'Datum' inte är ett formaterabart datum

'Denna funktion returnerar följande variablar som tal:
' Year,Mon,dat
' Format: 1 = Longdate 2 = Shortdate

Dim i%, tkn$, newDate$, p%, AntalTkn%

CrackDate = False

If Len(inDate) < 1 Then GoTo Exit_CrackDate:
AntalTkn = 0

'Tar bort eventuella separatorer i datumet..
For i = 1 To Len(inDate)
tkn = Mid$(inDate, i, 1)
If Not (Val(tkn) = 0 And tkn <> "0") Then 'Separator...
newDate = newDate & tkn
AntalTkn = AntalTkn + 1
Else
'Har hittat en sparator...
'För att klara otrevliga format så som 98/1/30...
If AntalTkn = 1 Then
'Infogar '0' framför månad/datum (blir 980130, där '0' frmför '1' här blir infogad)
newDate = left$(newDate, Len(newDate) - 1) & "0" & right$(newDate, 1)
End If
AntalTkn = 0
End If
Next

If Len(newDate) = 8 Then ' t.ex = 19980219
Year% = Val(left$(newDate, 4)) 'Om 19xxxxxx
p = 2
ElseIf Len(newDate) = 6 Then 't.ex = 980219
'OBS ! Denna funktion fungerar enbart mellan 1930 och 2029 om
' årtalet enbart matas in med 2 siffror
Year = Val(left$(newDate, 2)) 'Om 9xxxxx
p = 0
If Year < 30 Then
'Förutsätter att det är på 2000-talet
Year = 2000 + Year
Else
Year = 1900 + Year
End If
Else
'Datumet har inte korrekt format...
GoTo Exit_CrackDate:
End If

month% = Val(Mid$(newDate, 3 + p, 2))
dat = Val(Mid$(newDate, 5 + p, 2))

Select Case format
Case 1 'Datum utan datum avgränsare
RetDatum = Year & right$("0" & month, 2) & right$("0" & dat, 2)
Case 2 'Långt datum
RetDatum = "den " & Trim$(dat) & " " & GetMonth(month) & " " & Year
Case Else ' Normalt kort datum...
RetDatum = Year & "-" & right$("0" & month, 2) & "-" & right$("0" & dat, 2)
End Select

CrackDate = True
Exit_CrackDate:

End Function
Function dayOfWeek(Year%, month%, dat%) As Integer
'Returnerar veckodagen som ett tal mellan 1 till 7
'(Svenska stuket)

Dim y&, m&, day&
y = CLng(Year)
m = CLng(month)
day = CLng(dat)

dayOfWeek = ((Factor(y, m, day)) + 6) Mod 7

If dayOfWeek = 0 Then dayOfWeek = 7

End Function
Function daysInMonth(mon%, Year%) As Integer
'Returnerar antal dagar i månaden...
Select Case mon
Case 2
daysInMonth = 28
If (((Year Mod 4) = 0) And ((Year Mod 100) <> 0)) Or ((Year Mod 400) = 0) Then daysInMonth = 29
Case 4, 6, 9, 11
daysInMonth = 30
Case Else
daysInMonth = 31
End Select
End Function
'Räknar ut antal dagar...
Function Factor(Year&, month&, dat&) As Long
Dim y&, m&, day&

y = Year
m = month
day = dat

If m < 3 Then
y = y - 1
m = m + 12
End If

Factor = Int(365 * y) + Int(y / 4) - Int((Int(y / 100 + 1) * 3) / 4) + Int((m * 3060 - 9135) / 100) + day + 59

End Function

'Räknar ut antalet dagar i månaden. Returnear 0 om det inte är OK
Function date_ok(Year&, month&, dat&) As Long
Dim tmpy As Long, tmpm As Long, tmpd%, F1 As Long, day As Long

date_ok = 0

If Year < 1710 Then GoTo Exit_date_ok:
If month < 1 Or month > 12 Then GoTo Exit_date_ok:
If dat < 1 Or dat > 31 Then GoTo Exit_date_ok:

tmpy = Year
tmpm = month
day = dat
tmpd = 1

F1 = Factor(Year, month, 1)
F1 = Factor(Year, (month + 1), 1) - F1

If F1 < day Then GoTo Exit_date_ok:

date_ok = F1 ' om ok returerar antal dagar i månaden

Exit_date_ok:

End Function

Function addToDate(Year%, month%, dat%, days&, ResultDate$) As Long
Dim y&, m&, D&, F1&, tm&, maxDays&, td&

y = CLng(Year)
m = CLng(month)
D = CLng(dat)

Debug.Print "Y=" & y & " M=" & m & " D= " & D & " Days=" & days

F1 = Factor(y, m, D) + days
y = Int(F1 / 365.2425) 'möjligt precisions fel !
m = 1
D = 1
tm = 0

Do While tm <= 12
'm = tm++;
tm = tm + 1
m = tm
maxDays = date_ok(y, m, D)
td = F1 - Factor(y, m, D) + 1
If td <= maxDays Then
D = td
Exit Do
End If
Loop

ResultDate = y & "-" & m & "-" & D

End Function


MVH

Peter S

Hej igen !
Jag tror att dit program räknar fel på skottåren. Vilket skall vara:

If (((Year Mod 4) = 0) And ((Year Mod 100) <> 0)) Or ((Year Mod 400) = 0) Then Skottår = true

Upptäcket att jag hade några 'msgbox'ar som måste rem'as för dos...

MVH

Peter S