yak yak yak yak
Her et gammelt unit jeg har brugt til kalender... til DOS (pascal .. right
? ).. men kan snildt laves om til Delphi.
Dato beregning er 100% korrekt. Der mangler et unit... men det er kun
tekstjusteringer osv.. det har du sikkert selv...
Have fun
{--SNIP--}
Unit Calendar;
Interface
Procedure Showcalendar;
Implementation
uses basicop2,dos;
Const
Month : array [0..11] of String[10] =
('January','February','March',
'April','May','June','July',
'August','September','October',
'November','December');
ShortDayNames : array [0..6] of string[6] =
('Sun','Mon','Tues','Wednes','Thurs',
'Fri','Satur');
Specdates : array[0..12] of string[10]=('',
'NewyearsDay','NewyearsEve','13. Dag','1. Maj','Xmas Eve','XmasDay','2
XmasDay',
'Langfredag','2. P?skedag','Kr. Him.','2 Pinsedag','Foolsday');
BackCol = 27;
SelCol = 30;
Shadowcol = 19;
selchocol = 62;
pickcol = 48;
Panelcol = 30;
SelMenuCol = 14;
OneWeek = 7;
type
TimeDate = Record
Year : word;
Month,
Day,
WeekDay,
Hour,
Min,
Sec,
ms :byte;
End;
{ several routines frowm swag, collected by Ingolf }
(* Public domain
Author: Marius Ellen, Winsum, Groningen, The Netherlands
Fido 2:282/607.2
After studying several DayOfWeeks i got sick.
None of them worked really correctly and most
had over 15 DIV'/MOD's or * in it.
The Zeller's congruence was the best but the
routine also contains some range errors. Years
are only valid from 1..6300 and its really slow,
so i wrote my own..
About the routines..
routine results valid if year in 0..65536
month in 1..12, and day in 1..28/29/30/31
there is absolute no range checking..
*)
var
xxp,yyp: integer;
dt : timedate;
seldate : timedate;
CalStartPos : byte;
function DayOfWeek(year,month,day:word):word;
{Returns the day of week, 0=Sun..6=Sat}
assembler; {See 1995}
const mtable:array[0..11] of byte=
(0,3, 3,6, 1,4, 6,2, 5,0, 3,5);
asm
{(Y+(Y div 4)-(Y div 100)+(Y div 400)-Adjust)mod 7}
mov ax,year
mov di,ax
xor bx,bx
xor cx,cx
mov si,day
dec si
shr ax,1; adc cl,0 {si+=year div 4}
shr ax,1; adc cl,0
add si,ax
mov bx,25 {si+=year div 100}
xor dx,dx
div bx
sub si,ax
shr ax,1; adc ch,0 {si+=year div 400}
shr ax,1; adc ch,0
add si,ax
add si,di
{if leap-year then decrease days}
mov bx,month
cmp bx,2; ja @Noleap {do not adjust}
and cl,cl; jne @NoLeap {year mod 4=0?}
and dx,dx; jne @IsLeap {year mod 100=0?}
and di,di; je @NoLeap {year=0?}
and ch,ch; jne @Noleap {year mod 400=0?}
@IsLeap:dec si
@Noleap:xor ah,ah
mov al,byte ptr mTable[bx-1]
add ax,si
mov bx,7
xor dx,dx
div bx
xchg ax,dx
end;
function GetDaysInMonth(Month:Byte;Year:Word):Word;
{Returns the total number of days in a month}
assembler;
asm
mov bl,Month
{What about februari?}
cmp bl,2; jne @N
mov ax,Year
shr ax,1; jc @S
shr ax,1; jc @S
{it's a leap-year}
mov cx,25;{ div cx} { DIV CX clammed out by ingolf,
seems to have no func,
but crashes beyond year 2000 }
and dx,dx; jne @T
{its a century}
and al,3; jne @S
@T: {leap}
mov ax,29; jmp @E
@S: {noleap}
mov ax,28; jmp @E
@N: {Nope, calc moth day's}
mov ax,15
shr bl,1; rcl ax,1
cmp bl,4; jb @E
xor ax,1
@E:
end;
function GetDaysInYear(Year:Word):Word;
{Returns the total number of days in a year}
assembler;
asm
mov ax,2
push ax
push year
call GetDaysInMonth
add ax,(365-28)
end;
Procedure GetTimeDate(Var Time:TimeDate);
Begin
With Time do
Begin
basicop2.GetTime(Hour,Min,Sec,ms);
basicop2.GetDate(Year,Month,Day,WeekDay);
End;
End;
Function DaysInMonth(Month:Byte;Year:Word):Byte;
Begin
Case Month Of
1:DaysInMonth:=31;
2:Begin
If (Year Mod 100)=0 Then {Centuary}
If (Year Mod 400)=0 Then
DaysInMonth:=29
Else
DaysInMonth:=28
Else {Non Centuary}
If (Year Mod 4)=0 Then
DaysInMonth:=29
Else
DaysInMonth:=28;
End;
3:DaysInMonth:=31;
4:DaysInMonth:=30;
5:DaysInMonth:=31;
6:DaysInMonth:=30;
7:DaysInMonth:=31;
8:DaysInMonth:=31;
9:DaysInMonth:=30;
10:DaysInMonth:=31;
11:DaysInMonth:=30;
12:DaysInMonth:=31;
End;
End;
Function DaysInYear(Year:Word):Word;
Begin
If DaysInMonth(2,Year)=29 Then DaysInYear:=366 Else DaysInYear:=365;
End;
Function DayOfYear(Const Date:TimeDate):Word;
Var
Temp :Word;
X :Byte;
Begin
Temp:=Date.Day;
For X:=1 to Date.Month-1 do
Inc(Temp,DaysInMonth(X,Date.Year));
DayOfYear:=Temp;
End;
{----------------------------------------------------------------------}
{-- Calculate Approxmiate Phase of the Moon: --}
{----------------------------------------------------------------------}
{-- Uses formula by P. Harvey in the "Journal of the British --}
{-- Astronomical Association", July 1941. Formula is accurate to --}
{-- within one day (or on some occassions two days). If anyone knows --}
{-- a better formula please let me know! Internet: as544@torfree.net --}
{----------------------------------------------------------------------}
{-- Calculates number of days since the new moon where: --}
{-- 0 = New moon 15 = Full Moon --}
{-- 7 = First Quarter 22 = Last Quarter (right half dark) --}
{----------------------------------------------------------------------}
Function Moon_age(y : word; m : word; d : word) : byte;
var i : integer;
c : word;
begin
c:=(y div 100);
if (m>2) then dec(m,2) else inc(m,10);
i:=((((((y mod 19)*11)+(c div 3)+(c div 4)+8)-c)+m+d) mod 30);
moon_age:=i;
end;
function easternDay(Ye:word): word; {what day Eastern Day is that year}
{ uses Gauss' Eastern formula to calculate Eastern Day }
{ you're not supposed to understand this... :) }
{ it took me quite some while to convert the "formula" from }
{ the look up tables, that I found in my encyclopaedia, into }
{ pure, working assembler, so enjoy... }
var
res : word;
begin
asm
mov ax,Ye
cmp ax,99
jg @noadd
cmp ax,80
jg @not2000
add ax,100
@not2000:
add ax,1900
@noadd:
mov bx,ax
cwd
mov cx,19
div cx
mov ax,dx
mul cx
add ax,24
mov cx,30
div cx
mov si,dx
mov ax,bx
and ax,3
shl ax,1
mov di,ax
mov ax,bx
cwd
mov cx,7
div cx
mov ax,dx
shl ax,2
add di,ax
mov ax,si
shl ax,1
add ax,si
shl ax,1
add ax,5
add ax,di
cwd
div cx
add dx,si
add dx,81
and bx,3
jne @no29
inc dx
@no29:
mov res,dx
end;
easternday:=res;
end;
function DetermineDayType(Dat : TimeDate) : byte;
{returns type of day, see list }
function dayNo(Ye,Mo,Da:word): word; {calculate the daynumber 1..366}
begin
asm
mov bx,Ye
mov cx,Mo
dec cx (* Month = 0..11 *)
mov di,Da
{ if Month>2 then }
cmp cx,1
jle @janfeb
{ S := ((Year mod 4) + 3) div 4 + (4 * Month + 23) div 10 - 1 }
and bx,3
add bx,3
shr bx,2
mov ax,cx
inc ax
shl ax,2
add ax,23
cwd
push cx
mov cx,10
div cx
pop cx
dec ax
add bx,ax
jmp @eif
{ else }
@janfeb:
{ S := 0; }
xor bx,bx
@eif:
{ DayNo:= 31 * (Month - 1) + Day - S; }
mov ax,cx
mov cx,31
mul cx
add ax,di
sub ax,bx
end;
end;
var dn,ed:word;
typ : byte;
begin
dn:=DayOfYear(dat); ed:=easternDay(dat.Year);
with dat do
begin
if ((Day= 1)and(Month= 1)) then typ:=1 else {Ny?rsdagen}
if ((Day= 31)and(Month= 12)) then typ:=2 else {Nyt?rsaften}
if ((Day= 6)and(Month= 1)) then typ:=3 else {Trettondedagen}
if ((Day= 1)and(Month= 5)) then typ:=4 else {1:sta maj }
if ((Day=24)and(Month=12)) then typ:=5 else {Juleaften}
if ((Day=25)and(Month=12)) then typ:=6 else {Juldagen}
if ((Day=26)and(Month=12)) then typ:=7 else {Annandag jul}
if (dn=(ed- 2)) then typ:=8 else {L?ngfredag}
if (dn=(ed+ 1)) then typ:=9 else {Annandag p?sk}
if (dn=(ed+39)) then typ:=10 else {Kristi himmelsf"rdsdag}
if (dn=(ed+50)) then typ:=11 else {Annandag pingst}
if ((day=1)and(month=4)) then typ:=12 else {Aprilsnar}
typ:=0;
end;
DetermineDayType:=typ;
end;
procedure ShowCal(dat : timedate);
var
TEL : BYTE;
dow : byte;
x,
y : byte;
col : byte;
daycor : byte;
moonag : byte;
st : string;
workdays: byte;
tmpdat : timedate;
spcno : byte;
begin
rwrite(xxp+1,yyp+1,center(specdates[Determinedaytype(dat)]+'
'+daynames[dayofweek(dat.year,dat.month,dat.day)]+' '+
nills(dat.day,1)+'. '+month[dat.month-1]+'
'+nills(dat.year,4),maxxpos-9),backcol);
moonag := Moon_age(seldate.year,seldate.month,seldate.day);
case moonag of
0..6 : st:='New moon';
7..14 : st:='First Quater';
15..21 : st:='Full moon';
22..31 : st:='Last Quarter';
else st:='';
end; { case }
x:=0;
y:=0;
workdays:=0;
for tel:=1 to daysinmonth(dat.month,dat.year) do
begin
dow:=Dayofweek(dat.year,dat.month,TEL);
if dow=0 then dow:=7;
if tel=1 then CalStartPos:=Dow;
x:=(dow-1)*10;
{ writeln(x:4,y:4);}
if dow<6 then inc(workdays);
if (dat.day=tel) then col:=pickcol else
if (dow=7) then col:=27 else col:=shadowcol;
rwrite(2+XXP+x,4+YYP+y,center(nills(tel,1),9),col);
tmpdat:=dat;
tmpdat.day:=tel;
spcno:=Determinedaytype(tmpdat);
if spcno>0 then if dat.day=tel then col:=pickcol else col:=backcol;
rwrite(2+XXP+x,5+YYP+y,center(specdates[spcno],9),col);
if dow=7 then inc(y,3);
end;
dow:=Dayofweek(dat.year,1,1);
if dow=0 then dow:=7;
daycor:=8-dow;
if ((daycor+dayofyear(dat)) div OneWeek)=0 then tel:=53 else
tel:=((daycor+dayofyear(dat)) div OneWeek);
rwrite(xxp+1,yyp+22,center('Day #'+rjust(nills(dayofyear(dat),1),3)+' of
'+rjust(nills(daysinyear(dat.year),1),3)+' '+
'Week #'+rjust(nills(tel,1),2)+' '+
ljust(rjust(nills(moonag,1),2)+'. Moonday
('+st+')',27)+
ljust(rjust(nills(workdays,1),2)+'
Workdays',12),maxxpos-9),selcol);
end;
procedure ClearCalendar;
var
tel : byte;
begin
for tel:=1 to 6 do
begin
rwrite(xxp+1,yyp+1+(tel*3),rjust('',maxxpos-8),backcol);
rwrite(xxp+1,yyp+2+(tel*3),rjust('',maxxpos-8),backcol);
end;
end;
procedure initscreen;
var
tel : byte;
begin
frame(xxp,yyp,maxxpos-3,yyp+23,'Calendar',false,DefTxtcol,DefBaCol);
clearcalendar;
for tel:=1 to 7 do if tel<7 then
rwrite(4+xxp+((tel-1)*10),yyp+3,center(shortdaynames[tel],6),selcol) else
rwrite(4+xxp+((tel-1)*10),yyp+3,center(shortdaynames[0],6),selcol);
for tel:=1 to 6 do
begin
rwrite(xxp+2,yyp+3+(tel*3),{'Ì'+}repchar('Ä',(xxp+(maxxpos-10))-xxp){+'¹'},b
ackcol);
END;
end;
procedure CalendarNavigate;
var
popday : byte;
procedure Checkday;
begin
if seldate.day>GetDaysInMonth(seldate.month,seldate.year) then
seldate.day:=GetDaysInMonth(seldate.month,seldate.year);
end;
procedure DecMonth;
begin
if seldate.month>1 then dec(seldate.month,1) else
begin
seldate.month:=12;
dec(seldate.year);
end;
clearcalendar;
end;
procedure incMonth;
begin
if seldate.month<12 then inc(seldate.month,1) else
begin
seldate.month:=1;
inc(seldate.year);
end;
clearcalendar;
end;
procedure DecDay;
begin
if seldate.day>1 then dec(seldate.day) else
begin
DecMonth;
seldate.day:=GetDaysInMonth(seldate.month,seldate.year);
end;
end;
procedure IncDay;
begin
if seldate.day<GetDaysInMonth(seldate.month,seldate.year) then
inc(seldate.day) else
begin
IncMonth;
seldate.day:=1;
end;
end;
procedure PrevWeek;
begin
if seldate.day>OneWeek then dec(seldate.day,OneWeek) else
begin
popday:=seldate.day;
decmonth;
seldate.day:=GetDaysInMonth(seldate.month,seldate.year)-(oneweek-popday);
end;
end;
procedure NextWeek;
begin
if seldate.day<=(GetDaysInMonth(seldate.month,seldate.year)-oneweek)
then inc(seldate.day,OneWeek)
else
begin
popday:=GetDaysInMonth(seldate.month,seldate.year)-seldate.day;
incmonth;
seldate.day:=oneweek-popday;
end;
end;
procedure PrevMonth;
begin
decmonth;
checkday;
end;
procedure NextMonth;
begin
incmonth;
checkday;
end;
procedure PrevYear;
begin
dec(seldate.year);
clearcalendar;
checkday;
end;
procedure NextYear;
begin
inc(seldate.year);
clearcalendar;
checkday;
end;
procedure SetTime2Now;
begin
gettimedate(seldate);
clearcalendar;
end;
procedure GotoDate;
var
vl,cd : integer;
st : string;
ok : boolean;
tel : byte;
nyear,
nmont : word;
begin
ok:=false;
repeat
st:=gettext('Goto year',nills(seldate.year,1),5,false);
if st=_CANCEL then exit;
val(st,vl,cd);
if cd=0 then ok:=true;
until ok;
nyear:=vl;
st:='';
for tel:=0 to 11 do
begin
st:=st+month[tel];
if tel<11 then st:=st+',';
end;
st:=select(0,0,0,0,'Goto year '+nills(nyear,1)+' month
?',st,seldate.month);
if st=_CANCEL then exit;
for tel:=0 to 11 do if st=month[tel] then break;
nmont:=tel+1;
seldate.year:=nyear;
seldate.month:=nmont;
clearcalendar;
end;
var
don : boolean;
ch : char;
fsel : byte;
msel : integer;
begin
don:=false;
repeat
readmouse;
if mousebut>0 then
begin
if mousey=maxypos then
begin
fsel:=mousex div 8;
Waitmousenobut;
case fsel of
0 : DecDay;
1 : IncDay;
2 : PrevMonth;
3 : NextMonth;
4 : PrevYear;
5 : NextYear;
6 : Settime2now;
7 : Gotodate;
9 : don:=true;
end; { case }
end else
if (mousex>xxp) and (mousex<(maxxpos-3)) and
(mousey>(yyp+3)) and (mousey<(yyp+21)) then
begin
msel:=1+ ( ((mousex-(1+xxp)) div 10)+(((mousey-(4+yyp)) div 3) *7) );
msel:=msel-(calstartpos-1);
if msel<1 then msel:=1 else
if msel>daysinmonth(seldate.month,seldate.year) then
msel:=daysinmonth(seldate.month,seldate.year);
seldate.day:=msel;
end;
showcal(seldate);
end else
if keypressed then
begin
ch:=readkey;
if ch=#27 then don:=true else
if ch=#0 then
begin
ch:=readkey;
if ch=#68 then don:=true;
if (ch=#75) OR (ch=#59) then
begin
DecDay;
end else
if (ch=#77) OR (ch=#60) then
begin
IncDay;
end else
if ch=#72 then
begin
PrevWeek;
end else
if ch=#80 then
begin
NextWeek;
end;
if (ch=#73) or (ch=#61) then { month dec }
begin
PrevMonth;
end else
if (ch=#81) or (ch=#62) then { month inc }
begin
NextMonth;
end else
if (ch=#71) or (ch=#63) then { year dec }
begin
PrevYear;
end else
if (ch=#79) or (ch=#64) then { year inc }
begin
NextYear;
end else
if (ch=#65) then { set date to now }
begin
SetTime2Now;
end else
if (ch=#66) then { goto.. }
begin
gotodate;
end;
end;
showcal(seldate);
end;
until don;
end;
procedure init;
begin
gettimedate(dt);
seldate:=dt;
xxp:=4;
yyp:=((maxypos-20) div 2)-2;
if yyp<0 then yyp:=0;
INITSCREEN;
ClearFncKeys;
UpdateFncKey(1,'Prv Day');
UpdateFncKey(2,'Nex Day');
UpdateFncKey(3,'PrvMont');
UpdateFncKey(4,'NexMont');
UpdateFncKey(5,'PrvYear');
UpdateFncKey(6,'NexYear');
UpdateFncKey(7,' Now ');
UpdateFncKey(8,' Goto ');
UpdateFncKey(10,' Quit');
ShowFnckeys;
showcal(dt);
end;
Procedure Showcalendar;
begin
pushscreen;
init;
CalendarNavigate;
popscreen;
end;
begin
end.
{--SNIP--}
Venligst
Ingolf
"Thomas Due" <tdue@mail.dk> wrote in message
news:f4373cde.0110142229.40951c05@posting.google.com...
> "Ulrik Vadstrup" <vadstrup@post12.tele.dk> wrote in message
news:<9qcbjm$19o9$1@news.cybercity.dk>...
> > Nogen der har en god ide til hvordan jeg finder ud af hvilke datoer et
uge
> > nummer indeholder (7, stk) og putter dem i et array ?
>
> For det første skal du have fundet ud af hvilken ugedag den 1/1 er,
> det har nemlig betydning for ugenumrene. Der er nogle enkle regler
> for hvor uge 1 starter, og det har temmelig stor betydning hvilken
> ugedag den 1/1 er.
>
> Reglen er at den 4/1 SKAL ligge i uge 1, så hvis uge 52 i det forgangne
> år slutter f.eks. den 25/12, kan det ikke lade sig gøre at få den 4/1 i
> uge 1, og derfor indskyder man en gang imellem et ekstra uge, nemlig 53.
>
> Så start med at finde ud af hvilken ugedag d. 1/1 er. Hvis det for
eksempel
> er en onsdag, så ved du at d. 4/1 er en lørdag (og derfor i uge 1). Dermed
> ved du at den første hele uge er uge 2, startende med mandag d. 6/1.
>
> Derefter er det sådan set bare at tælle frem til den uge du ønsker. Det
> mest besværlige er det jeg lige har beskrevet herover.
>
> Mvh
> Thomas Due
|