Найти те даты, когда день рождения попадает на тот же день

[Дюша Метелкин]

Дана дата рождения и день недели на, который она попадает. Найти те даты, когда день рождения попадает на тот же день. Заранее спасибо!

[newerow1989]

procedure TForm1.Button1Click(Sender: TObject);
const dni:array[1..7] of string=('вс','пн','вт','ср','чт','пт','сб');
var i,a,b:integer;
    dat,dn:string;
    dt:tDateTime;
begin
   dat:=Edit1.Text;//23.06
   dn:=Edit2.Text;//чт
   a:=StrToInt(Edit3.Text);//2000
   b:=StrToInt(Edit4.Text);//2100
   ListBox1.Clear;
   For i:=a to b do
   begin
      dt:=StrToDateTime(Format('%s.%d',[dat,i]));
      If dni[DayOfWeek(dt)]=dn then
         ListBox1.Items.Add(FormatDateTime('dd.mm.yyyy - ddd',dt));
   end;
end;

[Serge_Bliznykov]

newerow1989, боюсь, что не сойдёт... Вы же на Delphi написали, а раздел - "Паскаль"...

[Дюша Метелкин]

Срочно нужно, помогите пожалуйста!

[min@y™]

Срочно нужно, помогите пожалуйста!

чо не устраивает-то?

[Aleksandr H.]

(с)пионерино отсудаво

uses CRT;
procedure GetDay (var d, m, y : integer);
var
correct : byte;
begin
correct := 1;
repeat
writeLn ('Input Data.');
write ('Day - ');
readLn (d);
write ('Month - ');
readLn (m);
write ('Year - ');
readLn (y);

{ Проверим правильность года. Если год не "правильный", то попросим ввести дату ещё раз }
if y <= 4903 then
if y >= 1000 then
correct := 0;
until correct = 0
end;

function CountDay (d, m, y : integer):string ;
var
week : array [0 .. 6] of string[11];
c, w : integer;
begin
week[0] := 'sunday';
week[1] := 'monday';
week[2] := 'tuesday';
week[3] := 'wednesday';
week[4] := 'thursday';
week[5] := 'friday';
week[6] := 'saturday';

{ Месяц январь или февраль = > нужно преобразовать }
if m < 3 then
begin
m := m + 10;
y := y - 1
end
else
m := m - 2;

c := y div 100;
y := y mod 100;
w := abs (trunc (2.6 * m -0.2) + d + y div 4 + y + c div 4 - 2 * c) mod 7;
CountDay := week[w];
end;

var
d, y, m : integer; i:byte;
today:string;
begin
ClrScr;
GetDay (d, m, y);
today := CountDay (d, m, y);
writeln(today);

for i := 0 to 20 do
   begin
        if today = CountDay(d,m,2000+i) then
           writeln(2000+i);
   end;
readln;
end.

[Serge_Bliznykov]

Aleksandr H., что-то мне подсказывает, что этот код не без косячков...
попробуйте ввести 12.04.2002
Это какой день недели? И в каких годах 12 апреля будет тем же самым днём?!


p.s. хотя, я согласен с вопросом к автору темы - "А что конкретно не устраивает?"


добавлю. я бы рекомендовал воспользоваться функцией отсюда

function DayOfWeek(Day, Month, Year: Integer) : Integer;
var
  century, yr, dw: Integer;
begin
  if Month < 3 then
  begin
    Inc(Month, 10);
    Dec(Year);
  end
  else
     Dec(Month, 2);
  century := Year div 100;
  yr := year mod 100;
  dw := (((26 * month - 2) div 10) + day + yr + (yr div 4) +
    (century div 4) - (2 * century)) mod 7;
  if dw < 0 then DayOfWeek := dw + 7
  else DayOfWeek := dw;
  if (dw = 0) or ((dw+7)=0) then DayOfWeek:=7
end;

[Aleksandr H.]

Serge_Bliznykov, да, косячит Но 23/6/2016 совпало

Вот вариант из источника

function WhatDay(Year: Integer; Month: Integer; Day: Integer):string;

var a,y,m: integer;
    week : array [0 .. 6] of string[11];
    w : integer;
begin
week[0] := 'sunday';
week[1] := 'monday';
week[2] := 'tuesday';
week[3] := 'wednesday';
week[4] := 'thursday';
week[5] := 'friday';
week[6] := 'saturday';
 a := (14 - Month) div 12;
 y := year - a;
 m := month + 12 * a - 2;
 w := (7000 + (day + y + y div 4 - y div 100 + y div 400 + (31 * m) div 12)) mod 7;

 WhatDay := week[w];
end;

[Serge_Bliznykov]

Сообщение от Aleksandr H.

Вот вариант из источника

function WhatDay(Year: Integer; Month: Integer; Day: ......end;

Проверил. Работает.
Результаты у DayOfWeek и WhatDay совпадают.
Можно пользоваться любой из этих функций!