تشخیص روز هفته

[niloofar_taieban]

با سلام.
دوستام من یه برنامه احتیاج دارم به زبان دلفی که بتونه این کار را برای من انجام بده

وقتی که کاربر یه تاریخی رو در یه edit وارد می کنه روز مربوط به اون تاریخ در یک edit دیگر نمایش داده شود.
یا وقتی اسم روزی رو از یه combo انتخاب می کنیم. مثلا شنبه اولین تاریخی که برابر با شنبه هست در editنمایش داده شود.
ممنون میشم اگه هر چه سریعتر کسی جواب منو بده.

[mohsenrami]

function DayOfWeek(Date: TDateTime): Integer;

بقیش با خودت......

[babak869]

سلام
لطفا در این باره بیشتر توضیح بدید
ممنونم

[mzjahromi]

GetDay((Trunc(Date)+30) mod 7);



Function GetDay(d1:Integer):String;

Begin

  case D1 Of

    0:getDay:='ÔäÈå';

    1:getDay:='íßÔäÈ&ar  ing;';

    2:getDay:='ÏæÔäÈ&arin  g;';

    3:getDay:='Óå ÔäÈå';

    4:getDay:='åÇÑÔä&E  grave;å';

    5:getDay:='äÌÔäÈ&ar  ing;';

    6:getDay:='ÌãÚå';

  End;

End;

[niloofar_taieban]

آقایون تو رو خدا یه کم واضح تر کمک کنید من تازه تازه دارم با دلفی کار می کنم.
و یه چیز دیگه اینکه من می خوام با تاریخ و روز شمسی کار کنم نه میلادی .یعنی باید بازدن تاریخ تو editبرای من یکی از روزهای هفته شنبه یکشنبه و .... را بیاره.

[mzjahromi]

آقایون تو رو خدا یه کم واضح تر کمک کنید من تازه تازه دارم با دلفی کار می کنم.
و یه چیز دیگه اینکه من می خوام با تاریخ و روز شمسی کار کنم نه میلادی .یعنی باید بازدن تاریخ تو editبرای من یکی از روزهای هفته شنبه یکشنبه و .... را بیاره.

بابا من که کد کامل واسه ات نوشتم
دیگه چی می خوای ؟
تبدیل کدهای شمسی به میلادی هم تو سایت هست

[niloofar_taieban]

نه من تبدیل شمسی به میلادی رو نمی خوام
فقط هیچی از کد هایی که شما نوشتید سر در نیاوردم.
به هر حال ازتون ممنونم.

[Babak-Aghili]

1- با تشکر از آقای سهراب صفوی.
2- یک کم ! طولانی شد ! ... یک کامپوننت گرافیکی کامل . تقویم قرن .

3- از متد DayOfWeek ش هم برای چیزی که لازم داری استفاده کن.

 

 

unit MyCalendar;
 

 

interface

 

uses

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

Dialogs, ComCtrls, ExtCtrls, StdCtrls , Grids,

CommCtrl;

const

COffDayColor = clRed;

CDisableColor = clGray;

CEnableColor = clYellow;

CFocusedCellColor = clBlue;

Kabise33Years = 55;

type

TDPM = Array [1..12] Of Byte;

TWeeksDays = Array [0..6] Of String;

Str2 = String[3];

TMyDate = Record

Day , Month , Year : Integer;

End;

TMonthNames = Array [1..12] Of String;

const

DPM : TDPM = (31,31,31,31,31,31,30,30,30,30,30,29);

RefrenceTime : String = '1381/09/23';

WeeksDays : TWeeksDays = ('ÔäÈå','íß&O  circ;äÈå','ÏæÔ&  auml;Èå','Óå ÔäÈå','�åÇ&Nt  ilde;ÔäÈå','�ä&Igrave  ; ÔäÈå','ÂÏ&iacut  e;äå');

MonthNames : TMonthNames = ('ÝÑæÑÏí&au  ml;','ÇÑÏíÈ&aring  ;ÔÊ','ÎÑÏÇ&Iu  ml;','ÊíÑ','ãÑ&I  uml;ÇÏ','ÔåÑ&iacute  ;æÑ','ãåÑ','&Acir  c;ÈÇä','ÂÐÑ','  Ïí','Èåãä','&  Ccedil;ÓÝäÏ');

type

 

TColor2DOpenArray = class(TControl)

private

FArray : Array Of Array Of TColor;

FColCount , FRowCount : Integer;

protected

procedure SetArrayLength(ACol,ARow : Integer);

procedure SetColCount(Value : Integer);

procedure SetRowCount(Value : Integer);

public

Constructor Create(AOwner : TComponent);override;

Destructor Destroy;override;

procedure SetItem(ACol,ARow : Integer ; Value : TColor);

function GetItem(ACol,ARow : Integer) : TColor;

property Items[ACol,ARow : Integer]:TColor read GetItem write SetItem;default;

published

property ColCount : Integer read FColCount write SetColCount;

property RowCount : Integer read FRowCount write SetRowCount;

end;

 

 

SCalendar = class;

 

TMyStringGrid = class(TStringGrid)

protected

FCal : SCalendar;

FCellDates : Array [0..6 , 1..6] Of Byte; //the date that each cell contains

FCellColors : TColor2DOpenArray;

procedure DblClick;override;

procedure Click;override;

procedure DrawCell(ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);override;

public

Constructor Create(AOwner : TComponent);override;

Destructor Destroy;override;

end;

 

SCalendar = class(TPanel)

private

// FInitOnTodayDate : Boolean;

FMah , FSal , FDay : Byte;

DrawGridForcesExit : Boolean;

FToday : String;

FMonthLabel , FYearLabel , FTodayLabel , FStaticLabel : TLabel;

FStringGrid : TMyStringGrid;

FUpDown : TUpDown;

FOffDayList : TStrings;

FOffDayColor ,

FDisableColor ,

FEnableColor ,

FFocusedCellColor : TColor;

FInitialDate , FD : String;

protected

procedure SetOffDayColor(Value : TColor);

procedure SetDisableColor(Value : TColor);

procedure SetEnableColor(Value : TColor);

procedure SetFocusedCellColor(Value : TColor);

function MyDateToString(FDate : TMyDate): String;

function Compare(t1 , t2 : TMYDate) : Integer;

function DayBetweenToDays(day , t1 , t2 : TMyDate) : Boolean;

procedure Exchange(var t1 , t2 : TMyDate);

procedure SetOffDays(Value : TStrings);

function StringToTMyDate(FDate : String):TMyDate;

function ConvertTo2Letter(i : Integer) : String;

function MyWhatDayIsIt(t1 : String): Byte;

procedure Panel1CanResize(Sender: TObject;var NewWidth,

NewHeight: Integer; var Resize: Boolean);

procedure Initialize;

procedure LabelOnClick(Sender : TObject);

procedure UpDown1ChangingEx(Sender: TObject;var AllowChange: Boolean; NewValue: Smallint;Direction: TUpDownDirection);//for up down

function GetToday : String;

procedure SetToday(Value : String);

procedure DrawGrid;

procedure SetDay(Value : String);

procedure SetInitialDate(Value : String);

procedure FDayFMahFSalChanged;

public

Constructor Create(AOwner : TComponent);override;

Destructor Destroy;override;

function StrTo10CharFormat(s : String):String;

function CheckDate(var FDate : String): Boolean;

function IsKabise(Sal : Integer):Boolean;

function ToFarsiDate(eng_date : string):String;

function WhatDayIsIt(t1 : String): String;

function IsOffDay(Date : String):Boolean;

function Dec(Date1 , Date2 : String) : Integer;

function WorkDays(Date1 , Date2 : String) : Integer;

function Intersect(Date1,Date2,Date3,Date4 : String;var Date5,Date6 : String):Integer;

property Today : String read GetToday write SetToday;

property OffDays : TStrings read FOffDayList write SetOffDays;

property DayOnGrid : String read FD write SetDay;

published

property InitialDate : String read FInitialDate write SetInitialDate;

property OffDayColor : TColor read FOffDayColor write SetOffDayColor;

property DisableColor : TColor read FDisableColor write SetDisableColor;

property EnableColor : TColor read FEnableColor write SetEnableColor;

property FocusedCellColor : TColor read FFocusedCellColor write SetFocusedCellColor;

 

end;

 

TFarsiCalendar = class(SCalendar)

published

property OffDayColor;

property DisableColor;

property EnableColor;

property FocusedCellColor;

end;

 

procedure Register;

 

implementation

 

{TMyStringGrid Class}

Constructor TMyStringGrid.Create(AOwner : TComponent);

begin

inherited Create(AOwner);

 

Cells[0 , 0] :='ÔäÈå';

Cells[1 , 0] :='1ÔäÈå';

Cells[2 , 0] :='2ÔäÈå';

Cells[3 , 0] :='3ÔäÈå';

Cells[4 , 0] :='4ÔäÈå';

Cells[5 , 0] :='5ÔäÈå';

Cells[6 , 0] :='ÌãÚå';

DefaultColWidth := 30;

DefaultRowHeight := 30;

Font.Name := 'Times New Roman';

Font.Size := 10;

Font.Style := [fsBold];

FixedCols := 0;

FixedRows := 1;

FixedColor := $00C08000;

ColCount := 7;

RowCount := 7;

Col := 0;

Row := 1;

ScrollBars := ssNone;

FCellColors := TColor2DOpenArray.Create(Self);

FCellColors.SetArrayLength(7 , 7);

ParentBiDiMode := False;

ParentCtl3D := False;

ParentFont := False;

ParentColor := False;

Ctl3D := False;

BorderStyle := bsNone;

TabStop := False;

BiDiMode := bdRightToLeft;

Width := 217;

Height := 216;

Options := [goFixedVertLine,goFixedHorzLine,goDrawFocusSelecte  d]-

[goRangeSelect,goRowSizing,goColSizing,goRowMoving,  goColMoving,

goEditing,goTabs,goRowSelect,goThumbTracking];

end;

 

Destructor TMyStringGrid.Destroy;

begin

FCellColors.Free;

inherited Destroy;

end;

 

procedure TMyStringGrid.DrawCell(ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);

Var i : Integer;

begin

If (ARow = 0) Then Begin

inherited DrawCell(ACol , ARow , Rect , State);

Exit;

End;

Canvas.Pen.Width := 1;

Canvas.Brush.Color := FCellColors[ACol , ARow];

Canvas.FillRect(Rect);

Canvas.Pen.Color := ClBlue;

Canvas.Font.Color := clBlack;

i := Rect.Left+2+(ABS(Rect.Right-Rect.Left)-Canvas.TextWidth(Cells[ACol , ARow])) Div 2;

Canvas.TextRect(Rect, i , Rect.Top+2, Cells[ACol, ARow]);

Canvas.Pen.Width := 2;

Canvas.Pen.Color := FCal.FocusedCellColor;

If (Col = ACol)AND(Row = ARow) Then

Canvas.Arc(Rect.Left , Rect.Top+1 , Rect.Right , Rect.Bottom-3 ,

Rect.Left , Rect.Top , Rect.Left , Rect.Top);

If csDesigning in ComponentState Then

inherited DrawCell(ACol , ARow , Rect , State);

End;

 

procedure TMyStringGrid.Click;

Var day , mah , sal : Integer;

begin

inherited Click;

If (Row = 0)Then Exit;

If FCal.DrawGridForcesExit Then Begin

FCal.DrawGridForcesExit := False;

Exit;

End;

day := FCellDates[Col , Row];

mah := FCal.FMah;

sal := FCal.FSal;

// r := 0;

If (day < 15)AND(Row > 4) Then Begin

Inc(mah);

// r := +1;

End Else

If(day > 15)AND(Row < 3) Then Begin

Dec(mah);

// r := -1;

End;

If mah = 0 Then Begin

mah := 12;

Dec(sal);

End Else

If mah = 13 Then Begin

mah := 1;

Inc(sal);

End;

If sal = -1 Then sal := 99;

If sal = 100 Then sal := 0;

// If r = 0 Then Exit;

FCal.FDay := day;

If FCal.Fday = DPM[FCal.FMah] Then

FCal.FDay := DPM[mah];

FCal.FMah := mah;

FCal.FSal := sal;

SendMessage(FCal.FUpDown.Handle , UDM_SETPOS , 0 , FCal.FMah);

FCal.FDayFMahFSalChanged;

end;

 

procedure TMyStringGrid.DblClick;

Var s : String;

day , mah , sal : Integer;

i : Integer;

begin

inherited DblClick;

If (Row = 0)OR(Col = 6) Then Exit;

day := FCellDates[Col , Row];

mah := FCal.FMah;

sal := FCal.FSal;

If (day < 15)AND(Row > 4) Then Begin

Exit;

End Else

If(day > 15)AND(Row < 3) Then Begin

Exit;

End;

s := FCal.StrTo10CharFormat(IntToStr(sal)+'/'+IntToStr(mah)+'/'+IntToStr(day));

i := FCal.FOffDayList.IndexOf(s);

If i <> -1 Then Begin

FCal.FOffDayList.Delete(i);

FCellColors[Col , Row] := FCal.EnableColor;

End Else

Begin

FCal.FOffDayList.Add(s);

FCellColors[Col ,Row] := FCal.OffDayColor;

End;

Invalidate;

end;

 

 

{SCalendar Class}

Constructor SCalendar.Create(AOwner : TComponent);

Var s : String;

begin

inherited Create(AOwner);

 

BiDiMode := bdRightToLeft;

FStringGrid := TMyStringGrid.Create(Self);

FStringGrid.Parent := Self;

FStringGrid.BiDiMode := bdRightToLeft;

FStringGrid.FCal := Self;

FMonthLabel := TLabel.Create(Self);

FMonthLabel.Parent := Self;

FMonthLabel.BiDiMode := bdRightToLeft;

FYearLabel := TLabel.Create(Self);

FYearLabel.Parent := Self;

FYearLabel.BiDiMode := bdRightToLeft;

FTodayLabel := TLabel.Create(Self);

FTodayLabel.Parent := Self;

FTodayLabel.BiDiMode := bdRightToLeft;

FStaticLabel := TLabel.Create(Self);

FStaticLabel.Parent := Self;

FStaticLabel.BiDiMode := bdRightToLeft;

FOffDayList := TStringList.Create;

FUpDown := TUpDown.Create(Self);

FUpDown.Parent := Self;

 

Font.Name := 'Times New Roman';

Font.Size := 16;

Font.Style := [fsBold];

Color := ClGreen;

Width := 221;

Height := 290;

FOffDayColor := COffDayColor;

FDisableColor := CDisableColor;

FEnableColor := CEnableColor;

FFocusedCellColor := CFocusedCellColor;

 

FOffDayList.Clear;// := TStrings(FOffDayListBox);

s := GetCurrentDir+'\OffDays.Txt';

If FileExists(s) Then

FOffDayList.LoadFromFile(s);

FStaticLabel.AutoSize := False;

FStaticLabel.Width := 41;

FStaticLabel.Height := 24;

FStaticLabel.Caption := '&Ccedil;&atilde;&Ntilde;&aelig;&Ograve;';

FStaticLabel.Top := 260;

FStaticLabel.Left := 162;

FStaticLabel.OnClick := LabelOnClick;

 

FTodayLabel.AutoSize := False;

FTodayLabel.Width := 116;

FTodayLabel.Height := 24;

// FTodayLabel.Caption := '1381/09/23';

FTodayLabel.Top := 260;

FTodayLabel.Left := 10;

FTodayLabel.OnClick := LabelOnClick;

 

FMonthLabel.AutoSize := False;

FMonthLabel.Width := 75;

FMonthLabel.Height := 24;

// FMonthLabel.Caption := '&Acirc;&ETH;&Ntilde;';

FMonthLabel.Top := 10;

FMonthLabel.Left := 75;

 

FYearLabel.AutoSize := False;

FYearLabel.Width := 62;

FYearLabel.Height := 24;

// FYearLabel.Caption := '1381';

FYearLabel.Top := 10;

FYearLabel.Left := 5;

 

FStringGrid.Top := 40;

FStringGrid.Left := 2;

FStringGrid.FCal := Self;

 

FUpDown.Top := 10;

FUpDown.Left := 160;

FUpDown.Orientation := udHorizontal;

FUpDown.Width := 46;

FUpDown.Height := 21;

FUpDown.OnChangingEx := UpDown1ChangingEx;

FDay := 1;

FInitialDate := '';

OnCanResize := Panel1CanResize;

Initialize;

End;

 

Destructor SCalendar.Destroy;

begin

FMonthLabel.Free;

FYearLabel.Free;

FTodayLabel.Free;

FStaticLabel.Free;

FStringGrid.Free;

FUpDown.Free;

FOffDayList.SaveToFile(GetCurrentDir+'\OffDays.Txt  ');

FOffDayList.Free;

inherited Destroy;

end;

 

procedure SCalendar.Initialize;

Var St : String;

d , m , y : Word;

begin

DecodeDate(Now , y , m , d);

St := ConvertTo2Letter(y)+'/'+ConvertTo2Letter(m)+'/'+IntToStr(d);

St := ToFarsiDate(St);

FToday := St;

FDay := StrToInt(Copy(St , 9 , 2));

FMah := StrToInt(Copy(St , 6 , 2));

FSal := StrToInt(Copy(St , 3 , 2));

 

FUpDown.Position := FMah;

FToday := St;

FD := St;

FDay := StrToInt(Copy(St , 9 , 2));

FMah := StrToInt(Copy(St , 6 , 2));

FSal := StrToInt(Copy(St , 3 , 2));

DrawGrid;

end;

 

procedure SCalendar.SetOffDays(Value : TStrings);

begin

If Value = nil Then Begin

FOffDayList.Free;

FOffDayList := nil;

Exit;

End;

FOffDayList.Assign(Value);

end;

procedure SCalendar.Panel1CanResize(Sender: TObject;var NewWidth,

NewHeight: Integer; var Resize: Boolean);

begin

Resize := False;

end;

 

procedure SCalendar.LabelOnClick(Sender : TObject);

begin

FDay := StrToInt(Copy(Today , 9 , 2));

FMah := StrToInt(Copy(Today , 6 , 2));

FSal := StrToInt(Copy(Today , 3 , 2));

FDayFMahFSalChanged;

end;

 

procedure SCalendar.UpDown1ChangingEx(Sender: TObject;

var AllowChange: Boolean; NewValue: Smallint;

Direction: TUpDownDirection);

Var prevmah : Integer;

begin

prevmah := FMah;

If NewValue < 1 Then Begin

If FSal-1<0 Then Begin //sal < 0

Exit;

End;

FMah := 12;

FSal := FSal-1;

SendMessage(FUpDown.Handle , UDM_SETPOS , 0 , FMah);

End Else

If NewValue > 12 Then Begin

If FSal+1>99 Then Begin

Exit;

End;

FMah := 1;

FSal := FSal +1;

SendMessage(FUpDown.Handle , UDM_SETPOS , 0 , FMah);

End Else

FMah := NewValue;

With FStringGrid Do

FDay := FCellDates[Col , Row];

If Fday = DPM[prevmah] Then

FDay := DPM[FMah];

If Fday = 0 Then Fday := 1;

FDayFMahFSalChanged; 

end;

 

function SCalendar.IsKabise(Sal : Integer):Boolean;

Var i : Integer;

begin

Result := False;

If Sal >= 100 Then

Sal := ((Sal Div 100)-13)*100+(Sal Mod 100);

i := ((Sal - Kabise33Years)Mod 33);

If i < 0 Then Inc(i , 33);

If i <> 32 Then

i := i Mod 4;

If i = 0 Then result := true;

end;

 

function SCalendar.IsOffDay(Date : String):Boolean;

begin

Result := False;

If Not CheckDate(Date) Then Exit;

If MyWhatDayIsIt(Date) = 6 Then Begin

Result := True;

Exit;

End;

If FOffDayList.IndexOf(Date) <> -1 Then

Result := True;

end;

 

procedure SCalendar.FDayFMahFSalChanged;

begin

SetDay('13'+ConvertTo2Letter(FSal)+'/'+ConvertTo2Letter(FMah)+'/'+

ConvertTo2Letter(FDay));

end;

 

procedure SCalendar.SetInitialDate(Value : String);

begin

If (NOT(csLoading in ComponentState))AND(NOT(csDesigning in ComponentState))

Then Exit;

If NOT CheckDate(Value) Then Begin

FInitialDate := '';

Exit;

End;

FInitialDate := Value;

Today := FInitialDate;

end;

 

procedure SCalendar.SetDay(Value : String);

begin

If NOT CheckDate(Value) Then Exit;

FD := Value;

FDay := StrToInt(Copy(Value , 9 , 2));

FMah := StrToInt(Copy(Value , 6 , 2));

FSal := StrToInt(Copy(Value , 3 , 2));

DrawGrid;

end;

 

procedure SCalendar.SetOffDayColor(Value : TColor);

begin

If Value <> FOffDayColor Then Begin

FOffDayColor := Value;

DrawGrid;

End;

end;

 

procedure SCalendar.SetDisableColor(Value : TColor);

begin

If Value <> FDisableColor Then Begin

FDisableColor := Value;

DrawGrid;

End;

end;

 

procedure SCalendar.SetEnableColor(Value : TColor);

begin

If Value <> FEnableColor Then Begin

FEnableColor := Value;

DrawGrid;

End;

end;

 

procedure SCalendar.SetFocusedCellColor(Value : TColor);

begin

If Value <> FFocusedCellColor Then Begin

FFocusedCellColor := Value;

DrawGrid;

End;

end;

 

procedure SCalendar.DrawGrid;

Var

temp : TMyDate;

i , j , k , m , t : Integer;

ti , tj : Integer;

Ar : Array [1..42] Of Integer;

CellCheck : Array [1..42] Of Boolean;

CellColor : Array [1..42] Of TColor;

p : Integer;//positon of cursor over Ar

begin

temp.Day := 1;

temp.Month := FMah;

temp.Year := FSal;

m := MyWhatDayIsIt(MyDateToString(temp));

If m = 0 Then m := 7;

 

 

If (FMah = 1)AND(IsKabise(FSal-1)) Then

k := 1

Else

k := 0;

 

If FMah = 1 Then

j := 1 //12

Else

j := 0;

If (FSal = 0)AND(FMah = 1)Then Begin

For i := 1 To m Do Begin

Ar[i] := DPM[FMah+j*12-1]-m+i+k;

CellCheck[i] := False;

CellColor[i] := DisableColor;

End;

End Else

For i := 1 To m Do Begin

Ar[i] := DPM[FMah+j*12-1]-m+i+k;

CellCheck[i] := IsOffDay(IntToStr(FSal-j)+'/'+IntToStr(FMah-1+j*12)+

'/'+IntToStr(Ar[i]));

If CellCheck[i] Then

CellColor[i] := OffDayColor

Else

CellColor[i] := DisableColor;

End;

p := m+1;

 

If (FMah = 12)AND(IsKabise(FSal)) Then

k := 1

Else

k := 0;

t := 0;

 

For i := 1 To DPM[FMah]+k Do Begin

Ar[p+i-1] := i;

CellCheck[p+i-1] := IsOffDay(IntToStr(FSal)+'/'+IntToStr(FMah)+

'/'+IntToStr(i));

If i = FDay Then

t := p+i-1;

If CellCheck[p+i-1] Then

CellColor[p+i-1] := OffDayColor

Else

CellColor[p+i-1] := EnableColor;

End;

p := p+DPM[FMah]+k;

j := 0;

If FMah = 12 Then

j := 1;

For i := p To 42 Do Begin

Ar[i] := i-p+1;

CellCheck[i] := IsOffDay(IntToStr(FSal+j)+'/'+IntToStr(FMah+1-12*j)+

'/'+IntToStr(Ar[i]));

If CellCheck[i] Then

CellColor[i] := OffDayColor

Else

CellColor[i] := DisableColor;

End;

i := 0;

j := 1;

ti := 0;

tj := 1;

For k := 1 To 42 Do Begin

FStringGrid.Cells[i , j] := IntToStr(Ar[k]);

FStringGrid.FCellDates[i , j] := Ar[k];

If (k = t)Then Begin

ti := i;

tj := j;

End;

FStringGrid.FCellColors[i , j] := CellColor[k];

Inc(i);

If i = 7 Then Begin

i := 0;

Inc(j);

End;

End;

DrawGridForcesExit := True;

FStringGrid.Col := ti;

DrawGridForcesExit := True;

FStringGrid.Row := tj;

DrawGridForcesExit := False;

 

FTodayLabel.Caption := Today;

FMonthLabel.Caption := MonthNames[temp.Month];

FYearLabel.Caption := '13'+ ConvertTo2Letter(temp.Year);

end;

 

procedure SCalendar.SetToday(Value : String);

begin

If Not CheckDate(Value) Then Exit;

FToday := Value;

 

FDay := StrToInt(Copy(Value , 9 , 2));

FMah := StrToInt(Copy(Value , 6 , 2));

FSal := StrToInt(Copy(Value , 3 , 2));

SendMessage(FUpDown.Handle , UDM_SETPOS , 0 , FMah);

FTodayLabel.Caption := FToday;

FDayFMahFSalChanged;

end;

 

function SCalendar.GetToday : String;

begin

Result := FToday;

end;

 

function SCalendar.ConvertTo2Letter(i : Integer) : String;

var s : String;

Begin

s := IntToStr(i);

If Length(s) = 2 Then

Result := s

Else

Result := '0' + s;

End;

 

function SCalendar.MyDateToString(FDate : TMyDate): String;

begin

Result := '13'+ConvertTo2Letter(Fdate.Year)+'/'

+ConvertTo2Letter(Fdate.Month)+'/'

+ConvertTo2Letter(Fdate.Day);

end;

 

function SCalendar.StringToTMyDate(FDate : String):TMyDate;

begin

Result.Day := StrToInt(Copy(FDate , 9 , 2));

Result.Month := StrToInt(Copy(FDate , 6 , 2));

Result.Year := StrToInt(Copy(FDate , 3 , 2));

end;

 

procedure SCalendar.Exchange(var t1 , t2 : TMyDate);

var temp : TMyDate;

begin

temp := t1;

t1 := t2;

t2 := temp;

end;

 

function SCalendar.MyWhatDayIsIt(t1 : String): Byte;

Var i : Integer;

t2 : String;

begin

Result := 0;

If NOT CheckDate(t1) Then Exit;

t2 := RefrenceTime;

i := Dec(t1 , t2);

i := i Mod 7;

If i < 0 Then Inc(i , 7);

Result := i;

end;

 

function SCalendar.WhatDayIsIt(t1 : String): String;

begin

Result := WeeksDays[MyWhatDayIsIt(t1)];

end;

 

function SCalendar.CheckDate(var FDate : String): Boolean;

 

function SetDay(Value , month , year : String):boolean;

Var i : Integer;

m : Integer;

y : Integer;

b : Boolean;

begin

Result := True;

try

i := StrToInt(Value);

m := StrToInt(month);

y := StrToInt(year);

b := True; //date is right --> true

If (m = 12)AND(i = 30)Then Begin

If Not IsKabise(y) Then

b := False;

End;

If Not b Then Begin

MessageDlg('.&atilde;&Ccedil;&aring; &Ccedil;&Oacute;&Yacute;&auml;&Iuml; &Yacute;&THORN;&Oslash; &Iuml;&Ntilde; &Oacute;&Ccedil;&aacute;&aring;&Ccedil;&iacute; &szlig;&Egrave;&iacute;&Oacute;&aring; 30 &Ntilde;&aelig;&Ograve;&aring; &Ccedil;&Oacute;&Ecirc;' , mtError,[mbOk],0);

Result := False;

Exit;

End;

 

If Not((i > 0)AND( ((m <=6)AND(i < 32)) OR ((m >6)AND(i < 31)))AND(b)) Then Begin

Result := False;

MessageDlg('.&Ntilde;&aelig;&Ograve; &Ccedil;&Ocirc;&Ecirc;&Egrave;&Ccedil;&aring; &aelig;&Ccedil;&Ntilde;&Iuml; &Ocirc;&Iuml;&aring; &Ccedil;&Oacute;&Ecirc;',mterror,[mbok],0);

Exit;

End;

except

Result := False;

MessageDlg('.&Ecirc;&Ccedil;&Ntilde;&iacute;&Icirc  ; &Ccedil;&Ocirc;&Ecirc;&Egrave;&Ccedil;&aring; &aelig;&Ccedil;&Ntilde;&Iuml; &Ocirc;&Iuml;&aring; &Ccedil;&Oacute;&Ecirc;',mterror,[mbok],0);

end;

end;

 

function SetMonth(Value : String): Boolean;

Var i : Integer;

begin

Result := True;

try

i := StrToInt(Value);

If Not((i > 0)AND(i < 13)) Then Begin

MessageDlg('.&atilde;&Ccedil;&aring; &Ccedil;&Ocirc;&Ecirc;&Egrave;&Ccedil;&aring; &aelig;&Ccedil;&Ntilde;&Iuml; &Ocirc;&Iuml;&aring; &Ccedil;&Oacute;&Ecirc;',mterror,[mbok],0);

Result := False;

Exit;

End;

except

Result := False;

MessageDlg('.&atilde;&Ccedil;&aring; &Ccedil;&Ocirc;&Ecirc;&Egrave;&Ccedil;&aring; &aelig;&Ccedil;&Ntilde;&Iuml; &Ocirc;&Iuml;&aring; &Ccedil;&Oacute;&Ecirc;',mterror,[mbok],0);

end;

end;

 

function SetYear(Value : String): Boolean;

begin

Result := True;

try

StrToInt(Value);

except

Result := False;

MessageDlg('.&Oacute;&Ccedil;&aacute; &Ccedil;&Ocirc;&Ecirc;&Egrave;&Ccedil;&aring; &aelig;&Ccedil;&Ntilde;&Iuml; &Ocirc;&Iuml;&aring; &Ccedil;&Oacute;&Ecirc;',mterror,[mbok],0);

end;

end;

Var

s , t : String;

i : Integer;

ResDate : STring;

begin

Result := False;

ResDate := '';

s := FDate;

t := Copy(s , 1 ,Pos('/' , s)-1);

i := Length(t);

If NOT SetYear(t) Then

Exit;

If i > 2 Then

Delete(t , 1 , i-2);

If i = 1 Then

t := '0'+t;

ResDate := '13'+ t;

Delete(s , 1 , i+1);

t := Copy(s , 1 ,Pos('/' , s)-1);

i := Length(t);

If NOT SetMonth(t) Then

Exit;

If i = 1 Then

t := '0'+t;

ResDate := ResDate + '/' + t;

Delete(s , 1 , i+1);

If NOT SetDay(s , Copy(ResDate , 6 , 2) , Copy(ResDate , 3 ,2)) Then

Exit;

If Length(s) = 1 Then

s := '0' + s;

ResDate := ResDate + '/' +s;

Result := True;

FDate := ResDate;

end;

 

function SCalendar.StrTo10CharFormat(s : String):String;

begin

Result := '';

If Length(s)<5 Then Begin

MessageDlg('.&Oslash;&aelig;&aacute; &Ntilde;&Ocirc;&Ecirc;&aring; &Egrave;&Ccedil;&iacute;&Iuml; &Iacute;&Iuml;&Ccedil;&THORN;&aacute; &Egrave;&Ntilde;&Ccedil;&Egrave;&Ntilde; 6 &Egrave;&Ccedil;&Ocirc;&Iuml;',mtError ,[mbOk],0);

Exit;

End;

If NOT CheckDate(s) Then

Exit;

Result := s;

end;

 

function SCalendar.Compare(t1 , t2 : TMYDate) : Integer;// 0 : Equal

// 1 : t1 > t2

// 2 : t1 < t2

begin

Result := 0;

If (t1.Year = t2.Year)AND(t1.Month = t2.Month)AND(t1.Day = t2.Day) Then Exit;

If (t1.Year > t2.Year)

OR((t1.Year = t2.Year)AND(t1.Month > t2.Month))

OR((t1.Year = t2.Year)AND(t1.Month = t2.Month)AND(t1.Day > t2.Day))Then

Result := 1

Else

Result := 2;

end;

 

function SCalendar.Intersect(Date1,Date2,Date3,Date4 : String;var Date5,Date6 : String):Integer;

var 

t1 , t2 , t3 , t4 , r1 , r2: TMyDate;

begin

Result := -1;

If Not CheckDate(Date1) Then Exit;

If Not CheckDate(Date2) Then Exit;

If Not CheckDate(Date3) Then Exit;

If Not CheckDate(Date4) Then Exit;

t1 := StringToTMyDate(Date1);

t2 := StringToTMyDate(Date2);

t3 := StringToTMyDate(Date3);

t4 := StringToTMyDate(Date4);

If Compare(t1 , t2) = 1 Then Exchange(t1 , t2);

If Compare(t3 , t4) = 1 Then Exchange(t3 , t4);

r1 := t1;

r2 := t4;

If Compare(t2 , t4) = 1 Then Begin

r2 := t4;

If Compare(t1 , t3) = 1 Then

r1 := t1

Else

r1 := t3;

End Else

Begin

r2 := t2;

If Compare(t1 , t3) = 1 Then

r1 := t1

Else

r1 := t3;

End;

If Compare(r1 , r2) = 1 Then

r2 := r1;

Result := Dec(MyDateToString(r1) , MyDateToString(r2));

Date5 := MyDateToString(r1);

Date6 := MyDateToString(r2);

end;

 

function SCalendar.DayBetweenToDays(day , t1 , t2 : TMyDate) : Boolean;

Var

i : Integer;

e : Integer;

begin

Result := True;

e := Compare(t1 , t2);

If (e = 0)AND(Compare(day , t1)= 0) Then Begin

Exit;

End

Else If e = 2 Then Exchange(t1 , t2);

i := Compare(t1 , day);

If i = 2 Then Begin

Result := False;

Exit;

End;

i := Compare(day , t2);

If i = 2 Then Begin

Result := False;

Exit;

End;

end;

 

function SCalendar.WorkDays(Date1 , Date2 : String) : Integer;

var i , j : Integer;

t1 , t2 : TMyDate;

begin

j := 0;

Result := -1;

If Not CheckDate(Date1) Then Exit;

If Not CheckDate(Date2) Then Exit;

t1 := StringToTMyDate(Date1);

t2 := StringToTMyDate(Date2);

For i := 0 To OffDays.Count-1 Do

If DayBetweenToDays(StringToTMyDate(OffDays[i]) , t1 , t2) Then

Inc(j);

i := Dec(Date1 , Date2);

i := i-j;

Result := i;

end;

 

function SCalendar.Dec(Date1 , Date2 : String) : Integer;

Var

d , d2 , i , m1 , m2 : Integer;

y1 , y2 : Integer;

e : Integer;

Leaps : Array [1..28] Of Integer;

LeapLen : Integer;

t1 , t2 : TMyDate;

begin

Result := -1;

If Not CheckDate(Date1) Then Exit;

If Not CheckDate(Date2) Then Exit;

t1 := StringToTMyDate(Date1);

t2 := StringToTMyDate(Date2);

e := Compare(t1 , t2);

If e = 0 Then Begin

Result := 0;

Exit;

End

Else If e = 2 Then Exchange(t1 , t2);

LeapLen := 0;

For i := 0 To 99 Do

If IsKabise(i) Then Begin

Leaps[LeapLen+1] := i;

Inc(LeapLen);

End;

d := (t1.Year-t2.Year)*365;

y1 := 0;

y2 := 0;

For i := 1 To LeapLen Do

If t2.Year <= Leaps[i] Then Begin

y1 := i;

Break;

End;

For i := y1 To LeapLen Do

If t1.Year <= Leaps[i] Then Begin

y2 := i-1;

Break;

End;

d := d + (y2 - y1 +1);

If t1.Month >= t2.Month Then Begin

m1 := t2.Month;

m2 := t1.Month;

d2 := (t1.Day - t2.Day);

End Else

Begin

m2 := t2.Month;

m1 := t1.Month;

d2 := (t2.Day - t1.Day);

End;

// d2 := 0;

For i := m1 To m2-1 Do

d2:= d2 + DPM[i];

If t1.Month >= t2.Month Then

d := d + d2

Else

d := d - d2;

If e = 2 Then d := d *(-1);

Result := d;

end;

 

Function SCalendar.ToFarsiDate(eng_date : string):String;

var

year,month,day,f_year,f_month,f_day,lastday,

plus,minus,intercalary : integer;

strg : string;

m,Ret:string;

i : Integer;

begin

strg:=eng_date;

plus := 0;

i := Pos('/' , eng_date)-1;

year := StrToInt(Copy(eng_date , 1 , i));

Delete(eng_date , 1 , i+1);

i := Pos('/' , eng_date)-1;

month := StrToInt(Copy(eng_date , 1 , i));

Delete(eng_date , 1 , i+1);

day := StrToInt(eng_date);

case month of

1,5,6 : plus := 10;

2,4 : plus := 11;

3,7,8,9,11,12: plus := 9;

10 : plus := 8;

end;

 

year := year mod 100;

 

intercalary := year ;

 

 

if (intercalary mod 4 = 0) then

if (month > 2) then plus := plus + 1;

 

 

if ((intercalary-1) mod 4 = 0) then

begin

lastday := 30;

if (month <= 3) then plus := plus + 1;

end

else lastday := 29;

 

f_year := year - 22;

if (f_year < 0) then f_year:=f_year+100;

 

f_month := month + 9;

if (f_month > 12) then

begin

f_month:=f_month-12;

inc(f_year);

end;

 

f_day := day+plus;

if (f_month <= 6) then minus:=31

else if (f_month>6) and (f_month<12) then minus:=30

else minus:=lastday;

 

if (f_day>minus) then

begin

f_day:=f_day-minus;

inc(f_month);

end;

 

if (f_month > 12) then

begin

f_month:=f_month-12;

inc(f_year);

end;

 

m := '00';

strg := '00';

If f_year >= 10 Then

str(f_year,m)

Else Begin

m[1] := '0';

strg := IntToStr(f_year);

m[2] := strg[1];

End;

Ret:=m+'/';

If f_month >= 10 Then

str(f_month,m)

Else Begin

m[1] := '0';

strg := IntToStr(f_month);

m[2] := strg[1];

End;

Ret:=Ret+m+'/';

If f_day >= 10 Then

str(f_day,m)

Else Begin

m[1] := '0';

strg := IntToStr(f_day);

m[2] := strg[1];

End;

Ret:=Ret+m;

Result := '13'+Ret;

end;

 

 

{TColor2DOpenArray Class}

procedure TColor2DOpenArray.SetArrayLength(ACol,ARow : Integer);

begin

SetLength(FArray , ACol , ARow);

FColCount := ACol;

FRowCount := ARow;

end;

 

procedure TColor2DOpenArray.SetColCount(Value : Integer);

begin

If (Value < 0)OR(Value = FColCount)Then Exit;

SetArrayLength(Value , FRowCount);

end;

 

procedure TColor2DOpenArray.SetRowCount(Value : Integer);

begin

If (Value < 0)OR(Value = FRowCount)Then Exit;

SetArrayLength(FColCount , Value);

end;

 

Constructor TColor2DOpenArray.Create(AOwner : TComponent);

begin

inherited Create(AOwner);

end;

 

Destructor TColor2DOpenArray.Destroy;

begin

FArray := nil;

inherited Destroy;

end;

 

procedure TColor2DOpenArray.SetItem(ACol,ARow : Integer ; Value : TColor);

begin

If (ARow>=0)AND(ARow<FRowCount)AND(ARow>=0)AND(ARow<F  RowCount) Then

FArray[ACol , ARow] := Value;

end;

 

function TColor2DOpenArray.GetItem(ACol,ARow : Integer) : TColor;

begin

If (ARow>=0)AND(ARow<FRowCount)AND(ARow>=0)AND(ARow<F  RowCount) Then

Result := FArray[ACol , ARow]

Else

Result := MaxInt;

end;

 

 

procedure Register;

begin

RegisterComponents('Samples', [TFarsiCalendar]);

end;

 

end.

متاسفانه مثل اینکه فونت فارسی بصورت هیروگلیف ظاهر شده ...
واسه همین ، سورس کدش را آپلود میکنم ...
( سورس کد حذف شد ! حداقل زحمت Copy-Paste ش را بکشید ! )

[amehrabi]

شما یه سر به سایت www.oxinsoft.com بزنید . اونجا یک dll هست که کار شما رو راه می اندازه .

[m-khorsandi]

دوست عزیز،
شما با استفاده از تابع DayOfWeek از یونیت SysUtils یا تابع DayOfWeekStr از یونیت HttpApp میتونید
روز هفته رو بدست بیارید. تابع DayOfWeek یه پارامتر از نوع TDataTime (تاریخ/ساعت)میگیره و خروجی اون
از نوع Integer که عددی بین 1 تا 7 هست ، میباشد . شما میتونید یک متغیر یا ثابت آرایه ایی که شامل روزهای
هفته ایرانی یا انگلیسی هست تعریف کنید و خیلی راحت مقدار رشته ایی روز مورد نظر رو بدست بیارید.

در مورد DayOfWeekStr هم باید بگم که این تابع هم پارامتری از نوع TDateTime میگیره ولی خروجی اون دقیقا"
مقدار رشته ایی روز مورد نظر هست مانند Sun, Mon ,...

  DayOfWeek(Now());

DayOfWeekStr(Now());

[babak869]

با سلام
بله یه Dll هست که توابع بسیار خوبی داره اما متاسفانه نمیتونم ازون در دلفی استفاده کنم.چون برای وی بی نوشته شده از دوستان اگه میتونند کمک کنند
ممنونم

[m-khorsandi]

Const

  IRDaysOfWeek: array[1..7] of string = (

'یکشنبه', 'دوشنبه', 'سه شنبه', 'چهارشنبه', 'پنجشنبه', 'جمعه', 'شنبه')



procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowMessage(IRDaysOfWeek[DayOfWeek(Now())]);

end;

[Developer Programmer]

اگه می خواین همانند برنامه زیر رو تولید کنید، به کاربر SalarSoft پیغام خصوصی (PM) بزنید
خوش باشید

[niloofar_taieban]

سلام دوستان. از اینکه جواب دادید خیلی ممنونم.
آقای بابک عقیلی ممنون می شم اگه برنامه رو همراه با فرمش بفرستید.فایل zipiکه گذاشتید فقط شامل unitهست.

[MiRHaDi]

سلام
بابک عقیلی ! مثل شادمهر عقیلی ! :)
سالار سافت هم که آلود کرده و لینک گذاشته
امیدوارم برنامه ایشون درست باشه که انشاءلله باشه
ولی من سورس آقا کامبیز خجسته رو ترجیه میدم
یا علی

[Babak-Aghili]

بابک عقیلی ! مثل شادمهر عقیلی

آ آ آ !! عقیلی_ شادمهر عقیلی را مثل عقیلی_ بابک عقیلی مینویسند! نه برعکس!

آقای بابک اقیلی ممنون می شم اگه برنامه رو همراه با فرمش بفرستید.فایل zipiکه گذاشتید فقط شامل unitهست

خب سورس کامپوننت را گذاشتم دیگه !
نصبش کن ! منوی Component -> Install Component ->Browse buttn in Unit File Name
بعدش در تب Sample نصب میشه ... enjoy

.
.
درحاشیه: من یک مقدار شما را Trace !! کردم .. شکارچی کامپوننت خوبی هستین !

[babak869]

کسی با اون Dll کار نکرده؟
اگه جواب مثبته لطفا کمی توضیح بدید
متشکرم

[Bahmany]

از گذاشتن سورس ممنونم

[SalarSoft]

اگه خواستین می تونین از این کامپوننت استفاده کنیین:
http://www.salarsoft.somee.com/downl....htm#farsidate

به این صورت

TFarDate.farFormatDateTime('dddd dd mmmm سال yyyy', TFarDate.MiladyToShamsi(now))

که به شما این رو میده: شنبه 2 بهمن سال 1384

برای دریافت مستقیم هم میتونید از توابع farDayString و farMonthString استفاده کنید.

[niloofar_taieban]

سلام دوستان از جواب هاتو ن خیلی ممنونم.همینطور از غلط دیکته هاتون. ولی اشتباه تایپی بود چون بینهایت با عجله این پست رو تایپ و ارسال کردم.

آقای عقیلی اگه شما خواستید باز هم trace کنید باید بگم من قبلا با نام کاربری نیلوفر طیبان وارد سایت می شدم و با اون نام کاربری هم کامپوننت جمع کردم.
بازم ازتون ممنون و سپاسگزارم. :لبخندساده

[اَرژنگ]

آ آ آ !! عقیلی_ شادمهر عقیلی را مثل عقیلی_ بابک عقیلی مینویسند! نه برعکس!

شادمهر عقیلی کیه؟