wwmonthcalendar.pas

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

{
//
// Components : TwwDBMonthCalendar
//
// Copyright (c) 1998-2001 by Woll2Woll Software
//
// 8/24/98 - Support Delphi 4 ActionLists
// 8/24/98 - Call Change method when using arrow keys to change date
// 8/25/98 - Return true if ComCtl supports mdoNoToday,
//           versions 4.7 or earlier did not
// 9/1/98  - Do not raise EncodeDate exception
// 9/10/98 - Check for clearing of max date when mindate <> 0
// 9/24/98 - Fix bug when user right-clicked to choose "Go to Today" on MouseDown method
// 10/29/98 - Fix bug when entering page-up in month calendar when previous month does
//            not have as many days.
// 1/9/98 - Make sure Handle is allocated before calling InvalidateRect
// 1/9/98 - Update Multiselection Start and End Dates - PYW
// 2/15/98 - Don't call change when no changes to date have occurred.
// 2/15/98 - Make sure calendar gets focus when mouse clicked on control.
// 2/15/98 - Fix bug when making a selection in a databound monthcalendar where changes
//           are reset when entering edit mode.
// 5/18/2000 - PYW - Remove Multiselect when just clicking without dragging
// 10/13/2000 - PYW - Certain keys did not respect mindate/maxdate values so out of range.  Fixed.
// 3/22/2000 - PYW - Add better support for 12/31/9999.
// 3/04/2002 - PYW - Added support for 12/31/9999 in CN_Notify
// 5/21/07 - Don't call SetDate and that prevents button next from being repeated
}

unit wwmonthcalendar;
interface

{$i wwIfDef.pas}
{$R-}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  comctrls, commctrl, db, dbctrls,menus, wwintl;

const MaxMonthForDayState = 14;

type
  TwwDateTimeColors = class(TPersistent)
  private
    Owner: TComponent;
    FBackColor: TColor;
    FTextColor: TColor;
    FTitleBackColor: TColor;
    FTitleTextColor: TColor;
    FMonthBackColor: TColor;
    FTrailingTextColor: TColor;
    procedure SetColor(Index: Integer; Value: TColor);
    procedure SetAllColors;

  public
    constructor Create(AOwner: TComponent);
    procedure Assign(Source: TPersistent); override;

  published
//    property BackColor: TColor index 0 read FBackColor write SetColor default clWindow;
    property TextColor: TColor index 1 read FTextColor write SetColor default clWindowText;
    property TitleBackColor: TColor index 2 read FTitleBackColor write SetColor default clActiveCaption;
    property TitleTextColor: TColor index 3 read FTitleTextColor write SetColor default clWhite;
    property MonthBackColor: TColor index 4 read FMonthBackColor write SetColor default clWhite;
    property TrailingTextColor: TColor index 5 read FTrailingTextColor
      write SetColor default clInactiveCaptionText;
  end;

  TwwPopupYearOptions =  class(TPersistent)
  private
     FYearsPerColumn:Integer;
     FNumberColumns:Integer;
     FStartYear:Integer;
     FShowEditYear: boolean;
     procedure SetStartYear(Value: Integer);
     procedure SetNumberColumns(Value: Integer);
     procedure SetYearsPerColumn(Value: Integer);
     procedure SetShowEdityear(Value: Boolean);
  public
     constructor Create(AOwner: TComponent);
     procedure Assign(Source: TPersistent); override;
  published
     property YearsPerColumn: Integer read FYearsPerColumn write SetYearsPerColumn default 10;
     property NumberColumns: Integer read FNumberColumns write SetNumberColumns default 2;
     property StartYear: Integer read FStartYear write SetStartYear default 1990;
     property ShowEditYear: Boolean read FShowEditYear write SetShowEditYear default False;
  end;

  TwwMonthOption = (mdoDayState, mdoWeekNumbers, mdoNoToday, mdoNoTodayCircle, mdoMultiSelect,
     mdoNoTrailingDates {Vista only}, //Disables displaying the dates from the previous/next month in the current calendar
     mdoShortDaysOfWeek {Vista Only}, // Uses CAL_SSHORTESTDAYNAME names to display for the day of the week column header
     mdoNoSelChangeOnNav {Vista only} // This flag does not chagne the selection when the user navigates next or previous in the calendar.
                                      // This allows the user to select a range larger than what they can currently see.
     );
  TwwMonthOptions = set of TwwMonthOption;
  TCalcBoldDayEvent =
     procedure(Sender: TObject; ADate: TDate; Month, Day, Year: Integer; var Accept: Boolean) of object;
  TmcMouseMoveEvent =
     procedure(Sender: TObject; Shift: TShiftState; X, Y, Month, Day, Year: Integer) of object;
  TmcMouseUPDownEvent =
     procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y, Month, Day, Year: Integer) of object;

  TwwCalDayOfWeek = (wwdowMonday, wwdowTuesday, wwdowWednesday, wwdowThursday,
    wwdowFriday, wwdowSaturday, wwdowSunday, wwdowLocaleDefault);

  TwwMonthCalendar = class(TWinControl)
  private
    FBorder : TBorderStyle;
    FCalColors: TwwDateTimeColors;
    FDateTime: TDateTime;
    FStartDate: TDateTime;
    FEndDate: TDateTime;
    FMaxDate: TDate;
    FMinDate: TDate;
    FOnChange: TNotifyEvent;
    FOnCalcBoldDay: TCalcBoldDayEvent;
    FOptions: TwwMonthOptions;
    FMaxSelectCount:Integer;
    FSelChanged:Boolean;
    FOnMouseMove: TmcMouseMoveEvent;
    FOnMouseDown: TmcMouseUpDownEvent;
    FOnMouseUp: TmcMouseUpDownEvent;
    FYearPopupMenu: TPopupMenu;
    FYearPopupShowing : Boolean;
    FMonthPopupShowing : Boolean;
    FAfterYearPopup:Boolean;
    FAfterMonthPopup:Boolean;    
    FMonthPopupMenu: TPopupMenu;
    FPopupSystemTime: TSystemTime;
    FPrevPopupMonth:integer;
    FDummyList:TList;   // Dummy List for maintenance builds.

    FPopupYearOptions:TwwPopupYearOptions;
    FFirstDayOfWeek: TwwCalDayOfWeek;
    procedure AdjustHeight;
    function GetDate: TDate;
    function GetTime: TTime;
    function GetEndDate: TDate;
    function GetStartDate: TDate;
    function GetHeight: Integer;
    function GetWidth: Integer;
//    function GetMaxSelectCount: Integer;
    procedure SetCalColors(Value: TwwDateTimeColors);
    procedure SetDate(Value: TDate);
    procedure SetEndDate(Value: TDate);
    procedure SetStartDate(Value: TDate);
    procedure SetDateTime(Value: TDateTime);
    procedure SetBorder(Value: TBorderStyle);
    procedure SetHeight(Value: Integer);
    procedure SetWidth(Value: Integer);
    procedure SetMaxDate(Value: TDate);
    procedure SetMaxSelectCount(Value: Integer);
    procedure SetMinDate(Value: TDate);
    procedure SetRange(MinVal, MaxVal: TDateTime);
    procedure SetTime(Value: TTime);
    procedure SetPopupYearOptions(Value:TwwPopupYearOptions);
    procedure SetFirstDayOfWeek(Value: TwwCalDayOfWeek);
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN; {handle tab}
//    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetOptions(val: TwwMonthOptions); virtual;
    procedure Change; dynamic;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure GetFocus; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState;X, Y: Integer); override;
    function SetSelRange(AStart,AEnd:TDate):Boolean;
    function SetMonthCalDateTime(Value:TDateTime):Boolean;
    procedure Loaded; override;
    procedure WndProc(var Message: TMessage); override;
    procedure wwPopupMenuClick(Sender: TObject);
    procedure wwMonthPopupMenuClick(Sender: TObject);
  public
    Patch: Variant;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function IsPopupYearMonthShowing: boolean;
    property EndDate: TDate read GetEndDate write SetEndDate;
    property StartDate: TDate read GetStartDate write SetStartDate;
    property DateTime : TDateTime read FDateTime write SetDateTime;
(*  {$ifdef wwdelphi4up}
    procedure RefreshBoldDays;
    {$endif}*)
  published
    property BorderStyle: TBorderStyle read FBorder write SetBorder default bsNone;
    property CalColors: TwwDateTimeColors read FCalColors write SetCalColors;
    property Date: TDate read GetDate write SetDate;
    property Time: TTime read GetTime write SetTime;
    property Color stored True default clWindow;
    property Options : TwwMonthOptions read FOptions write SetOptions default [mdoDayState];
    property PopupYearOptions:TwwPopupYearOptions read FPopupYearOptions write SetPopupYearOptions;
    property FirstDayOfWeek: TwwCalDayOfWeek read FFirstDayOfWeek write SetFirstDayOfWeek
      default wwdowLocaleDefault;
    property Height: Integer read GetHeight write SetHeight;
    property MaxSelectCount: Integer read FMaxSelectCount write SetMaxSelectCount default 31;
    property MaxDate: TDate read FMaxDate write SetMaxDate;
    property MinDate: TDate read FMinDate write SetMinDate;
    property ParentColor default False;
    property TabStop default True;
    property Width: Integer read GetWidth write SetWidth;
    property OnCalcBoldDay: TCalcBoldDayEvent read FOnCalcBoldDay write FOnCalcBoldDay;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnMouseDown: TmcMouseUpDownEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseMove: TmcMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseUp: TmcMouseUpDownEvent read FOnMouseUp write FOnMouseUp;
  end;

  TwwDBCustomMonthCalendar = class(TwwMonthCalendar)
  private
    FDataLink: TFieldDataLink;
    FPaintControl: TwwMonthCalendar;//PaintControl;
//    FPaintControl: TPaintControl;

    function GetField: TField;
    function GetDataField: string;
    procedure SetDataField(const Value: string);
    function GetReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetDataSource(Value: TDataSource);
    function GetDataSource: TDataSource;

    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure DataChange(Sender: TObject);
    procedure UpdateData(Sender: TObject);
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  protected
    procedure Notification(AComponent: TComponent;
        Operation: TOperation); override;
    procedure KeyPress(var Key: Char); override;
    procedure Change; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    {$ifdef wwdelphi4up}
    function ExecuteAction(Action: TBasicAction): Boolean; override; { 8/24/98 }
    function UpdateAction(Action: TBasicAction): Boolean; override; {8/24/98}
    {$endif}
    property Field: TField read GetField;

  published
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  end;

  TwwDBMonthCalendar = class(TwwDBCustomMonthCalendar)
  published
    {$ifdef wwDelphi4Up}
    property Anchors;
    {$endif}
    property Align;
    property BorderStyle;
    property CalColors;
    {$ifdef wwDelphi4Up}
    property Constraints;
    {$endif}
    property Date;
    property Time;
    property Color;
    property Options;
    property PopupYearOptions;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FirstDayOfWeek;
    property Font;
    property Height;
    property ImeMode;
    property ImeName;
    property MaxSelectCount;
    property MaxDate;
    property MinDate;
    property ParentColor default False;
    property ParentFont;
    property ParentShowHint;
//    property PopupMenu;
    property ShowHint;
    property TabStop default True;
    property Visible;
    property Width;
    property OnCalcBoldDay;
    property OnClick;
    property OnChange;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;

    property DataField;
    property DataSource;
    property ReadOnly;

  end;


//procedure Register;

implementation

uses comstrs,
{$ifdef wwDelphi6Up}
rtlconsts, variants,
{$endif}
 consts, wwdbdatetimepicker, wwcommon;

const
  ColorIndex: array[0..5] of Integer = (MCSC_BACKGROUND, MCSC_TEXT,
    MCSC_TITLEBK, MCSC_TITLETEXT, MCSC_MONTHBK, MCSC_TRAILINGTEXT);

    function min(a,b:integer):Integer;
    begin
       if a<=b then result :=a else result :=b;
    end;

    function DaysThisMonth(Month,Year:integer): Integer;
    const
      DaysPerMonth: array[1..12] of Integer =
        (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);	    { usual numbers of days }
    begin
       Result := DaysPerMonth[Month];                        { normally, just return number }
       if (Month = 2) and IsLeapYear(Year) then Inc(Result); { plus 1 in leap February }
    end;


{ 8/25/98 - Return true if ComCtl supports mdoNoToday,
  versions 4.7 or earlier did not}
function UpdatedComCtlVersion: boolean;
var dummy: DWORD;
    verInfoSize, verValueSize: DWORD;
    verInfo: Pointer;
    verValue: PVSFixedFileInfo;
    V1,V2: WORD;
begin
   if IsVistaComCtrlVersion then // 5/21/07 - Vista support
   begin
      result:=true;
      exit;
   end;
   verInfoSize:= GetFileVersionInfoSize('comctl32.dll', Dummy);
   if VerInfoSize = 0 then