function FifthTuesday(ADate: TDateTime): TDateTime;
var
Lastday: TDateTime;
DOW: Word;
begin
Result := 0;
Lastday := EndOfTheMonth(ADate);
DOW := DayOfTheWeek(Lastday);
if WeekOfTheMonth(LastDay) = 5 then
begin
if DOW = 2 then
Result := LastDay
else if DOW > 2 then
begin
while DOW > 2 do
begin
LastDay := IncDay(LastDay, -1);
DOW := DayOfTheWeek(Lastday);
end;
Result := LastDay;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(DatetimetoStr(FifthTuesday(Date))) //for this month
end;
function FindDate(Dt:TDate;Dy:String;Num:Integer):TDate;
var
i,j:integer;
ddte:TDate;
Dte : String;
begin
j:=0;
for i:= 1 to DaysInMonth(MonthOf(dt)) do
begin
ddte := EncodeDate(YearOf(dt),MonthOf(dt),i);
Dte := FormatDateTime('ddd',ddte);
if Dte = Dy then
begin
inc(j);
if j = Num then
begin
Result := ddte;
exit;
end;
end;
end;
if J < Num then
Result := StrToDate('01/01/1700');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
If Datetostr(FindDate(now,'Tue',5)) = StrToDate('01/01/1700') then
Showmessage('There is no date for that number in this month')
else
Showmessage(DateToStr(Datetostr(FindDate(now,'Tue',5))));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ShortDateFormat := 'dd/mm/yyyy';
end;
function FindDate(Dt:TDate;Dy:String;Num:Integer):TDate;
var
i,j:integer;
ddte:TDate;
Dte : String;
begin
Result := StrToDate('01/01/1700');
j:=0;
for i:= 1 to DaysInMonth(MonthOf(dt)) do
begin
ddte := EncodeDate(YearOf(dt),MonthOf(dt),i);
Dte := FormatDateTime('ddd',ddte);
if Dte = Dy then
begin
inc(j);
if j = Num then
begin
Result := ddte;
exit;
end;
end;
end;
if J < Num then
Result := StrToDate('01/01/1700');
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Dt:TDate;
begin
Dt := FindDate(now,'Tue',5); // or FindDate(now,'Thu',5);
If Dt = StrToDate('01/01/1700') then
Showmessage('There is no date for that number in this month')
else
Showmessage(Datetostr(Dt));
end;
function FifthTuesday(ADate: TDateTime): TDateTime;
var
Lastday: TDateTime;
DOW: Word;
begin
Result := 0;
Lastday := EndOfTheMonth(ADate);
DOW := DayOfTheWeek(Lastday);
if WeekOfTheMonth(LastDay) = 5 then
begin
if DOW = 2 then
Result := LastDay
else if DOW > 2 then
begin
while (WeekOfTheMonth(LastDay) = 5) and (DOW > 2) do
begin
LastDay := IncDay(LastDay, -1);
DOW := DayOfTheWeek(Lastday);
end;
if DOW = 2 then
Result := LastDay;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(DatetimetoStr(FifthTuesday(Date))) //for this month
end;
function FindDate(Dt:TDate;Dy,Num:Integer):TDate;
var
i,j:integer;
ddte:TDate;
Dte : String;
begin
Result := EncodeDate(1700,1,1);
j:=0;
for i:= 1 to DaysInMonth(MonthOf(dt)) do
begin
ddte := EncodeDate(YearOf(dt),MonthOf(dt),i);
if DayOfWeek(ddte) = Dy then
begin
inc(j);
if j = Num then
begin
Result := ddte;
exit;
end;
end;
end;
if J < Num then
Result := EncodeDate(1700,1,1);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Dt:TDate;
begin
Dt := FindDate(now,3,5);
If Dt = EncodeDate(1700,1,1) then
Showmessage('There is no date for that number in this month')
else
Showmessage(Datetostr(Dt));
end;
function FindDate(Dt:TDate;Dy,Num:Integer):TDate;
var
i,j:integer;
ddte:TDate;
begin
Result := EncodeDate(1700,1,1);
j:=0;
for i:= 1 to DaysInAMonth(YearOf(dt),MonthOf(dt)) do
begin
ddte := EncodeDate(YearOf(dt),MonthOf(dt),i);
if DayOfWeek(ddte) = Dy then
begin
inc(j);
if j = Num then
begin
Result := ddte;
exit;
end;
end;
end;
if J < Num then
Result := EncodeDate(1700,1,1);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Dt:TDate;
begin
Dt := FindDate(now,3,5);
If Dt = EncodeDate(1700,1,1) then
Showmessage('There is no date for that number in this month')
else
Showmessage(Datetostr(Dt));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(DatetoStr(EndOfTheMonth(EncodeDate(2011,5,3))));
end;
function FifthTuesday(ADate: TDateTime): TDateTime;
var
CheckDay: TDateTime;
Index: Integer;
WorkMonth: Word;
DD, MM, YY: WORD;
begin
Result := 0;
DecodeDate(ADate, YY, MM, DD);
CheckDay := EncodeDate(YY, MM, 1);
//start by getting first tuesday
while DayOfTheWeek(CheckDay) <> 2 do
CheckDay := IncDay(CheckDay, 1);
//now we have first tuesday
WorkMonth := MM;
Index := 1;
while (WorkMonth = MM) and (Index < 5) do
begin
CheckDay := IncDay(CheckDay, 7);
WorkMonth := MonthOf(CheckDay);
Inc(Index);
end;
if (WorkMonth = MM) and (Index = 5) then
Result := CheckDay
else
Result := 0;
end;
procedure TForm3.Button1Click(Sender: TObject);
begin
ShowMessage(DateToStr(FifthTuesday(MonthCalendar1.Date)));
end;
function FifthTuesday1(MM, YY: Integer): TDateTime;
var
CheckDay: TDateTime;
Index: Integer;
WorkMonth: Word;
begin
Result := 0;
CheckDay := EncodeDate(YY, MM, 1);
//start by getting first tuesday
while DayOfTheWeek(CheckDay) <> 2 do
CheckDay := IncDay(CheckDay, 1);
//now we have first tuesday
WorkMonth := MM;
Index := 1;
while (WorkMonth = MM) and (Index < 5) do
begin
CheckDay := IncDay(CheckDay, 7);
WorkMonth := MonthOf(CheckDay);
Inc(Index);
end;
if (WorkMonth = MM) and (Index = 5) then
Result := CheckDay
else
Result := 0;
end;
//
ShowMessage(DateToStr(FifthTuesday1(8, 2011)))
procedure TForm1.spinEditYearChange(Sender: TObject);
var i : integer;
dt,LastDay : TDate;
begin
Memo1.Clear;
for i := 1 to 12 do
begin
dt := EncodeDate(Floor(spinEditYear.Value), i, 1); // Go to 1st day
Lastday := EndOfTheMonth(dt);
while DayOfWeek(dt) <> 3 do dt := dt + 1; // Toggle to Fist Tuesday
dt := dt + 28; // Add 4 weeks to first Tuesday
if dt <= Lastday then // Check if date still in range
Memo1.Lines.Add(DateToStr(dt))
end;
end;
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Delphi XE10, DigitalPersona Fingerprint reader and MySQL | 6 | 267 | |
creating manifest for my dll that called from activex | 6 | 114 | |
Strange behavior when a form is closed | 6 | 57 | |
Installshield for Embarcadero EX 10.1 Berlin | 4 | 41 |
Join the community of 500,000 technology professionals and ask your questions.