wwmonthcalendar.pas

胜天进销存源码,国产优秀的进销存

   begin
      Dummy:= GetLastError;
      result:= True;
      exit;
   end;

   GetMem(VerInfo, VerInfoSize);
   GetFileVersionInfo('comctl32.dll', 0, VerInfoSize, VerInfo);
   VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
   with VerValue^ do begin
      V1:= dwFileVersionMS shr 16;
      V2:= dwFileVersionMS and $FFFF;
   end;
   result:= ((v1>=4) and (v2>70)) or (v1>=5);
   FreeMem(VerInfo, VerInfoSize);

end;

constructor TwwPopupYearOptions.Create(AOwner: TComponent);
begin
  inherited Create;
  FYearsPerColumn:=10;
  FNumberColumns:= 2;
  FStartYear:= 1990;
end;

procedure TwwPopupYearOptions.SetYearsPerColumn(Value: Integer);
begin
  if Value <> FYearsPerColumn then
     FYearsPerColumn := Value;
end;

procedure TwwPopupYearOptions.SetShowEditYear(Value: boolean);
begin
  if Value <> FShowEditYear then
     FShowEditYear:= Value;
end;

procedure TwwPopupYearOptions.SetNumberColumns(Value: Integer);
begin
  if Value <> FNumberColumns then
     FNumberColumns := Value;
end;

procedure TwwPopupYearOptions.SetStartYear(Value: Integer);
begin
  if Value <> FStartYear then
     FStartYear := Value;
end;

constructor TwwDateTimeColors.Create(AOwner: TComponent);
begin
  Owner := AOwner;
  FBackColor := clWindow;
  FTextColor := clWindowText;
  FTitleBackColor := clActiveCaption;
  FTitleTextColor := clWhite;
  FMonthBackColor := clWhite;
  FTrailingTextColor := clInactiveCaptionText;
end;

procedure TwwPopupYearOptions.Assign(Source: TPersistent);
begin
  if Source is TwwPopupYearOptions then
  begin
     FYearsPerColumn:= TwwPopupYearOptions(Source).YearsPerColumn;
     FNumberColumns:= TwwPopupYearOptions(Source).NumberColumns;
     FStartYear:= TwwPopupYearOptions(Source).StartYear;
     FShowEdityear:= TwwPopupYearOptions(Source).ShowEditYear;
     Exit;
  end;
  inherited Assign(Source);
end;

procedure TwwDateTimeColors.Assign(Source: TPersistent);
var
  SourceName: string;
begin
  if Source = nil then SourceName := 'nil'
  else SourceName := Source.ClassName;
  if (Source = nil) or not (Source is TwwDateTimeColors) then
    raise EConvertError.CreateFmt(SAssignError, [SourceName, ClassName]);
//  FBackColor := TwwDateTimeColors(Source).BackColor;
  FTextColor := TwwDateTimeColors(Source).TextColor;
  FTitleBackColor := TwwDateTimeColors(Source).TitleBackColor;
  FTitleTextColor := TwwDateTimeColors(Source).TitleTextColor;
  FMonthBackColor := TwwDateTimeColors(Source).MonthBackColor;
  FTrailingTextColor := TwwDateTimeColors(Source).TrailingTextColor;
end;

procedure TwwDateTimeColors.SetColor(Index: Integer; Value: TColor);
begin
  if Owner is TwwMonthCalendar then
     MonthCal_SetColor(
        (Owner as TwwMonthCalendar).Handle, ColorIndex[Index], ColorToRGB(Value));
  case Index of
    0: FBackColor := Value;
    1: FTextColor := Value;
    2: FTitleBackColor := Value;
    3: FTitleTextColor := Value;
    4: FMonthBackColor := Value;
    5: FTrailingTextColor := Value;
  end;
end;


procedure TwwDateTimeColors.SetAllColors;
begin
  SetColor(0, FBackColor);
  SetColor(1, FTextColor);
  SetColor(2, FTitleBackColor);
  SetColor(3, FTitleTextColor);
  SetColor(4, FMonthBackColor);
  SetColor(5, FTrailingTextColor);
end;
type
 TCalendarPopupMenu = class(TPopupMenu)
   private
     PoppedUp: boolean;
   protected
     procedure Popup(X, Y: Integer); override;
   public
     function isPoppedUp: boolean;
 end;

 function TCalendarPopupMenu.isPoppedUp: boolean;
 begin
    result:= PoppedUp;
 end;

 procedure TCalendarPopupMenu.Popup(X, Y: Integer);
 begin
    PoppedUp:= True;
    inherited Popup(x,y);
//    Application.ProcessMessages;  {Allows processing of Mouse Messages to finish before clearing flag.}
    PoppedUp:= False;
 end;

constructor TwwMonthCalendar.Create(AOwner: TComponent);
var i:integer;
begin
  CheckCommonControl(ICC_DATE_CLASSES);
  FCalColors := TwwDateTimeColors.Create(Self);
  FPopupYearOptions:= TwwPopupYearOptions.create(Self);
  FDateTime := Now;
  inherited Create(AOwner);
  ControlStyle := [csOpaque, csClickEvents, csDoubleClicks, csFixedHeight];
  Color := clWindow;
  ParentColor := False;
  TabStop := True;
  Width := 155;
  FOptions:= [mdoDayState];
  FMaxSelectCount := 31;
  FMinDate := 0.0;
  FMaxDate := 0.0;
  FSelChanged := False;
  FDummyList := TList.Create;
  FFirstDayOfWeek := wwdowLocaleDefault;
  FMonthPopupMenu := TCalendarPopupMenu.Create(Self);
  {$ifdef wwDelphi5Up}
  FMonthPopupMenu.AutoHotKeys:= maManual;
  {$endif}
  FMonthPopupMenu.Alignment := paRight;
  for i:= 1 to 12 do begin
     FMonthPopupMenu.Items.Add(NewItem(LongMonthNames[i],0,False,True,nil,0,''));
     FMonthPopupMenu.Items[i-1].onClick := wwMonthPopupMenuClick;
  end;
  Patch:= VarArrayCreate([0, 0], varVariant);
  Patch[0]:= False; { 2/15/99 -  Internally used to skip data change event }

end;

destructor TwwMonthCalendar.Destroy;
begin
  if FCalColors.owner=self then FCalColors.Free;  { Paul, why check for owner? }
  FPopupYearOptions.Free;

  FDummyList.Free;
  FMonthPopupMenu.Free;
  inherited Destroy;
end;

procedure TwwMonthCalendar.MouseMove(Shift: TShiftState; X, Y: Integer);
var info:TMCHitTestInfo;
begin
   FillChar(info, SizeOf(TMCHitTestInfo), 0); { RSW }
   info.cbSize := sizeof(TMCHitTestInfo);
   info.pt := Point(X,Y);
   MonthCal_HitTest(Handle,info);
   if Assigned(FOnMouseMove) then begin
      if (info.st.wday=0) or (info.st.wday > 32) then
         FOnMouseMove(Self, Shift, X, Y, info.st.wMonth, info.st.wDay, info.st.wYear)
      else FOnMouseMove(Self, Shift, X, Y, info.st.wMonth, info.st.wDay, info.st.wYear);
   end;
end;

procedure TwwMonthCalendar.MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);
var info:TMCHitTestInfo;
begin
   FillChar(info, SizeOf(TMCHitTestInfo), 0); { RSW }
   info.cbSize := sizeof(TMCHitTestInfo);
   info.pt := Point(X,Y);
   MonthCal_HitTest(Handle,Info);
   if Assigned(FOnMouseUp) then
   begin
      if (info.st.wday=0) or (info.st.wday > 32) then
         FOnMouseUp(Self, Button, Shift, X, Y, info.st.wMonth, 0, info.st.wYear)
      else FOnMouseUp(Self, Button, Shift, X, Y, info.st.wMonth, info.st.wDay, info.st.wYear);
   end;

   if (mdoMultiSelect in Options) then begin
     if FSelChanged then begin
       Change;
     end;
     FSelChanged := False;
   end;
end;

procedure TwwMonthCalendar.MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);
var STA: packed array[1..2] of TSystemTime;
    var info:TMCHitTestInfo;
    curx,cury,i,numpopupyears:integer;
    APoint:TPoint;
    m,dy,yr:Word;
    months,yearoffset:integer;
begin
   // Added this code to fix bug when user right-clicked to choose "Go to Today"
   // on the month or year it would popup our popup menus incorrectly.  -ksw (9/24/98)
   if Button = mbRight then
   begin
     inherited;
     Exit;
   end;

   // 2/15/98 - PYW - Make sure calendar gets focus when mouse clicked on control.
   if not (Owner is TwwDBCustomDateTimePicker) then SetFocus;

   FillChar(info, SizeOf(TMCHitTestInfo), 0); { RSW }
   info.cbSize := sizeof(TMCHitTestInfo);
   info.pt := Point(X,Y);
   MonthCal_HitTest(Handle,Info);
   // if info.st.wday = 0 or > 32 then not a valid date.
   if Assigned(FOnMouseDown) then begin
      try
        if (info.st.wday=0) or (info.st.wday > 32) then
           FOnMouseDown(Self, Button, Shift, X, Y, info.st.wMonth, 0, info.st.wYear)
        else FOnMouseDown(Self, Button, Shift, X, Y, info.st.wMonth, info.st.wDay, info.st.wYear);
      except
         FAfterYearPopup := False;
         FAfterMonthPopup := False;
         exit;
      end;
   end;

   // Prevent Clicking on an Invalid Date (Min/Max Date Values) when clicking on actual Dates.
   if (info.st.wDay<>0) and (info.st.wDay < 32) then begin
      FAfterYearPopup := False;
      FAfterMonthPopup := False;

      if ((MaxDate<> 0.0) and
         (Trunc(MaxDate)<Trunc(EncodeDate(info.st.wyear,info.st.wmonth,info.st.wday)))) or
         (Trunc(MinDate)>Trunc(EncodeDate(info.st.wyear,info.st.wmonth,info.st.wday))) then
      begin
        if ((MaxDate<> 0.0) and
           (Trunc(MaxDate)<Trunc(EncodeDate(info.st.wyear,info.st.wmonth,info.st.wday)))) then
          DecodeDate(MaxDate,yr,m,dy)
        else
          DecodeDate(MinDate,yr,m,dy);
        Date:=EncodeDate(yr,m,dy);
        exit;
      end;
   end
   // Prevent Scrolling to an Invalid Date (Min/Max Date Values) when clicking on buttons.
   else if (info.uHit = MCHT_TITLEBTNNEXT) or (info.uHit = MCHT_TITLEBTNPREV) then
   begin
      FAfterYearPopup := False;
      FAfterMonthPopup := False;

      MonthCal_GetMonthRange(WindowHandle,GMR_VISIBLE,@STA[1]);
      months := MonthCal_GetMonthDelta(WindowHandle);
      DecodeDate(Date,yr,m,dy);
      if (info.uHit = MCHT_TITLEBTNPREV) then begin
         if STA[1].wMonth-Months > 0 then begin
           if Trunc(EncodeDate(STA[1].wYear,STA[1].wMonth-Months,min(dy,DaysThisMonth(STA[1].wMonth-(Months),STA[1].wYear))))<MinDate then
           begin
              Date:=Trunc(MinDate);
              MessageBeep(0); // 7/24/1998 - pw - Added Message Beep when setting to MinDate
           end
           else Date:=EncodeDate(STA[1].wYear,STA[1].wMonth-(Months),
              min(dy,DaysThisMonth(STA[1].wMonth-(Months),STA[1].wYear)));
         end
         else begin
           if Trunc(EncodeDate(STA[1].wYear-1,12+STA[1].wMonth-(Months),
               min(dy,DaysThisMonth(12+STA[1].wMonth-Months,STA[1].wYear-1))))<MinDate then
           begin
              Date:=Trunc(MinDate);
              MessageBeep(0);  // 7/24/1998 - pw - Added Message Beep when setting to MinDate
           end
           else Date:=EncodeDate(STA[1].wYear-1,12+STA[1].wMonth-Months,
               min(dy,DaysThisMonth(12+STA[1].wMonth-Months,STA[1].wYear)));
         end;
         Change;
      end
      else begin
         if STA[2].wMonth+(Months) <= 12 then begin
           if (MaxDate<>0.0) and (Trunc(EncodeDate(STA[2].wYear,STA[2].wMonth+(Months),min(dy,DaysThisMonth(STA[2].wMonth+(Months),STA[2].wYear))))>Trunc(MaxDate)) then
           begin
              Date:=Trunc(MaxDate);
              MessageBeep(0); // 7/24/1998 - pw - Added Message Beep when setting to MaxDate
           end
           else
              Date:=EncodeDate(STA[2].wYear,STA[2].wMonth+(Months),
                  min(dy,DaysThisMonth(STA[2].wMonth+(Months),STA[2].wYear)));
         end
         else begin
           if (MaxDate<>0.0) and (Trunc(EncodeDate(STA[2].wYear+1,STA[2].wMonth+(Months)-12,min(dy,DaysThisMonth(STA[2].wMonth+(Months)-12,STA[2].wYear+1))))>Trunc(MaxDate)) then
           begin
              Date:=Trunc(MaxDate);
              MessageBeep(0);  // 7/24/1998 - pw - Added Message Beep when setting to MaxDate
           end
           else begin
              // 3/22/2000 - PYW - Add better support for 12/31/9999.
              if (STA[2].wYear+1<10000) then
                Date:=EncodeDate(STA[2].wYear+1,STA[2].wMonth+Months-12,
                  min(dy,DaysThisMonth(STA[2].wMonth+(Months)-12,STA[2].wYear+1)))
              else MessageBeep(0);
           end;
         end;
         Change;
      end;
      exit;
   end;

   curx:=x;
   cury:=y;
   //If TitleYear was clicked on then Get Positions and then popup the Year Menu.
   if info.uHit = MCHT_TITLEYEAR then begin
      FAfterMonthPopup := False;
      if (FYearPopupShowing or FAfterYearPopup) and (info.st.wMonth = FPrevPopupMonth) then begin
        FAfterYearPopup := False;
        exit;
      end;
      FPrevPopupMonth := info.st.wMonth;
      while Info.uhit = MCHT_TITLEYEAR do begin
         cury := cury+1;
         info.pt := Point(curx,cury);
         MonthCal_HitTest(Handle,Info);
      end;
      cury:=cury-1;

      info.pt := Point(curx,cury);
      MonthCal_HitTest(Handle,Info);

      while Info.uhit = MCHT_TITLEYEAR do begin
         curx := curx-1;
         info.pt := Point(curx,cury);
         MonthCal_HitTest(Handle,Info);