aflookup.pas

来自「delphi编程控件」· PAS 代码 · 共 1,439 行 · 第 1/3 页

unit aflookup;
(*
 COPYRIGHT (c) RSD software 1997 - 98
 All Rights Reserved.
*)

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB;

type
  TAutoCustomLookup = class;

  TAutoListSourceLink = class(TDataLink)
  private
    AutoCustomLookup: TAutoCustomLookup;
  protected
    procedure ActiveChanged; override;
    procedure DataSetChanged; override;
  end;

  TAutoCustomLookup = class(TCustomControl)
  private
    FLookupSource: TDataSource;
    FListLink: TAutoListSourceLink;
    FKeyFieldName: string;
    FListFieldName: string;
    FListFieldIndex: Integer;
    FKeyField: TField;
    FListField: TField;
    FListFields: TList;
    FKeyValue: Variant;
    FSearchText: string;
    FFocused: Boolean;
    FItems : TStrings;
    FItemsAlignment : TAlignment;
    FItemsColor : TColor;
    IsValueItems : Integer;
    FCaption : Boolean;

    function GetBorderSize: Integer;
    function GetKeyFieldName: string;
    function GetListSource: TDataSource;
    function GetTextHeight: Integer;
    procedure ItemsChange(Sender : TObject);
    procedure ListLinkActiveChanged; virtual;
    procedure ListLinkDataChanged; virtual;
    function LocateKey: Boolean;
    procedure ProcessSearchKey(Key: Char);
    procedure SelectKeyValue(const Value: Variant);
    procedure SetItems(Value: TStrings);
    procedure SetItemIndex(Value : Integer);
    procedure SetItemsColor(Value: TColor);
    procedure SetKeyFieldName(const Value: string);
    procedure SetKeyValue(const Value: Variant);
    procedure SetListFieldName(const Value: string);
    procedure SetListSource(Value: TDataSource);
    procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
    procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
    procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  protected
    FListActive: Boolean;

    function GetItemsLabel(Index : Integer) : String;
    function GetItemsValue(Index : Integer) : Variant;
    function FindItemsValue(V : Variant) : Integer;
    procedure KeyValueChanged; virtual;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    property Items: TStrings read FItems write SetItems;
    property ItemIndex : Integer read IsValueItems write SetItemIndex;
    property ItemsColor : TColor read FItemsColor write SetItemsColor;
    property ItemsAlignment : TAlignment read FItemsAlignment write FItemsAlignment;
    property KeyValue: Variant read FKeyValue write SetKeyValue;
    property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
    property ParentColor default False;
    property TabStop default True;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property KeyField: string read GetKeyFieldName write SetKeyFieldName;
    property ListField: string read FListFieldName write SetListFieldName;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property Caption : Boolean read FCaption write FCaption;
  end;

  TAutoCustomLookupList = class(TAutoCustomLookup)
  private
    FRecordIndex: Integer;
    FRecordCount: Integer;
    FRealRowCount: Integer;
    FRowCount: Integer;
    FBorderStyle: TBorderStyle;
    FKeySelected: Boolean;
    FTracking: Boolean;
    FTimerActive: Boolean;
    FLockPosition: Boolean;
    FMousePos: Integer;
    FPopup : Boolean;
    function GetKeyIndex(Delta : Integer): Boolean;
    procedure ListLinkActiveChanged; override;
    procedure ListLinkDataChanged; override;
    procedure SelectCurrent;
    procedure SelectItemAt(X, Y: Integer);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetRowCount(Value: Integer);
    procedure StopTimer;
    procedure StopTracking;
    procedure TimerScroll;
    procedure UpdateScrollBar;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
    procedure WMTimer(var Message: TMessage); message WM_TIMER;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure KeyValueChanged; override;    
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property KeyValue;
  published
    property Align;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Caption;    
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property Items;
    property ItemsAlignment;
    property ItemsColor;
    property KeyField;
    property ListField;
    property ListFieldIndex;
    property ListSource;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property RowCount: Integer read FRowCount write SetRowCount stored False;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    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;
  end;

  TAutoDBLookupList = class(TAutoCustomLookupList)
  end;

  TAutoPopupDataList = class(TAutoCustomLookupList)
  private
    procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;


  TAutoDropDownAlign = (daLeft, daRight, daCenter);

  TAutoCustomLookupCombo = class(TAutoCustomLookup)
  private
    FDataList: TAutoPopupDataList;
    FText: string;
    FDropDownRows: Integer;
    FDropDownWidth: Integer;
    FDropDownAlign: TAutoDropDownAlign;
    FListVisible: Boolean;
    FTracking: Boolean;
    FAlignment: TAlignment;
    FOnDropDown: TNotifyEvent;
    FOnCloseUp: TNotifyEvent;
    procedure ListLinkActiveChanged; override;
    procedure ListMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure StopTracking;
    procedure TrackButton(X, Y: Integer);
    procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  protected
    FButtonWidth: Integer;
    FPressed: Boolean;
          
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure KeyValueChanged; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure CloseUp(Accept: Boolean);
    procedure DropDown;
    property KeyValue;
    property ListVisible: Boolean read FListVisible;
    property Text: string read FText;
  published
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property DropDownAlign: TAutoDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
    property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;
    property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
    property Enabled;
    property Font;
    property Items;
    property ItemsAlignment;    
    property ItemsColor;
    property KeyField;
    property ListField;
    property ListFieldIndex;
    property ListSource;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

implementation
{ TListSourceLink }

procedure TAutoListSourceLink.ActiveChanged;
begin
  if AutoCustomLookup <> nil then AutoCustomLookup.ListLinkActiveChanged;
end;

procedure TAutoListSourceLink.DataSetChanged;
begin
  if AutoCustomLookup <> nil then AutoCustomLookup.ListLinkDataChanged;
end;

{ TAutoCustomLookup }

function VarEquals(const V1, V2: Variant): Boolean;
begin
  Result := False;
  try
    Result := V1 = V2;
  except
  end;
end;

var
  SearchTickCount: Integer = 0;

constructor TAutoCustomLookup.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if NewStyleControls then
    ControlStyle := [csOpaque] else
    ControlStyle := [csOpaque, csFramed];
  ParentColor := False;
  TabStop := True;
  FItems := TStringList.Create;
  TStringList(FItems).OnChange := ItemsChange;
  FLookupSource := TDataSource.Create(Self);
  FListLink := TAutoListSourceLink.Create;
  FListLink.AutoCustomLookup := Self;
  FListFields := TList.Create;
  FKeyValue := Null;
  FItemsColor := clBtnFace;
  IsValueItems := -1;
end;

destructor TAutoCustomLookup.Destroy;
begin
  FItems.Free;
  FListFields.Free;
  FListLink.AutoCustomLookup := nil;
  FListLink.Free;
  inherited Destroy;
end;

function TAutoCustomLookup.GetBorderSize: Integer;
var
  Params: TCreateParams;
  R: TRect;
begin
  CreateParams(Params);
  SetRect(R, 0, 0, 0, 0);
  AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  Result := R.Bottom - R.Top;
end;

function TAutoCustomLookup.GetKeyFieldName: string;
begin
  Result := FKeyFieldName;
end;

function TAutoCustomLookup.GetListSource: TDataSource;
begin
  Result := FListLink.DataSource;
end;

function TAutoCustomLookup.GetTextHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  Result := Metrics.tmHeight;
end;

procedure TAutoCustomLookup.KeyValueChanged;
begin
end;

procedure TAutoCustomLookup.ItemsChange(Sender : TObject);
begin
  Paint;
end;  

procedure TAutoCustomLookup.ListLinkActiveChanged;
var
  DataSet: TDataSet;
begin
  FListActive := False;
  FKeyField := nil;
  FListField := nil;
  FListFields.Clear;
  if FListLink.Active and (FKeyFieldName <> '') then  begin
    DataSet := FListLink.DataSet;
    FKeyField := DataSet.FieldByName(FKeyFieldName);
    DataSet.GetFieldList(FListFields, FListFieldName);
    if FListFields.Count = 0 then FListFields.Add(FKeyField);
     if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
       FListField := FListFields[FListFieldIndex] else
       FListField := FListFields[0];
    FListActive := True;
  end;
end;

procedure TAutoCustomLookup.ListLinkDataChanged;
begin
end;

function TAutoCustomLookup.LocateKey: Boolean;
begin
  Result := False;

  IsValueItems := FindItemsValue(FKeyValue);
  if(IsValueItems > -1) then begin;
    Result := True;
    exit;
  end;
  if not VarIsNull(FKeyValue) then begin
    try
      if FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
        Result := True;
    except
    end;
  end;
end;

function TAutoCustomLookup.FindItemsValue(V : Variant) : Integer;
Var
  i : Integer;
begin
  Result := -1;
  for i := 0 to Items.Count - 1 do
    if Not VarIsNull(V) then begin
      if VarEquals(V, GetItemsValue(i)) then begin
        Result := i;
        exit;
      end;
    end
    else if VarIsNull(GetItemsValue(i)) then begin
       Result := i;
       exit;
    end;  
end;

function TAutoCustomLookup.GetItemsLabel(Index : Integer) : String;
Var
  p : Integer;
begin
  Result := '';
  if(Index > -1) And (Index < FItems.Count) then begin
    p := Pos(',', FItems[Index]);
    if(p > 0) then
      Result := Copy(FItems[Index], 1, p - 1)
    else Result := FItems[Index];
  end;
end;

function TAutoCustomLookup.GetItemsValue(Index : Integer) : Variant;
Var
  p : Integer;
  St : String;
begin
  St := '';
  if(Index > -1) And (Index < FItems.Count) then begin
    p := Pos(',', FItems[Index]);
    if(p > 0) then
      St := Copy(FItems[Index], p + 1, 1000)
    else St := FItems[Index];
  end;
  if(St = '') then
    Result := Null
  else Result := Variant(St);
end;

procedure TAutoCustomLookup.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FListLink <> nil)
  and (AComponent = ListSource) then ListSource := nil;
end;

procedure TAutoCustomLookup.ProcessSearchKey(Key: Char);
var
  TickCount: Integer;
  S: string;