adbcombo.pas

来自「delphi编程控件」· PAS 代码 · 共 851 行 · 第 1/2 页

unit adbcombo;
(*
 COPYRIGHT (c) RSD Software 1997 - 98
 All Rights Reserved.
*)

interface
uses controls, windows, messages, stdctrls, classes, DB, DBTables,
SysUtils, DBCtrls;

type

TDBComboBoxOrder = (AscOrder, DescOrder, DefaultOrder, SmartOrder);
TDBComboBoxBeforeRefresh = procedure(Sender : TObject; SQL : TStrings) of object;

TAutoCustomDBComboBox = class(TCustomComboBox)
private
  hwndList : HWND;
  FComboListInstance: Pointer;
  FDefComboListProc: Pointer;
  FQuery : TQuery;
  FDataSource : TDataSource;
  FDataLink : TDataLink;
  FDataBaseName : TFileName;
  FFieldName : String;
  FTableName : TFileName;
  UpdateFlag : Boolean;
  FroseSetCurSel : Boolean;
  FDBComboBoxOrder : TDBComboBoxOrder;
  FRefreshAlways : Boolean;
  FOnBeforeRefresh : TDBComboBoxBeforeRefresh;
  FLoadPartial : Boolean;

  procedure SetDataBaseName(Value : TFileName);
  procedure SetTableName(Value : TFileName);
  procedure SetFieldName(Value : String);
  procedure SetDBComboBoxOrder(Value : TDBComboBoxOrder);
  procedure SetLoadPartial(Value : Boolean);

  procedure InitQuery(Active : Boolean);
  procedure DataSetChanged(ADataSet : TDataSet);
  procedure UpdateComboLBoxData;
  procedure ComboListWndProc(var Message: TMessage);
  procedure UpdateScrollBar;
protected
  procedure CreateWnd; override;
  procedure WndProc(var Message: TMessage); override;
  procedure DropDown; override;
  procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  function GetComboText: string;  
  property DataSource : TDataSource read FDataSource;
public
  constructor Create(AOwner : TComponent); override;
  destructor Destroy; override;

  function LoadRecords : Boolean;
  property Query : TQuery read FQuery;
  property Text;
published
  property DataBaseName : TFileName read FDataBaseName write SetDataBaseName;
  property FieldName : String read FFieldName write SetFieldName;
  property TableName : TFileName read FTableName write SetTableName;
  property RefreshAlways : Boolean read FRefreshAlways write FRefreshAlways;
  property DBComboBoxOrder : TDBComboBoxOrder read FDBComboBoxOrder write SetDBComboBoxOrder;
  property LoadPartial : Boolean read FLoadPartial write SetLoadPartial;
  property OnBeforeRefresh : TDBComboBoxBeforeRefresh read FOnBeforeRefresh write FOnBeforeRefresh;
  property Style;
  property Color;
  property Ctl3D;
  property DragMode;
  property DragCursor;
  property DropDownCount;
  property Enabled;
  property Font;
  property ItemHeight;
  property MaxLength;
  property ParentColor;
  property ParentCtl3D;
  property ParentFont;
  property ParentShowHint;
  property PopupMenu;
  property ShowHint;
  property TabOrder;
  property TabStop;
  property Visible;
  property OnChange;
  property OnClick;
  property OnDblClick;
  property OnDragDrop;
  property OnDragOver;
  property OnDrawItem;
  property OnDropDown;
  property OnEndDrag;
  property OnEnter;
  property OnExit;
  property OnKeyDown;
  property OnKeyPress;
  property OnKeyUp;
  property OnMeasureItem;
  property OnStartDrag;
end;

TAutoDBComboBox = class(TAutoCustomDBComboBox)
private
  FDataFieldLink: TFieldDataLink;

  procedure DataChange(Sender: TObject);
  procedure EditingChange(Sender: TObject);
  function GetDataField: string;
  function GetDataSource: TDataSource;
  function GetField: TField;
  function GetReadOnly: Boolean;
  procedure SetComboText(const Value: string);
  procedure SetDataField(const Value: string);
  procedure SetDataSource(Value: TDataSource);
  procedure SetEditReadOnly;
  procedure SetReadOnly(Value: Boolean);
  procedure UpdateData(Sender: TObject);
  procedure ActiveChange(Sender : TObject);
  procedure CMExit(var Message: TCMExit); message CM_EXIT;
  procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
protected
  procedure Change; override;
  procedure Click; override;
  procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
    ComboProc: Pointer); override;
  procedure CreateWnd; override;
  procedure DropDown; override;
  procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  procedure KeyPress(var Key: Char); override;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  procedure WndProc(var Message: TMessage); override;
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
  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;

TAutoDBComboBoxLocate = class(TAutoCustomDBComboBox)
private
  FDataFieldLink: TFieldDataLink;
  FOldLocateSt : String;
  FOptions : TLocateOptions; 

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

  procedure Locate;
  procedure ActiveChange(Sender : TObject);  
protected
  procedure Change; override;
  procedure Click; override;
  procedure KeyPress(var Key: Char); override;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
  property Field: TField read GetField;
published
  property DataField: string read GetDataField write SetDataField;
  property DataSource: TDataSource read GetDataSource write SetDataSource;
  property Options : TLocateOptions read FOptions write FOptions;
end;

implementation

uses
  forms;

type
TAutoCustomDBComboDataLink = class(TDataLink)
private
   Control : TAutoCustomDBComboBox;
protected
   procedure DataSetScrolled(Distance: Integer); override;
   procedure DataSetChanged; override;
end;

procedure TAutoCustomDBComboDataLink.DataSetScrolled(Distance: Integer);
begin
  if Not (Control.FLoadPartial) then exit;
  Control.UpdateComboLBoxData;
  Control.UpdateScrollBar;
end;

procedure TAutoCustomDBComboDataLink.DataSetChanged;
begin
  if Not (Control.FLoadPartial) then exit;
  Control.UpdateComboLBoxData;
  Control.UpdateScrollBar;
end;

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

  FComboListInstance := MakeObjectInstance(ComboListWndProc);
  FQuery := TQuery.Create(self);
  FDataSource := TDataSource.Create(self);
  FDataSource.DataSet := FQuery;
  FDataLink := TAutoCustomDBComboDataLink.Create;
  with TAutoCustomDBComboDataLink(FDataLink) do begin
    FDataLink.DataSource := FDataSource;
    Control := self;
  end;  
  UpdateFlag := False;
  FDBComboBoxOrder := AscOrder;
  FRefreshAlways := True;
  FLoadPartial := False;
end;

destructor TAutoCustomDBComboBox.Destroy;
begin
  FDataLink.Free;
  FDataSource.Free;
  FQuery.Free;
  FreeObjectInstance(FComboListInstance);
  
  inherited;
end;

procedure TAutoCustomDBComboBox.CreateWnd;
begin
  inherited CreateWnd;
  hwndList := 0;
end;


procedure TAutoCustomDBComboBox.ComboListWndProc(var Message: TMessage);
begin
  with Message do begin
    if FLoadPartial then
      case Msg of
        WM_VSCROLL:
        if(FDataLink.Active) then begin
          with TWMVScroll(Message), FQuery do
            case ScrollCode of
              SB_LINEUP: MoveBy(-ItemIndex - 1);
              SB_LINEDOWN: MoveBy(FDataLink.RecordCount - ItemIndex);
              SB_PAGEUP: MoveBy(-FDataLink.RecordCount - ItemIndex + 1);
              SB_PAGEDOWN: MoveBy(FDataLink.RecordCount - ItemIndex + FDataLink.RecordCount - 2);
              SB_THUMBPOSITION: begin
                case Pos of
                  0: First;
                  1: MoveBy(-ItemIndex - FDataLink.RecordCount + 1);
                  2: Exit;
                  3 : MoveBy(FDataLink.RecordCount - ItemIndex + FDataLink.RecordCount - 2);
                  4: Last;
                end;
              end;
              SB_BOTTOM: Last;
              SB_TOP: First;
            end;
          exit;
        end;
        WM_ERASEBKGND, WM_NCPAINT, WM_PAINT:
           if(UpdateFlag) then exit;
        WM_MOUSEMOVE:
          if (FroseSetCurSel) then begin
            FroseSetCurSel := False;
            exit;
          end;
      end;
    Result := CallWindowProc(FDefComboListProc, hwndList, Msg, WParam, LParam);
  end;
  if FLoadPartial then
    UpdateScrollBar;
end;


procedure TAutoCustomDBComboBox.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_CTLCOLORLISTBOX:
      if (hwndList = 0) then begin
        hwndList := Message.lParam;
        FDefComboListProc := Pointer(GetWindowLong(hwndList, GWL_WNDPROC));
        SetWindowLong(hwndList, GWL_WNDPROC, Longint(FComboListInstance));
      end;
    WM_PAINT: if(UpdateFlag) And FLoadPartial then exit;
  end;
  inherited;
end;

procedure TAutoCustomDBComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
Var
  OldIndex : Integer;
begin
  if Not FDataLink.Active Or UpdateFlag Or FLoadPartial then exit;
  Canvas.FillRect(Rect);
  OldIndex := FDataLink.ActiveRecord;
  FDataLink.ActiveRecord := Index;
  Canvas.TextOut(Rect.Left + 2, Rect.Top, FQuery.Fields[0].Text);
  FDataLink.ActiveRecord := OldIndex;
end;


procedure TAutoCustomDBComboBox.UpdateScrollBar;
var
  Pos, Max: Integer;
  ScrollInfo: TScrollInfo;
begin
  Pos := 0;
  Max := 0;
  if FDataLink.RecordCount = FDataLink.BufferCount then
  begin
    Max := 60;
    if not FDataLink.DataSet.BOF then
      if not FDataLink.DataSet.EOF then Pos := 30 else Pos := 60;
  end;
  ScrollInfo.cbSize := SizeOf(TScrollInfo);
  ScrollInfo.fMask := SIF_POS or SIF_RANGE;
  if not GetScrollInfo(hwndList, SB_VERT, ScrollInfo) or
    (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
  begin
    with ScrollInfo do begin
      nMin := 0;
      nMax := Max;
      nPos := Pos;
    end;
    SetScrollInfo(hwndList, SB_VERT, ScrollInfo, True);
  end;
end;

procedure TAutoCustomDBComboBox.DropDown;
begin
 if(FRefreshAlways) And FQuery.Active then
   InitQuery(False);
 InitQuery(True);
 if(FDataLink.Active) And (Length(Text) > 0) And FLoadPartial then
   FQuery.Locate(FFieldName, Text, [loCaseInsensitive, loPartialKey]);
 if (FLoadPartial) then 
   UpdateComboLBoxData;
 inherited;
end;

procedure TAutoCustomDBComboBox.KeyDown(var Key: Word; Shift: TShiftState);
var
  Delta: Integer;
begin

  inherited KeyDown(Key, Shift);

  if Not FDataLink.Active Or (FLoadPartial)then exit;
  FroseSetCurSel := True;
  FDataLink.ActiveRecord := ItemIndex;
  Delta := 0;
  case Key of
    VK_UP:
      if(ItemIndex = 0) then Delta := -1;
    VK_DOWN:
      if(ItemIndex = DropDownCount - 1) then Delta := 1;
    VK_PRIOR: Delta := 1 - DropDownCount;
    VK_NEXT: Delta := DropDownCount - 1;
    VK_HOME: Delta := -Maxint;
    VK_END: Delta := Maxint;
  end;
  if (Delta <> 0) then  begin
    if Delta = -Maxint then FDataLink.DataSet.First else
      if Delta = Maxint then FDataLink.DataSet.Last else
        FDataLink.DataSet.MoveBy(Delta);
  end;
end;


function TAutoCustomDBComboBox.GetComboText: string;
var
  I: Integer;
begin
  if Style in [csDropDown, csSimple] then Result := Text else
  begin
    I := ItemIndex;
    if I < 0 then Result := '' else Result := Items[I];
  end;
end;


procedure TAutoCustomDBComboBox.DataSetChanged(ADataSet : TDataSet);
Var
  Sts : TStrings;
  St : String;
  i, j : Integer;
begin
  if(ADataSet <> Nil) And ((FDataBaseName = '') Or (FTableName = '')) then begin
    if(ADataSet is TTable) then begin
      FTableName := TTable(ADataSet).TableName;
      FDataBaseName := TTable(ADataSet).DataBaseName;
    end;
    if(ADataSet is TQuery) then begin
      FDataBaseName := TQuery(ADataSet).DataBaseName;
      Sts := TQuery(ADataSet).SQL;
      for i := 0 to Sts.Count - 1 do
        if(Pos('FROM', UpperCase(Sts[i])) > 0) then begin
          St := Copy(Sts[i], Pos('FROM', UpperCase(Sts[i])) + 1, 1000);
          St := TrimLeft(St);
          for j := 1 to Length(St) do
            if(St[j] = ' ') Or (St[j] = ',') then begin
              St := Copy(St, 1, j - 1);
              break;
             end;
           break;
        end;
      FTableName := St;
    end;
  end;
end;

procedure TAutoCustomDBComboBox.InitQuery(Active : Boolean);
begin
  with Query do begin
    Close;
    DataBaseName := FDataBaseName;
    SQL.Clear;
    if (FDBComboBoxOrder = SmartOrder) then
      SQL.Add('Select ' + FFieldName + ', Count('+FFieldName+')')
    else SQL.Add('Select Distinct ' + FFieldName);
    SQL.Add('From ' + FTableName);
    case FDBComboBoxOrder of