Code:

function DateExists(Date: string; Separator: char): Boolean;

var

OldDateSeparator: Char;

begin

Result := True;

OldDateSeparator := DateSeparator;

DateSeparator := Separator;

try

try

StrToDate(Date);

except

Result := False;

end;

finally

DateSeparator := OldDateSeparator;

end;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

if DateExists('35.3.2001', '.') then

begin

{your code}

end;

end;

 

 

 

Взято с Delphi Knowledge Base: https://www.baltsoft

 


Code:

function ValidDate(const S: String): Boolean;

BEGIN

Result := True;

try

StrToDate(S);

except

ON EConvertError DO

Result := False;

end;

END

 

 

https://delphiworld.narod

DelphiWorld 6.0

В связи с наступающим Новым годом я решил посвятить выпуск календарю. Ниже приведенная программа рисует на форме календарь на 2002 год. Для каждого месяца сначала выводится его название (используется глобальная переменная LongMonthNames модуля SysUtils), далее выводятся сокращенные названия дней недели (глобальная переменная ShortDayNames модуля SysUtils) и, наконец, выводятся сами числа. Количество дней в месяце записано в массиве months. Чтобы определить, високосный это год или нет, используется функция IsLeapYear.

 

Code:

const year = 2002; // Год календаря

 

var months: array [1..12] of byte;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

Form1.Caption := 'Календарь на ' + IntToStr(year) + ' год';

Form1.Color := clWhite;

// Длины месяцев:

months[1] := 31;

months[2] := 28 + ord(IsLeapYear(year));

months[3] := 31;

months[4] := 30;

months[5] := 31;

months[6] := 30;

months[7] := 31;

months[8] := 31;

months[9] := 30;

months[10] := 31;

months[11] := 30;

months[12] := 31;

end;

 

procedure TForm1.FormPaint(Sender: TObject);

const// Настройки размеров календаря:

MonthDX = 150;

MonthDY = 135;

DayDX = 20;

DayDY = 15;

MonthH = 20;

var

month, i: integer;

day: integer;

s: string[2];

begin

with Form1.Canvas dofor month := 1to12dobegin

// Вывод названия месяца:

Font.Name := 'Times';

Font.Size := 13;

TextOut((month - 1) mod3 * MonthDX, (month - 1) div3 * MonthDY,

LongMonthNames[month]);

 

Font.Name := 'Courier';

Font.Size := 8;

// Вывод названий дней недели:

for day := 1to7do

TextOut((month - 1) mod3 * MonthDX,

day mod7 * DayDY + (month - 1) div3 * MonthDY + MonthH,

ShortDayNames[(day + 1) mod7 + 1]);

 

// Определение дня недели первого числа месяца:

day := DayOfWeek(EncodeDate(year, month, 1)) - 2;

if day < 0then inc(day, 7);

// Вывод чисел:

for i := 1to months[month] dobegin

str(i: 2, s);

TextOut(day div7 * DayDX + (month - 1) mod3 * MonthDX + DayDX,

day mod7 * DayDY + (month - 1) div3 * MonthDY + MonthH, s);

inc(day);

end;

end;

end;

 

 

 

 

https://delphiworld.narod

Автор: Mike Orriss

 

Мне необходима программа, которая генерировала бы еженедельные списки задач. Программа должна просто показывать количество недель в списке задач и организовывать мероприятия, не совпадающие по времени. В моем текущем планировщике у меня имеется 12 групп и планы на 11 недель.

 

Мне нужен простой алгоритм, чтобы решить эту проблему. Какие идеи?

 

Вот рабочий код (но вы должны просто понять алгоритм работы):

 

Code:

unit Unit1;

 

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

 

type

TForm1 = class(TForm)

ListBox1: TListBox;

Edit1: TEdit;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

 

var

Form1: TForm1;

 

implementation

 

{$R *.DFM}

 

const

maxTeams = 100;

var

Teams: array[1..maxTeams] of integer;

nTeams, ix, week, savix: integer;

 

function WriteBox(week: integer): string;

var

str: string;

ix: integer;

begin

Result := Format('Неделя=%d ', [week]);

for ix := 1to nTeams do

begin

if odd(ix) then

Result := Result + ' '

else

Result := Result + 'v';

Result := Result + IntToStr(Teams[ix]);

end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

nTeams := StrToInt(Edit1.Text);

if Odd(nTeams) then

inc(nTeams); {должны иметь номера каждой группы}

ListBox1.Clear;

for ix := 1to nTeams do

Teams[ix] := ix;

ListBox1.Items.Add(WriteBox(1));

 

for week := 2to nTeams - 1do

begin

Teams[1] := Teams[nTeams - 1];

{используем Teams[1] в качестве временного хранилища}

for ix := nTeams downto2do

ifnot Odd(ix) then

begin

savix := Teams[ix];

Teams[ix] := Teams[1];

Teams[1] := savix;

end;

for ix := 3to nTeams - 1do

if Odd(ix) then

begin

savix := Teams[ix];

Teams[ix] := Teams[1];

Teams[1] := savix;

end;

Teams[1] := 1; {восстанавливаем известное значение}

ListBox1.Items.Add(WriteBox(week));

end;

end;

 

end.

Code:

function WeekOfYear(ADate: TDateTime): word;

var

day: word;

month: word;

year: word;

FirstOfYear: TDateTime;

begin

DecodeDate(ADate, year, month, day);

FirstOfYear := EncodeDate(year, 1, 1);

Result := Trunc(ADate - FirstOfYear) div7 + 1;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(IntToStr(WeekOfYear(Date)));

end;

 

 

 

https://delphiworld.narod

DelphiWorld 6.0

 

 


 

Code:

function WeekNum(const ADate: TDateTime): word;

var

Year: word;

Month: word;

Day: word;

begin

DecodeDate(ADate + 4 - DayOfWeek(ADate + 6), Year, Month, Day);

result := 1 + trunc((ADate - EncodeDate(Year, 1, 5) +

DayOfWeek(EncodeDate(Year, 1, 3))) / 7);

end;

 

https://delphiworld.narod

DelphiWorld 6.0

 

 


 

Code:

function WeekOfYear(Dat: TDateTime): Word;

// Интерпретация номеров дней:

// ISO: 1 = Понедельник, 7 = Воскресенье

// Delphi SysUtils: 1 = Воскресенье, 7 = Суббота

var

Day, Month, Year: Word;

FirstDate: TDateTime;

DateDiff: Integer;

begin

day := SysUtils.DayOfWeek(Dat) - 1;

Dat := Dat + 3 - ((6 + day) mod7);

DecodeDate(Dat, Year, Month, Day);

FirstDate := EncodeDate(Year, 1, 1);

DateDiff := Trunc(Dat - FirstDate);

Result := 1 + (DateDiff div7);

end;

©Drkb::00742

https://delphiworld.narod

Code:

{

Retrieves information about the time-out period associated

with the accessibility features.

The pvParam parameter must point to an ACCESSTIMEOUT

structure that receives the information.

Set the cbSize member of this structure and the

uiParam parameter to SizeOf(ACCESSTIMEOUT).

}

 

 

// ACCESSTIMEOUT structure

type

TAccessTimeOut = record

cbSize: UINT;

dwFlags: DWORD;

iTimeOutMSec: DWORD;

end;

 

procedure GetAccessTimeOut(var bTimeOut: Boolean; var bFeedBack: Boolean;

var iTimeOutTime: Integer);

// bTimeOut: the time-out period for accessibility features.

// bFeedBack: the operating system plays a descending

// siren sound when the time-out period elapses and the

// Accessibility features are turned off.

// iTimeOutTime: Timeout in ms

var

AccessTimeOut: TAccessTimeOut;

begin

ZeroMemory(@AccessTimeOut, SizeOf(TAccessTimeOut));

AccessTimeOut.cbSize := SizeOf(TAccessTimeOut);

 

SystemParametersInfo(SPI_GETACCESSTIMEOUT, SizeOf(AccessTimeOut), @AccessTimeOut, 0);

 

bTimeOut := (AccessTimeOut.dwFlags and ATF_TIMEOUTON) = ATF_TIMEOUTON;

bFeedBack := (AccessTimeOut.dwFlags and ATF_ONOFFFEEDBACK) = ATF_ONOFFFEEDBACK;

iTimeOutTime := AccessTimeOut.iTimeOutMSec;

end;

 

// Test it:

 

procedure TForm1.Button2Click(Sender: TObject);

var

bTimeOut, bFeedBack: Boolean;

iTimeOutTime: Integer;

begin

GetAccessTimeOut(bTimeOut, bFeedBack, iTimeOutTime);

label1.Caption := IntToStr(Ord(bTimeOut));

Label2.Caption := IntToStr(Ord(bFeedBack));

Label3.Caption := IntToStr(iTimeOutTime);

end;

 

{

Sets the time-out period associated with the accessibility features.

The pvParam parameter must point to anACCESSTIMEOUT structure that

contains the new parameters.

Set the cbSize member of this structure and the uiParam

parameter to sizeof(ACCESSTIMEOUT).

}

 

{

Setzt Informationen zu den ACCESSEDTIMEOUT-Eigenschaften.

"uiParam" erwartet die Gro?e der ACCESSEDTIMEOUT-Struktur,

die in "pvParam" ubergeben werden muss.

}

 

procedure SetAccessTimeOut(bTimeOut, bFeedBack: Boolean; iTimeOutTime: Integer);

// bTimeOut: If true, a time-out period has been set for accessibility features.

// bFeedBack: If true, the operating system plays a descending

// siren sound when the time-out period elapses and the

// accessibility features are turned off.

// iTimeOutTime: Timeout in ms

var

AccessTimeOut: TAccessTimeOut;

begin

ZeroMemory(@AccessTimeOut, SizeOf(TAccessTimeOut));

AccessTimeOut.cbSize := SizeOf(TAccessTimeOut);

 

case bTimeOut of

True: AccessTimeOut.dwFlags := ATF_TIMEOUTON;

False: AccessTimeOut.dwFlags := 0;

end;

 

if bFeedBack then

AccessTimeOut.dwFlags := AccessTimeOut.dwFlags or ATF_ONOFFFEEDBACK;

 

AccessTimeOut.iTimeOutMSec := iTimeOutTime;

 

SystemParametersInfo(SPI_SETACCESSTIMEOUT, SizeOf(AccessTimeOut),

@AccessTimeOut, SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);

end;

 

// Test it:

procedure TForm1.Button1Click(Sender: TObject);

begin

SetAccessTimeOut(True, True, 600000); // 10 min. timeout

end;