stooledit.pas

AlphaControls是一个Delphi标准控件的集合

unit sTooledit;
{$I sDefs.inc}
{$IFDEF DELPHI6UP}
{$WARN UNIT_PLATFORM OFF}
{$ENDIF}

interface

uses Windows, Classes, sStyleUtil, sConst, StdCtrls, Controls,
  Messages, SysUtils, Forms, Graphics, Menus, Buttons, Dialogs, Mask, sDateUtils,
  sCustomComboEdit, FileCtrl, comctrls, sPopupClndr, sControlsManager, sStrings,
  sUtils {$IFDEF DELPHI6}, Variants{$ENDIF};

type

  TsFileDirEdit = class(TsCustomComboEdit)
  private
    FAcceptFiles: Boolean;
    FOnDropFiles: TNotifyEvent;
    procedure SetDragAccept(Value: Boolean);
    procedure SetAcceptFiles(Value: Boolean);
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
  protected

    FMultipleDirs: Boolean;
    procedure CreateHandle; override;
    procedure DestroyWindowHandle; override;
    function GetLongName: string; virtual; abstract;
    function GetShortName: string; virtual; abstract;
    procedure ReceptFileDir(const AFileName: string); virtual; abstract;
    procedure ClearFileList; virtual;
    property MaxLength default 255;
  public
    constructor Create(AOwner: TComponent); override;
    property LongName: string read GetLongName;
    property ShortName: string read GetShortName;
    property AcceptFiles: Boolean read FAcceptFiles write SetAcceptFiles default False;
  published
    { Published declarations }
    property ClickKey;
    property OnDropFiles: TNotifyEvent read FOnDropFiles write FOnDropFiles;
    property OnButtonClick;
  end;

{ TsFilenameEdit }

  TFileDialogKind = (dkOpen, dkSave);

  TsFilenameEdit = class(TsFileDirEdit)
  private
    FDialog: TOpenDialog;
    FDialogKind: TFileDialogKind;
    procedure CreateEditDialog;
    function GetFileName: string;
    function GetDefaultExt: string;
    function GetFileEditStyle: TFileEditStyle;
    function GetFilter: string;
    function GetFilterIndex: Integer;
    function GetInitialDir: string;
    function GetHistoryList: TStrings;
    function GetOptions: TOpenOptions;
    function GetDialogTitle: string;
    function GetDialogFiles: TStrings;
    procedure SetDialogKind(Value: TFileDialogKind);
    procedure SetFileName(const Value: string);
    procedure SetDefaultExt(Value: string);
    procedure SetFileEditStyle(Value: TFileEditStyle);
    procedure SetFilter(const Value: string);
    procedure SetFilterIndex(Value: Integer);
    procedure SetInitialDir(const Value: string);
    procedure SetHistoryList(Value: TStrings);
    procedure SetOptions(Value: TOpenOptions);
    procedure SetDialogTitle(const Value: string);
    function IsCustomTitle: Boolean;
    function IsCustomFilter: Boolean;
  protected
    procedure ButtonClick; override;
    procedure ReceptFileDir(const AFileName: string); override;
    procedure ClearFileList; override;
    function GetLongName: string; override;
    function GetShortName: string; override;
  public
    constructor Create(AOwner: TComponent); override;
    property Dialog: TOpenDialog read FDialog;
    property DialogFiles: TStrings read GetDialogFiles;
    property FileEditStyle: TFileEditStyle read GetFileEditStyle write SetFileEditStyle default fsEdit;
    property DialogTitle: string read GetDialogTitle write SetDialogTitle stored IsCustomTitle;
  published
    property DialogKind: TFileDialogKind read FDialogKind write SetDialogKind default dkOpen;
    property DefaultExt: string read GetDefaultExt write SetDefaultExt;
    property FileName: string read GetFileName write SetFileName stored False;
    property Filter: string read GetFilter write SetFilter stored IsCustomFilter;
    property FilterIndex: Integer read GetFilterIndex write SetFilterIndex default 1;
    property InitialDir: string read GetInitialDir write SetInitialDir;
    property HistoryList: TStrings read GetHistoryList write SetHistoryList;
    property DialogOptions: TOpenOptions read GetOptions write SetOptions default [ofHideReadOnly];
  end;

{ TsDirectoryEdit }

  TsDirectoryEdit = class(TsFileDirEdit)
  private
    FOptions: TSelectDirOpts;
    FInitialDir: string;
    FDialogText: string;
  protected
    procedure ButtonClick; override;
    procedure ReceptFileDir(const AFileName: string); override;
    function GetLongName: string; override;
    function GetShortName: string; override;
  public
    constructor Create(AOwner: TComponent); override;
    property DialogText: string read FDialogText write FDialogText;
  published
    property DialogOptions: TSelectDirOpts read FOptions write FOptions default [sdAllowCreate, sdPerformCreate, sdPrompt];
    property InitialDir: string read FInitialDir write FInitialDir;
    property MultipleDirs: Boolean read FMultipleDirs write FMultipleDirs default False;
  end;

{ TsCustomDateEdit }

  TYearDigits = (dyDefault, dyFour, dyTwo);

type
  TOnAcceptDate = procedure(Sender: TObject; var aDate: TDateTime; var CanAccept: Boolean) of object;

  TsCustomDateEdit = class(TsCustomComboEdit)
  private
    FTitle: PString;
    FOnAcceptDate: TOnAcceptDate;
    FDefaultToday: Boolean;
    FHooked: Boolean;
    FCheckOnExit: Boolean;
    FBlanksChar: Char;
    FCalendarHints: TStrings;
    FStartOfWeek: TCalDayOfWeek;
    FWeekends: sConst.TDaysOfWeek;
    FWeekendColor: TColor;
    FYearDigits: TYearDigits;
    FDateFormat: string[10];
    FFormatting: Boolean;
    FMinDate: TDateTime;
    FMaxDate: TDateTime;
    function GetDate: TDateTime;
    procedure SetDate(Value: TDateTime);
    procedure SetYearDigits(Value: TYearDigits);
    function GetDialogTitle: string;
    procedure SetDialogTitle(const Value: string);
    function IsCustomTitle: Boolean;
    procedure SetCalendarHints(Value: TStrings);
    procedure CalendarHintsChanged(Sender: TObject);
    procedure SetWeekendColor(Value: TColor);
    procedure SetWeekends(Value: sConst.TDaysOfWeek);
    procedure SetStartOfWeek(Value: TCalDayOfWeek);
    procedure SetBlanksChar(Value: Char);
    function TextStored: Boolean;
    function FourDigitYear: Boolean;
    function FormatSettingsChange(var Message: TMessage): Boolean;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure SetMinDate(const Value: TDateTime);
    procedure SetMaxDate(const Value: TDateTime);
  protected
    procedure Change; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure DestroyWindowHandle; override;
    function GetDateFormat: string;
    procedure ApplyDate(Value: TDateTime); virtual;
    procedure UpdateFormat;
    procedure UpdatePopup;

    property BlanksChar: Char read FBlanksChar write SetBlanksChar default ' ';
    property CalendarHints: TStrings read FCalendarHints write SetCalendarHints;
    property CheckOnExit: Boolean read FCheckOnExit write FCheckOnExit default False;
    property DefaultToday: Boolean read FDefaultToday write FDefaultToday default False;
    property DialogTitle: string read GetDialogTitle write SetDialogTitle
      stored IsCustomTitle;
    property EditMask stored False;
    property Formatting: Boolean read FFormatting;
    property StartOfWeek: TCalDayOfWeek read FStartOfWeek write SetStartOfWeek default dowLocaleDefault;
    property Weekends: sConst.TDaysOfWeek read FWeekends write SetWeekends default [dowSunday];
    property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clRed;
    property YearDigits: TYearDigits read FYearDigits write SetYearDigits default dyFour;
    property OnAcceptDate: TOnAcceptDate read FOnAcceptDate write FOnAcceptDate;
    property MaxLength stored False;
    property Text stored TextStored;

    procedure PopupWindowShow; override;
  public
    procedure Loaded; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CheckValidDate;
    function GetDateMask: string;
    procedure WndProc (var Message: TMessage); override;
    procedure UpdateMask; virtual;

    property Date: TDateTime read GetDate write SetDate;
  published
    property MinDate : TDateTime read FMinDate write SetMinDate;
    property MaxDate : TDateTime read FMaxDate write SetMaxDate;
  end;

{ TsDateEdit }

  TsDateEdit = class(TsCustomDateEdit)
  public
    constructor Create(AOwner: TComponent); override;
    property EditMask;
  published
    property BlanksChar;
    property CalendarHints;
    property CheckOnExit;
    property ClickKey;
    property DefaultToday;
    property DialogTitle;
    property PopupAlign;
    property PopupWidth;
    property StartOfWeek;
    property Weekends;
    property WeekendColor;
    property YearDigits;
    property OnAcceptDate;
    property OnButtonClick;
    property OnChange;
    property OnContextPopup;
  end;

  EComboEditError = class(Exception);

{ Utility routines }

procedure DateFormatChanged;
function StrToDateFmt(const DateFormat, S: string): TDateTime;
function StrToDateFmtDef(const DateFormat, S: string; Default: TDateTime): TDateTime;

implementation

{.$R *.RES}

uses ShellAPI, Consts, sEditorsManager, sMessages, sStyleSimply;

const
  sFileBmp = 'FEDITBMP'; { Filename and directory editor button glyph }
  sDateBmp = 'DEDITBMP'; { Date editor button glyph }

{ TsFileDirEdit }

constructor TsFileDirEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  sStyle.COC := COC_TsFileDirEdit;

  OEMConvert := True;
  MaxLength := 255;
end;

procedure TsFileDirEdit.CreateHandle;
begin
  inherited CreateHandle;
  if FAcceptFiles then SetDragAccept(True);
end;

procedure TsFileDirEdit.DestroyWindowHandle;
begin
  SetDragAccept(False);
  inherited DestroyWindowHandle;
end;

procedure TsFileDirEdit.SetDragAccept(Value: Boolean);
begin
  if not (csDesigning in ComponentState) and (Handle <> 0) then DragAcceptFiles(Handle, Value);
end;

procedure TsFileDirEdit.SetAcceptFiles(Value: Boolean);
begin
  if FAcceptFiles <> Value then begin
    SetDragAccept(Value);
    FAcceptFiles := Value;
  end;
end;

procedure TsFileDirEdit.WMDropFiles(var Msg: TWMDropFiles);
var
  FileName: string;
  i, Num: Cardinal;
begin
  Msg.Result := 0;
  Num := DragQueryFile(Msg.Drop, $FFFFFFFF, nil, 0);
  if Num > 0 then begin
    ClearFileList;
    for i := 0 to Num - 1 do begin
      DragQueryFile(Msg.Drop, i, PChar(FileName), Length(FileName) - 1);
      ReceptFileDir(FileName);
      if not FMultipleDirs then Break;
    end;
    if Assigned(FOnDropFiles) then FOnDropFiles(Self);
  end;
  DragFinish(Msg.Drop);
end;

procedure TsFileDirEdit.ClearFileList;
begin
end;

{ TsFilenameEdit }

{
function ClipFilename(const FileName: string): string;
var
  Params: string;
begin
//  if FileExists(FileName) then Result := FileName
//  else SplitCommandLine(FileName, Result, Params);
end;
}
function ExtFilename(const FileName: string): string;
begin
  if (Pos(' ', FileName) > 0) and (FileName[1] <> '"') then
    Result := Format('"%s"', [FileName])
  else Result := FileName;
end;

constructor TsFilenameEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  sStyle.COC := COC_TsFilenameEdit;
  FDefBmpName := 'BTN_OPENFILE';
  CreateEditDialog;
end;

procedure TsFilenameEdit.CreateEditDialog;
var
  NewDialog: TOpenDialog;
//  s: string;
begin
  case FDialogKind of
    dkOpen: begin
      NewDialog := TOpenDialog.Create(Self);
    end;
    dkSave: begin
      NewDialog := TSaveDialog.Create(Self);
    end
    else NewDialog := nil;
  end;
  if FDialog <> nil then begin
    NewDialog.DefaultExt := FDialog.DefaultExt;
    NewDialog.FileEditStyle := FDialog.FileEditStyle;
    NewDialog.FileName := FDialog.FileName;
    NewDialog.Filter := FDialog.Filter;
    NewDialog.FilterIndex := FDialog.FilterIndex;
    NewDialog.InitialDir := FDialog.InitialDir;
    NewDialog.HistoryList := FDialog.HistoryList;
    NewDialog.Files.Assign(FDialog.Files);
    NewDialog.Options := FDialog.Options;
    NewDialog.Title := FDialog.Title;
    FDialog.Free;
  end
  else begin
    NewDialog.Title := stFileOpen;
    NewDialog.Filter := SDefaultFilter;
    NewDialog.Options := [ofHideReadOnly];
  end;
  FDialog := NewDialog;
end;

function TsFilenameEdit.IsCustomTitle: Boolean;
begin
  Result := CompareStr(stFileOpen, FDialog.Title) <> 0;
end;

function TsFilenameEdit.IsCustomFilter: Boolean;
begin
  Result := CompareStr(sDefaultFilter, FDialog.Filter) <> 0;
end;

procedure TsFilenameEdit.ButtonClick;
var
  Temp: string;
  Flag: Boolean;
begin
  inherited;
  Temp := inherited Text;
  Flag := True;
//  Temp := ClipFilename(Temp);
  if not Flag then Exit;
  if ValidFileName(Temp) then begin
    if DirExists(ExtractFilePath(Temp)) then SetInitialDir(ExtractFilePath(Temp));
    if (ExtractFileName(Temp) = '') or not ValidFileName(ExtractFileName(Temp)) then Temp := '';
    FDialog.FileName := Temp;
  end;
  FDialog.HelpContext := Self.HelpContext;
  Flag := FDialog.Execute;
  if Flag then Temp := FDialog.FileName;
  if CanFocus then SetFocus;
  if Flag then begin
    inherited Text := ExtFilename(Temp);
    SetInitialDir(ExtractFilePath(FDialog.FileName));
  end;
end;

function TsFilenameEdit.GetFileName: string;
begin
//  Result := ClipFilename(inherited Text);
  Result := inherited Text;
end;

procedure TsFilenameEdit.SetFileName(const Value: string);
begin
  if (Value = '') or ValidFileName(Value) then begin
    inherited Text := ExtFilename(Value);
    ClearFileList;
  end
  else raise EComboEditError.CreateFmt('Invalid file name', [Value]);
end;

function TsFilenameEdit.GetLongName: string;
begin
  Result := ShortToLongFileName(FileName);
end;

function TsFilenameEdit.GetShortName: string;
begin
  Result := LongToShortFileName(FileName);
end;

procedure TsFilenameEdit.ClearFileList;
begin
  FDialog.Files.Clear;
end;

procedure TsFilenameEdit.ReceptFileDir(const AFileName: string);
begin
  if FMultipleDirs then begin
    if FDialog.Files.Count = 0 then SetFileName(AFileName);
    FDialog.Files.Add(AFileName);
  end
  else SetFileName(AFileName);
end;

function TsFilenameEdit.GetDialogFiles: TStrings;
begin
  Result := FDialog.Files;
end;

function TsFilenameEdit.GetDefaultExt: string;
begin
  Result := FDialog.DefaultExt;
end;

function TsFilenameEdit.GetFileEditStyle: TFileEditStyle;
begin
  Result := FDialog.FileEditStyle;
end;

function TsFilenameEdit.GetFilter: string;
begin
  Result := FDialog.Filter;
end;

function TsFilenameEdit.GetFilterIndex: Integer;
begin
  Result := FDialog.FilterIndex;
end;

function TsFilenameEdit.GetInitialDir: string;
begin
  Result := FDialog.InitialDir;
end;

function TsFilenameEdit.GetHistoryList: TStrings;
begin
  Result := FDialog.HistoryList;
end;

function TsFilenameEdit.GetOptions: TOpenOptions;
begin
  Result := FDialog.Options;
end;

function TsFilenameEdit.GetDialogTitle: string;
begin
  Result := FDialog.Title;
end;

procedure TsFilenameEdit.SetDialogKind(Value: TFileDialogKind);
begin
  if FDialogKind <> Value then begin
    FDialogKind := Value;
    CreateEditDialog;
  end;
end;

procedure TsFilenameEdit.SetDefaultExt(Value: string);
begin
  FDialog.DefaultExt := Value;
end;

procedure TsFilenameEdit.SetFileEditStyle(Value: TFileEditStyle);
begin
  FDialog.FileEditStyle := Value;
end;

procedure TsFilenameEdit.SetFilter(const Value: string);
begin
  FDialog.Filter := Value;
end;

procedure TsFilenameEdit.SetFilterIndex(Value: Integer);
begin
  FDialog.FilterIndex := Value;
end;

procedure TsFilenameEdit.SetInitialDir(const Value: string);
begin
  FDialog.InitialDir := Value;
end;

procedure TsFilenameEdit.SetHistoryList(Value: TStrings);
begin
  FDialog.HistoryList := Value;