lunarcal.pas

DELPHI编写的商场收银POS机源代码

  end;
end;

procedure TLunarCal.SetDateElement(Index: Integer; Value: Integer);
var
  AYear, ADay, GYear, GMonth, GDay: Word;
  AMonth: SmallInt;
begin
  if Value > 0 then
  begin
    DecodeLunarDate(FDate, AYear, AMonth, ADay);
    DecodeDate(FDate, GYear, GMonth, GDay);
    case Index of
      1: if GYear <> Value then GYear := Value else Exit;
      2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
      3: if (Value <= LunarDaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
      else Exit;
    end;
    GYear := GetGregYear(GYear, AYear, AMonth);
    FDate := EncodeLunarDate(GYear, AYear, AMonth, ADay);
    FUseCurrentDate := False;
    UpdateCalendar;
    Change;
  end;
end;

procedure TLunarCal.SetStartOfWeek(Value: TDayOfWeek);
begin
  if Value <> FStartOfWeek then
  begin
    FStartOfWeek := Value;
    UpdateCalendar;
  end;
end;

procedure TLunarCal.SetUseCurrentDate(Value: Boolean);
begin
  if Value <> FUseCurrentDate then
  begin
    FUseCurrentDate := Value;
    if Value then
    begin
      FDate := Date; { use the current date, then }
      UpdateCalendar;
    end;
  end;
end;

{ Given a value of 1 or -1, moves to Next or Prev month accordingly }
procedure TLunarCal.ChangeMonth(Delta: Integer);
var
  LYear, ADay, GYear, GMonth, GDay: Word;
  AMonth: SmallInt;
  CurDay: Integer;
  OldFDate, NewDate: TDateTime;
  DaysOfLunarMonth: Integer;
begin
  OldFDate := FDate;
  DecodeLunarDate(FDate, LYear, AMonth, ADay);
  DecodeDate(FDate, GYear, GMonth, GDay);
  GYear := GetGregYear(GYear, LYear, AMonth);
  CurDay := ADay;
  if Delta > 0 then ADay := DaysPerLunarMonth(GYear, LYear, AMonth)
  else ADay := 1;
  NewDate := EncodeLunarDate(GYear, LYear, AMonth, ADay);
  NewDate := NewDate + Delta;
  DecodeLunarDate(NewDate, LYear, AMonth, ADay);
  DecodeDate(NewDate, GYear, GMonth, GDay);

  GYear := GetGregYear(GYear, LYear, AMonth);
  DaysOfLunarMonth := DaysPerLunarMonth(GYear, LYear, AMonth);
  if DaysOfLunarMonth > CurDay then ADay := CurDay
  else ADay := DaysOfLunarMonth;

  try
    CalendarDate := EncodeLunarDate(GYear, LYear, AMonth, ADay);
  except
    { to catch the EConvertError here, this is to prevent the exception
      from being raised for each display cell of the calendar }
    on EConvertError do 
      begin
        CalendarDate := OldFDate;
        MessageDlg(SLunarDateInvalidRange, mtError, [mbOK], 0);
      end;
  end;
end;

procedure TLunarCal.PrevMonth;
begin
  ChangeMonth(-1);
end;

procedure TLunarCal.NextMonth;
begin
  ChangeMonth(1);
end;

procedure TLunarCal.NextYear;
begin
  GregYear := GregYear + 1;
end;

procedure TLunarCal.PrevYear;
begin
  GregYear := GregYear - 1;
end;

procedure TLunarCal.UpdateCalendar;
var
  LYear, ADay, GYear, GMonth, GDay: Word;
  AMonth: SmallInt;
  FirstDate: TDateTime;
begin
  FUpdating := True;
  try
    DecodeLunarDate(FDate, LYear, AMonth, ADay);
    DecodeDate(FDate, GYear, GMonth, GDay);

    GYear := GetGregYear(GYear, LYear, AMonth);
    FirstDate := EncodeLunarDate(GYear, LYear, AMonth, 1);
    FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
    if FMonthOffset = 2 then FMonthOffset := -5;
    MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 2,
      False, False);
    Invalidate;
  finally
    FUpdating := False;
  end;
end;

procedure TLunarCal.WMSize(var Message: TWMSize);
var
  GridLines: Integer;
begin
  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines) div 8;
end;

procedure TLunarCal.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  hitpoint: TPoint;
begin
  inherited;

  if not FShowNavigator then Exit;

  if Button = mbLeft then
  begin
    hitpoint := self.HitTest;
    if (hitpoint.x > 0) and (hitpoint.x < DefaultColWidth) and
       (hitpoint.y > 0) and (hitpoint.y < DefaultRowHeight) then
      PrevMonth
    else 
      if (hitpoint.x > (DefaultColWidth*(ColCount-1))) and 
         (hitpoint.x < (DefaultColWidth*ColCount)) and
         (hitpoint.y > 0) and (hitpoint.y < DefaultRowHeight) then 
        NextMonth;
  end;
end;

procedure TLunarCal.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  TheCellText: string;
  DateRec: TDateRec;
  ROCYearStr, HintStr: String;
  HintRect: TRect;
  P: TPoint;
  X1, Y1, X2, Y2, CursorOffset: Integer;
  TopLeftX, TopLeftY, BotRightX, BotRightY: Integer;
  CurrentRowCol: TGridCoord;
begin
  inherited;
      
  if not ShowGregDate then Exit;
  if (not Focused) or (HitTest.Y < (DefaultRowHeight*2)) then
  begin
    FHintDate.ReleaseHandle;
    Exit;
  end;
  CurrentRowCol:= MouseCoord(HitTest.X, HitTest.Y);
  TheCellText := CellText[CurrentRowCol.X, CurrentRowCol.Y];
  if TheCellText <> '' then 
  begin
    if not GetCursorPos(P) then Exit;
    CursorOffset := GetSystemMetrics(SM_CYCURSOR) DIV 2;
    X1 := DefaultColWidth * CurrentRowCol.X;
    Y1 := DefaultRowHeight * CurrentRowCol.Y;
    X2 := DefaultColWidth * (CurrentRowCol.X+1);
    Y2 := DefaultRowHeight * (CurrentRowCol.Y+1);
    if (HitTest.X > X1) and (HitTest.X < X2) and
       (HitTest.Y > Y1) and (HitTest.Y < Y2) then
    begin
      DateRec.GregYear := GetGregYear(GregYear, LunarYear, LunarMonth);
      DateRec.LunarYear := LunarYear;
      DateRec.wMonth := LunarMonth;
      DateRec.wDay := StrToInt(TheCellText);
      if not LunarToGregorianDate(@daterec) then Exit;
      
      if daterec.GregYear > 1911 then
        ROCYearStr := '中国' + IntToStr(daterec.GregYear - 1911) + '年'
      else ROCYearStr := IntToStr(daterec.GregYear) + '年';
      HintStr := ROCYearStr + IntToStr(daterec.wMonth) + '月' +
                 IntToStr(daterec.wDay) + '日';
      HintRect := FHintDate.CalcHintRect(Screen.Width, HintStr, nil);
      BotRightX := HintRect.Right + P.X;
      BotRightY := HintRect.Bottom + P.Y + CursorOffset;
      TopLeftX := HintRect.Left + P.X;
      TopLeftY := HintRect.Top + P.Y + CursorOffset;
      if BotRightX > Screen.Width then
      begin
        BotRightX := Screen.Width;
        TopLeftX := Screen.Width - (HintRect.Right - HintRect.Left);
      end;
      if BotRightY > (Screen.Height - 4) then
      begin
        BotRightY := Screen.Height - 4;
        TopLeftY := Screen.Height - (HintRect.Bottom - HintRect.Top) - 4;
      end;
      HintRect := Rect(TopLeftX, TopLeftY, BotRightX, BotRightY);
      FHintDate.ActivateHint(HintRect, HintStr);
    end;
  end
  else FHintDate.ReleaseHandle;
end; 

function TLunarCal.GetGregYear(GYear, LYear: Word; LMonth: SmallInt): Word;
var
  lpThis: PLunar;
  i: integer;
  found: Boolean;
begin
  Result := GYear;
  found := False;

  lpThis := @LunarLookup[0];
  i := nLunarEntries;
  while i > 0 do
  begin
    if lpThis^.LunarYear <> LYear then
    begin
      Inc(lpThis);
      Dec(i);
      Continue;
    end;
    if lpThis^.LunarMonth <> LMonth then
    begin
      Inc(lpThis);
      Dec(i);
      Continue;
    end;
    if Abs(lpThis^.GregYear - GYear) > 3 then
    begin
      Inc(lpThis, 59 * 12);
      Dec(i, 59 * 12);
      Continue;
    end;
    found := True;
    break;
  end;

  if not found then
    Exit;

  Result := lpThis^.GregYear;
end;

end.