BaiduFMX

1
// ***************************************************************************
2
//
3
// FMXComponents: Firemonkey Opensource Components Set
4
//
5
// CalendarControl is a calendar component like iOS style, it uses
6
// listview component internally
7
//
8
// This component come from xubzhlin's FMX-UI-Controls, collect and
9
// arrange by the author's agreement
10
// The original project at: https://github.com/xubzhlin/FMX-UI-Controls
11
//
12
// 该控件来自 xubzhlin的FMX-UI-Controls项目，经作者同意进行收集整理
13
// 原项目地址为：https://github.com/xubzhlin/FMX-UI-Controls
14
//
15
//  https://github.com/zhaoyipeng/FMXComponents
16
//
17
// ***************************************************************************
18
// version history
19
// 2017-09-11, v0.1.0.0 :
20
//    first release
21
//    rename component to TFMXCalendarControl
22
//    add  properties Align, Anchors, ClipChildren, ClipParent, Cursor
23
//                    DragMode, EnableDragHighlight, Enabled, Height, HitTest
24
//                    Locked, Padding, Opacity, Margins, PopupMenu, Position
25
//                    RotationAngle, RotationCenter, Scale, Size, Visible, Width
26
//    fixed FWeekLayout and FCalenderView stored problem
27
// 2017-09-11, v0.2.0.0 :
28
//    add lunar date option
29
// 2017-09-11, v0.3.0.0 :
30
//    fixed the bug when EndDate's month is December
31
//    add set month names method
32
// 2018-01-10, v0.4.0.0 :
33
//    add English day support, add Lang property
34

35
unit FMX.CalendarControl;
36

37
interface
38

39
uses
40
  System.Classes,
41
  System.SysUtils,
42
  System.Types,
43
  System.UITypes,
44
  System.DateUtils,
45
  FMX.Platform,
46
  FMX.Controls,
47
  FMX.Layouts,
48
  FMX.Types,
49
  FMX.Calendar,
50
  FMX.ListView,
51
  FMX.ListView.Types,
52
  FMX.CalendarItemAppearance,
53
  FMX.ComponentsCommon;
54

55
type
56
  TWeekNames = array [1..7] of string;
57
  TMonthNames = array [1..12] of string;
58

59
const
60
  TCnWeeks: TWeekNames = ('日', '一', '二', '三', '四', '五', '六');
61
  TEnWeeks: TWeekNames = ('SUN', 'MON', 'TUE', 'WED', 'THU', 'FRI', 'SAT');
62
  TEsWeeks: TWeekNames = ('dom', 'lun', 'mar', 'mié', 'jue', 'vie', 'sáb');
63
  TRuWeeks: TWeekNames = ('ВС', 'ПН', 'ВТ', 'СР', 'ЧТ', 'ПТ', 'СБ');
64

65
  TCnMonths: TMonthNames = ('一月', '二月', '三月', '四月', '五月', '六月',
66
    '七月', '八月', '九月', '十月', '十一月', '十二月');
67
  TEnMonths: TMonthNames = (
68
    'January',
69
    'February',
70
    'March',
71
    'April',
72
    'May',
73
    'June',
74
    'July',
75
    'August',
76
    'September',
77
    'October',
78
    'November',
79
    'December'
80
  );
81
  TEsMonths: TMonthNames = (
82
    'Enero', 'Febrero', 'Marzo', 'Abril', 'Mayo', 'Junio',
83
    'Julio', 'Agosto', 'Septiembre', 'Octubre', 'Noviembre', 'Ciciembre');
84

85
  TRuMonths: TMonthNames = ('Январь', 'Февраль', 'Март', 'Апрель', 'Май',
86
    'Июнь', 'Июль', 'Август', 'Сентябрь', 'Октябрь', 'Ноябрь', 'Декабрь');
87

88
type
89
  TWeekLayout = class(TControl)
90
  private
91
    FWeekNames: TWeekNames;
92
    procedure DoDrawDay(LocRect:TRectF; AIndex:Integer);
93
  protected
94
    procedure Paint; override;
95
    procedure SetWeekNames(const Names: TWeekNames);
96
  end;
97

98
  [ComponentPlatformsAttribute(TFMXPlatforms)]
99
  TFMXCalendarControl = class(TControl)
100
  private
101
    FFirstDayOfWeekNum:Integer;
102
    FWeekLayout:TWeekLayout;
103
    FCalenderView:TCalenderView;
104

105
    FSelectedItem:TClendarDayItem;
106
    FIsClickDayItem:Boolean;
107
    FAtPoint:TPointF;
108
    FOnGetItemIsMark:TOnGetItemIsMark;
109
    FOnSelectedItem:TNotifyEvent;
110

111
    FNeedFillDays:Boolean;
112
    FStartDate: TDate;
113
    FEndDate: TDate;
114
    FIsShowLunarDate: Boolean;
115
    FMonthNames: TMonthNames;
116
    FLang: string;
117
    procedure SetSelectedDate(const Value: TDate);
118
    function DefineItemIndexOfFirstDayInMonth(ADate:TDate):Integer;
119
    procedure FillDays;
120
    procedure DoCalenderViewMouseDown(Sender:TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
121
    procedure DoCalenderViewMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
122
    procedure DoCalenderViewItemClickEx(const Sender: TObject; ItemIndex: Integer; const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
123
    procedure DoGetItemIsMark(ADayItem:TClendarDayItem; var AIsMark:Boolean);
124
    function GetSelectedDate: TDate;
125
    procedure SetEndDate(const Value: TDate);
126
    procedure SetStartDate(const Value: TDate);
127
    procedure SetIsShowLunarDate(const Value: Boolean);
128
    procedure SetFirstDayOfWeekNum(const Value: Integer);
129
    procedure SetLang(const Value: string);
130
  protected
131
    procedure Paint; override;
132
  public
133
    constructor Create(AOwner: TComponent); override;
134
    procedure SetMonthNames(const Names: TMonthNames; IsRepaint: Boolean = True);
135
    procedure SetWeekNames(const Names: TWeekNames; IsRepaint: Boolean = True);
136
  published
137
    property Align;
138
    property Anchors;
139
    property ClipChildren default False;
140
    property ClipParent default False;
141
    property Cursor default crDefault;
142
    property DragMode default TDragMode.dmManual;
143
    property EnableDragHighlight default True;
144
    property Enabled default True;
145
    property Height;
146
    property HitTest default True;
147
    property Locked default False;
148
    property Padding;
149
    property Opacity;
150
    property Margins;
151
    property PopupMenu;
152
    property Position;
153
    property RotationAngle;
154
    property RotationCenter;
155
    property Scale;
156
    property Size;
157
    property Visible default True;
158
    property Width;
159
    property Lang: string read FLang write SetLang;
160
    property StartDate:TDate read FStartDate write SetStartDate;
161
    property EndDate:TDate read FEndDate write SetEndDate;
162
    property FirstDayOfWeek:Integer read FFirstDayOfWeekNum write SetFirstDayOfWeekNum;
163
    property SelectedDate:TDate read GetSelectedDate write SetSelectedDate;
164
    property IsShowLunarDate: Boolean read FIsShowLunarDate write SetIsShowLunarDate default true;
165
    property OnGetItemIsMark:TOnGetItemIsMark read FOnGetItemIsMark write FOnGetItemIsMark;
166
    property OnSelectedItem:TNotifyEvent read FOnSelectedItem write FOnSelectedItem;
167
  end;
168

169
implementation
170

171
{ TWeekLayout }
172

173
procedure TWeekLayout.DoDrawDay(LocRect: TRectF; AIndex: Integer);
174
begin
175
  Canvas.Fill.Color:=$FF000000;
176
  Canvas.FillText(LocRect, FWeekNames[AIndex], False , 1, [], TTextAlign.Center, TTextAlign.Center);
177
end;
178

179
procedure TWeekLayout.Paint;
180
var
181
  i: Integer;
182
  ARect:TRectF;
183
  OffSetX:Single;
184
begin
185
  OffSetX:=ClipRect.Width / 7;
186
  ARect.Top:=ClipRect.Top;
187
  ARect.Left:=ClipRect.Left;
188
  ARect.Height:=ClipRect.Height;
189
  ARect.Width:= OffSetX;
190
  for i := 1 to 7 do
191
  begin
192
    DoDrawDay(ARect, i);
193
    ARect.Offset(OffSetX, 0);
194
  end;
195
end;
196

197
procedure TWeekLayout.SetWeekNames(const Names: TWeekNames);
198
var
199
  I: Integer;
200
begin
201
  for I := Low(Names) to High(Names) do
202
  begin
203
    FWeekNames[I] := Names[I];
204
  end;
205
end;
206

207
{ TCalendarControl }
208

209
constructor TFMXCalendarControl.Create(AOwner: TComponent);
210
var
211
  LocaleService:IFMXLocaleService;
212
begin
213
  inherited;
214
  //默认 最近两个月
215
  FStartDate := Now;
216
  FEndDate := IncMonth(Now, 1);
217

218
  FSelectedItem := nil;
219

220
  if TPlatformServices.Current.SupportsPlatformService(IFMXLocaleService, LocaleService) then
221
    FFirstDayOfWeekNum := LocaleService.GetFirstWeekday
222
  else
223
    FFirstDayOfWeekNum := DayMonday;
224

225
  FWeekLayout := TWeekLayout.Create(Self);
226
  FWeekLayout.Height := 28;
227
  FWeekLayout.Stored := False;
228
  FWeekLayout.Align := TAlignLayout.Top;
229
  FWeekLayout.Parent := Self;
230

231
  FCalenderView := TCalenderView.Create(Self);
232
  FCalenderView.Stored := False;
233
  FCalenderView.Align := TAlignLayout.Client;
234
  FCalenderView.OnMouseDown := DoCalenderViewMouseDown;
235
  FCalenderView.OnMouseMove := DoCalenderViewMouseMove;
236
  FCalenderView.OnItemClickEx := DoCalenderViewItemClickEx;
237
  FCalenderView.OnGetItemIsMark := DoGetItemIsMark;
238
  FCalenderView.ItemAppearanceName := 'ClendarDayListItem';
239
  FCalenderView.CanSwipeDelete := False;
240
  FCalenderView.ShowSelection := False;
241
  FCalenderView.Parent := Self;
242

243
  FWeekLayout.Margins.Left := FCalenderView.ItemSpaces.Left;
244
  FWeekLayout.Margins.Right := FCalenderView.ItemSpaces.Right;
245

246
  FNeedFillDays:=True;
247
  FLang := 'zh';
248
  SetMonthNames(TCnMonths, False);
249
  SetWeekNames(TCnWeeks, False);
250
end;
251

252
function TFMXCalendarControl.DefineItemIndexOfFirstDayInMonth(ADate:TDate): Integer;
253
var
254
  Interval: Integer;
255
  BeginDate: TDateTime;
256
begin
257
  Interval := DaysPerWeek - FFirstDayOfWeekNum;
258
  BeginDate := RecodeDay(ADate, 1);
259
  Result := (Interval + DayOfTheWeek(BeginDate)) mod DaysPerWeek;
260
end;
261

262
procedure TFMXCalendarControl.DoCalenderViewItemClickEx(const Sender: TObject;
263
  ItemIndex: Integer; const LocalClickPos: TPointF;
264
  const ItemObject: TListItemDrawable);
265
begin
266
  if FIsClickDayItem and (ItemObject is TClendarDayItem) then
267
  begin
268
    if TClendarDayItem(ItemObject).Day = 0 then exit;
269
    if FSelectedItem <> nil then
270
      FSelectedItem.IsSelected := False;
271
    FSelectedItem := TClendarDayItem(ItemObject);
272
    FSelectedItem.IsSelected := True;
273
    if Assigned(FOnSelectedItem) then
274
      FOnSelectedItem(FSelectedItem);
275
  end;
276
end;
277

278
procedure TFMXCalendarControl.DoCalenderViewMouseDown(Sender: TObject;
279
  Button: TMouseButton; Shift: TShiftState; X, Y: Single);
280
begin
281
  FIsClickDayItem := True;
282
  FAtPoint := TPointF.Create(X, Y);
283
end;
284

285
procedure TFMXCalendarControl.DoCalenderViewMouseMove(Sender: TObject;
286
  Shift: TShiftState; X, Y: Single);
287
begin
288
  if FIsClickDayItem then
289
  begin
290
    // 偏移了10 认为不是点击
291
    if (Abs(FAtPoint.X - X) > 10) or (Abs(FAtPoint.Y - Y) > 10) then
292
      FIsClickDayItem := False;
293
  end;
294
end;
295

296
procedure TFMXCalendarControl.DoGetItemIsMark(ADayItem: TClendarDayItem; var AIsMark: Boolean);
297
begin
298
  if Assigned(FOnGetItemIsMark) then
299
    FOnGetItemIsMark(ADayItem, AIsMark);
300
end;
301

302
procedure TFMXCalendarControl.FillDays;
303
var
304
  FDate, LastDate: TDate;
305
  First: Word;
306
  Year: Word;
307
  ItemIndex, NewIndex:Integer;
308
  AItem:TClendarWeekListViewItem;
309
  procedure FillDaysOfMonth(ADate:TDate);
310
  var
311
    DaysInMonthTmp: Word;
312
    Day:Word;
313
    I: Word;
314
  begin
315
    //FillMonth
316
    ItemIndex := -1;
317
    DaysInMonthTmp := DaysInMonth(ADate);
318
    for I := First to First + DaysInMonthTmp - 1 do
319
    begin
320
      NewIndex := i div 7;
321
      if NewIndex > ItemIndex then
322
      begin
323
        AItem := TClendarWeekListViewItem(FCalenderView.Items.Add);
324
        ItemIndex := NewIndex;
325
      end;
326
      Day:= I - First + 1;
327
      case (i+FFirstDayOfWeekNum) mod 7 of
328
        0: AItem.SunDayItem.Day := Trunc(RecodeDay(ADate, Day));
329
        1: AItem.MonDayItem.Day := Trunc(RecodeDay(ADate, Day));
330
        2: AItem.TurDayItem.Day := Trunc(RecodeDay(ADate, Day));
331
        3: AItem.WedDayItem.Day := Trunc(RecodeDay(ADate, Day));
332
        4: AItem.ThuDayItem.Day := Trunc(RecodeDay(ADate, Day));
333
        5: AItem.RuiDayItem.Day := Trunc(RecodeDay(ADate, Day));
334
        6: AItem.SatDayItem.Day := Trunc(RecodeDay(ADate, Day));
335
      end;
336
    end;
337
  end;
338
  procedure FillMonth(ADate:TDate);
339
  var
340
    AYear:Word;
341
  begin
342
    AYear := YearOf(ADate);
343
    //FillYear
344
    if (Year = 0) or (AYear <> Year) then
345
    begin
346
      Year:=AYear;
347
      AItem:=TClendarWeekListViewItem(FCalenderView.Items.Add);
348
      AItem.Height := 28;
349
      AItem.YearItem.Year := Year;
350
    end;
351
    AItem := TClendarWeekListViewItem(FCalenderView.Items.Add);
352
    AItem.Text := FMonthNames[MonthOf(ADate)];
353
    First := DefineItemIndexOfFirstDayInMonth(ADate);
354
//    case (First + FFirstDayOfWeekNum) mod 7 of
355
//      0: AItem.Objects.TextObject.PlaceOffset.X := AItem.SunDayItem.PlaceOffset.X;
356
//      1: AItem.Objects.TextObject.PlaceOffset.X := AItem.MonDayItem.PlaceOffset.X;
357
//      2: AItem.Objects.TextObject.PlaceOffset.X := AItem.TurDayItem.PlaceOffset.X;
358
//      3: AItem.Objects.TextObject.PlaceOffset.X := AItem.WedDayItem.PlaceOffset.X;
359
//      4: AItem.Objects.TextObject.PlaceOffset.X := AItem.ThuDayItem.PlaceOffset.X;
360
//      5: AItem.Objects.TextObject.PlaceOffset.X := AItem.RuiDayItem.PlaceOffset.X;
361
//      6: AItem.Objects.TextObject.PlaceOffset.X := AItem.SatDayItem.PlaceOffset.X;
362
//    end;
363
    FillDaysOfMonth(ADate);
364
  end;
365
begin
366
  FCalenderView.Items.Clear;
367
  FCalenderView.BeginUpdate;
368
  try
369
    Year:=0;
370
    FDate:=FStartDate;
371

372
    while (FDate<EndOfTheMonth(FEndDate)) do
373
    begin
374
      FillMonth(FDate);
375
      FDate := IncMonth(FDate);
376
    end;
377
  finally
378
    FCalenderView.EndUpdate;
379
  end;
380
end;
381

382
function TFMXCalendarControl.GetSelectedDate: TDate;
383
begin
384
  if FSelectedItem = nil then
385
    Result :=Trunc(Now)
386
  else
387
    Result:=FSelectedItem.Day;
388
end;
389

390
procedure TFMXCalendarControl.Paint;
391
begin
392
  if FNeedFillDays then
393
  begin
394
    FillDays;
395
    FNeedFillDays := False;
396
  end;
397
  inherited;
398
end;
399

400
procedure TFMXCalendarControl.SetEndDate(const Value: TDate);
401
begin
402
  if (FEndDate <> Value) and (Value > FStartDate) then
403
  begin
404
    FEndDate := Value;
405
    FNeedFillDays := True;
406
    Repaint;
407
  end;
408
end;
409

410
procedure TFMXCalendarControl.SetFirstDayOfWeekNum(const Value: Integer);
411
begin
412
  if FFirstDayOfWeekNum <> Value then
413
  begin
414
    FFirstDayOfWeekNum := Value;
415
    FNeedFillDays := True;
416
    Repaint;
417
  end;
418
end;
419

420
procedure TFMXCalendarControl.SetSelectedDate(const Value: TDate);
421
var
422
  i: Integer;
423
  AItem: TClendarWeekListViewItem;
424
  LObject: TClendarDayItem;
425
  NewDay:Int64;
426
begin
427
  LObject:=nil;
428
  NewDay:=Trunc(Value);
429
  if (FSelectedItem = nil) or (FSelectedItem.Day <> NewDay) then
430
  begin
431
    if FSelectedItem <> nil then
432
      FSelectedItem.IsSelected := False;
433
    for i := 0 to FCalenderView.Items.Count - 1 do
434
    begin
435
      AItem := TClendarWeekListViewItem(FCalenderView.Items[i]);
436
      LObject := AItem.FindDayItem(NewDay);
437
      if LObject <> nil then
438
      begin
439
        FSelectedItem := LObject;
440
        FSelectedItem.IsSelected := True;
441
        Break;
442
      end;
443
    end;
444
  end;
445
end;
446

447
procedure TFMXCalendarControl.SetIsShowLunarDate(const Value: Boolean);
448
begin
449
  if FIsShowLunarDate <> Value then
450
  begin
451
    FIsShowLunarDate := Value;
452
    Repaint;
453
  end;
454
end;
455

456
procedure TFMXCalendarControl.SetLang(const Value: string);
457
begin
458
  if FLang <> Value.ToLower  then
459
  begin
460
    FLang := Value.ToLower;
461
    if FLang.Equals('en') then
462
    begin
463
      SetMonthNames(TEnMonths, False);
464
      SetWeekNames(TEnWeeks, True);
465
    end
466
    else begin
467
      SetMonthNames(TCnMonths, False);
468
      SetWeekNames(TCnWeeks, True);
469
    end;
470
    Repaint;
471
  end;
472
end;
473

474
procedure TFMXCalendarControl.SetMonthNames(const Names: TMonthNames;
475
  IsRepaint: Boolean);
476
var
477
  I: Integer;
478
begin
479
  for I := Low(Names) to High(Names) do
480
  begin
481
    FMonthNames[I] := Names[I];
482
  end;
483
  if IsRepaint then
484
  begin
485
    FNeedFillDays := True;
486
    Repaint;
487
  end;
488
end;
489

490
procedure TFMXCalendarControl.SetStartDate(const Value: TDate);
491
begin
492
  if (FStartDate <> Value) and (Value < FEndDate) then
493
  begin
494
    FStartDate := Value;
495
    FNeedFillDays := True;
496
    Repaint;
497
  end;
498
end;
499

500
procedure TFMXCalendarControl.SetWeekNames(const Names: TWeekNames;
501
  IsRepaint: Boolean);
502
var
503
  I: Integer;
504
begin
505
  FWeekLayout.SetWeekNames(Names);
506
  if IsRepaint then
507
  begin
508
    FNeedFillDays := True;
509
    Repaint;
510
  end;
511
end;
512

513
end.
514