dblookup.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

    (DataSource.DataSet = LookupSource.DataSet)) then
    raise EInvalidOperation.Create(SLookupSourceError);
  if (FGrid.Value <> NewValue) or (Text <> NewValue) then
    if FGrid.DataLink.Active then
    begin
      FGrid.Value := NewValue;
      Text := FGrid.DisplayValue;
    end;
end;

function TDBLookupCombo.GetReadOnly: Boolean;
begin
  Result := FFieldLink.ReadOnly;
end;

procedure TDBLookupCombo.SetReadOnly(Value: Boolean);
begin
  FFieldLink.ReadOnly := Value;
  inherited ReadOnly := not CanEdit;
end;

procedure TDBLookupCombo.EditingChange(Sender: TObject);
begin
  inherited ReadOnly := not CanEdit;
end;

procedure TDBLookupCombo.UpdateData(Sender: TObject);
begin
  if FFieldLink.Field <> nil then
    if Editable then
      FFieldLink.Field.AsString := Text else
      FFieldLink.Field.AsString := FGrid.Value;
end;

procedure TDBLookupCombo.FieldLinkActive(Sender: TObject);
begin
  if FFieldLink.Active and FGrid.DataLink.Active then
  begin
    FGrid.SetValue('');
    DataChange(Self)
  end;
end;

procedure TDBLookupCombo.WMPaste(var Message: TMessage);
begin
  if Editable then FFieldLink.Edit;
  if CanEdit then inherited;
end;

procedure TDBLookupCombo.WMCut(var Message: TMessage);
begin
  if Editable then FFieldLink.Edit;
  if CanEdit then inherited;
end;

procedure TDBLookupCombo.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
end;

procedure TDBLookupCombo.CreateWnd;
begin
  inherited CreateWnd;
  SetEditRect;
  FGrid.HandleNeeded;
  DataChange(Self);
end;

procedure TDBLookupCombo.SetEditRect;
var
  Loc: TRect;
begin
  Loc.Bottom := ClientHeight + 1;  {+1 is workaround for windows paint bug}
  Loc.Right := FBtnControl.Left - 2;
  Loc.Top := 0;
  Loc.Left := 0;
  SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
end;

procedure TDBLookupCombo.WMSize(var Message: TWMSize);
var
  MinHeight: Integer;
begin
  inherited;
  if (csDesigning in ComponentState) then
    FGrid.SetBounds(0, Height + 1, 10, 10);
  MinHeight := GetMinHeight;
  if Height < MinHeight then Height := MinHeight
  else begin
    if NewStyleControls then
      FBtnControl.SetBounds(ClientWidth - FButton.Width, 0, FButton.Width, ClientHeight)
    else
      FBtnControl.SetBounds(ClientWidth - FButton.Width, 1, FButton.Width, ClientHeight - 1);
    FButton.Height := FBtnControl.Height;
    SetEditRect;
  end;
end;

function TDBLookupCombo.GetMinHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  I: Integer;
  SysMetrics, Metrics: TTextMetric;
begin
  DC := GetDC(0);
  GetTextMetrics(DC, SysMetrics);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  I := SysMetrics.tmHeight;
  if I > Metrics.tmHeight then I := Metrics.tmHeight;
  FTextMargin := I div 4;
  Result := Metrics.tmHeight + FTextMargin + GetSystemMetrics(SM_CYBORDER) * 4 + 1;
end;

procedure TDBLookupCombo.WMPaint(var Message: TWMPaint);
var
  PS: TPaintStruct;
  ARect: TRect;
  TextLeft, TextTop: Integer;
  Focused: Boolean;
  DC: HDC;
const
  Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT,
    DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
begin
  if Editable then
  begin
    inherited;
    Exit;
  end;

  if FCanvas = nil then
  begin
    FCanvas := TControlCanvas.Create;
    FCanvas.Control := Self;
  end;

  DC := Message.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  FCanvas.Handle := DC;
  try
    Focused := GetFocus = Handle;
    FCanvas.Font := Font;
    with FCanvas do
    begin
      ARect := ClientRect;
      Brush.Color := clWindowFrame;
      FrameRect(ARect);
      InflateRect(ARect, -1, -1);
      Brush.Style := bsSolid;
      Brush.Color := Color;
      FillRect (ARect);
      TextTop := FTextMargin;
      ARect.Left := ARect.Left + 2;
      ARect.Right := FBtnControl.Left - 2;
      TextLeft := FTextMargin;
      if Focused then
      begin
        Brush.Color := clHighlight;
        Font.Color := clHighlightText;
        ARect.Top := ARect.Top + 2;
        ARect.Bottom := ARect.Bottom - 2;
      end;
      ExtTextOut(FCanvas.Handle, TextLeft, TextTop, ETO_OPAQUE or ETO_CLIPPED, @ARect,
        PChar(Text), Length(Text), nil);
      if Focused then
        DrawFocusRect(ARect);
    end;
  finally
    FCanvas.Handle := 0;
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
end;

procedure TDBLookupCombo.CMFontChanged(var Message: TMessage);
begin
  inherited;
  GetMinHeight;
end;

procedure TDBLookupCombo.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  FButton.Enabled := Enabled;
end;

procedure TDBLookupCombo.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  CloseUp;
end;

procedure TDBLookupCombo.CMCancelMode(var Message: TCMCancelMode);
begin
  with Message do
    if (Sender <> Self) and (Sender <> FBtnControl) and
      (Sender <> FButton) and (Sender <> FGrid) then CloseUp;
end;

procedure TDBLookupCombo.CMHintShow(var Message: TMessage);
begin
  Message.Result := Integer(FGrid.Visible);
end;

procedure TDBLookupCombo.DropDown;
var
  ItemCount: Integer;
  P: TPoint;
  Y: Integer;
  GridWidth, GridHeight, BorderWidth: Integer;
  SysBorderWidth, SysBorderHeight: Integer;
begin
  if not FGrid.Visible and (Width > 20) then
  begin
    if Assigned(FOnDropDown) then FOnDropDown(Self);
    ItemCount := DropDownCount;
    if ItemCount = 0 then ItemCount := 1;
    SysBorderWidth := GetSystemMetrics(SM_CXBORDER);
    SysBorderHeight := GetSystemMetrics(SM_CYBORDER);
    P := ClientOrigin;
    if NewStyleControls then
    begin
      Dec(P.X, 2 * SysBorderWidth);
      Dec(P.Y, SysBorderHeight);
    end;
    if loRowLines in Options then
      BorderWidth := 1 else
      BorderWidth := 0;
    GridHeight := (FGrid.DefaultRowHeight + BorderWidth) *
      (ItemCount + FGrid.FTitleOffset) + 2;
    FGrid.Height := GridHeight;
    if ItemCount > FGrid.RowCount then
    begin
      ItemCount := FGrid.RowCount;
      GridHeight := (FGrid.DefaultRowHeight + BorderWidth) *
        (ItemCount + FGrid.FTitleOffset) + 4;
    end;
    if NewStyleControls then
      Y := P.Y + ClientHeight + 3 * SysBorderHeight else
      Y := P.Y + Height - 1;
    if (Y + GridHeight) > Screen.Height then
    begin
      Y := P.Y - GridHeight + 1;
      if Y < 0 then
      begin
        if NewStyleControls then
          Y := P.Y + ClientHeight + 3 * SysBorderHeight else
          Y := P.Y + Height - 1;
      end;
    end;
    GridWidth := DropDownWidth;
    if GridWidth = 0 then
    begin
      if NewStyleControls then
        GridWidth := Width + 2 * SysBorderWidth else
        GridWidth := Width - 4;
    end;
    if NewStyleControls then
      SetWindowPos(FGrid.Handle, 0, P.X, Y, GridWidth, GridHeight, SWP_NOACTIVATE) else
      SetWindowPos (FGrid.Handle, 0, P.X + Width - GridWidth, Y, GridWidth, GridHeight, SWP_NOACTIVATE);
    if Length(LookupField) = 0 then
      FGrid.DisplayValue := Text;
    FGrid.Visible := True;
    Windows.SetFocus(Handle);
  end;
end;

procedure TDBLookupCombo.CloseUp;
begin
  FGrid.Visible := False;
end;

procedure TDBLookupCombo.GridClick(Sender: TObject);
begin
  FFieldLink.Edit;
  if (FFieldLink.DataSource = nil) or FFieldLink.Editing then
  begin
    FFieldLink.Modified;
    Text := FGrid.DisplayValue;
  end;
end;

procedure TDBLookupCombo.SetStyle(Value: TDBLookupComboStyle);
begin
  if FStyle <> Value then
    FStyle := Value;
end;

procedure TDBLookupCombo.WMLButtonDown(var Message: TWMLButtonDown);
begin
  if Editable then
    inherited
  else
    NonEditMouseDown(Message);
end;

procedure TDBLookupCombo.WMLButtonUp(var Message: TWMLButtonUp);
begin
  if not Editable then MouseCapture := False;
  inherited;
end;

procedure TDBLookupCombo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  if Editable then
    inherited
  else
    NonEditMouseDown(Message);
end;

procedure TDBLookupCombo.NonEditMouseDown(var Message: TWMLButtonDown);
var
  CtrlState: TControlState;
begin
  SetFocus;
  HideCaret (Handle);

  if FGrid.Visible then CloseUp
  else DropDown;

  MouseCapture := True;
  if csClickEvents in ControlStyle then
  begin
    CtrlState := ControlState;
    Include(CtrlState, csClicked);
    ControlState := CtrlState;
  end;
  with Message do
    MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);
end;

procedure MouseDragToGrid(Ctrl: TControl; Grid: TPopupGrid; X, Y: Integer);
var
  pt, clientPt: TPoint;
begin
  if Grid.Visible then
  begin
    pt.X := X;
    pt.Y := Y;
    pt := Ctrl.ClientToScreen (pt);
    clientPt := Grid.ClientOrigin;
    if (pt.X >= clientPt.X) and (pt.Y >= clientPt.Y) and
       (pt.X <= clientPt.X + Grid.ClientWidth) and
       (pt.Y <= clientPt.Y + Grid.ClientHeight) then
    begin
      Ctrl.Perform(WM_LBUTTONUP, 0, MakeLong (X, Y));
      pt := Grid.ScreenToClient(pt);
      Grid.Perform(WM_LBUTTONDOWN, 0, MakeLong (pt.x, pt.y));
    end;
  end;
end;

procedure TDBLookupCombo.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  if (ssLeft in Shift) and not Editable and (GetCapture = Handle) then
    MouseDragToGrid(Self, FGrid, X, Y);
end;

procedure TDBLookupCombo.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  if not Editable then HideCaret(Handle);
end;

procedure TDBLookupCombo.CMExit(var Message: TCMExit);
begin
  try
    FFieldLink.UpdateRecord;
  except
    DoSelectAll;
    SetFocus;
    raise;
  end;
  inherited;
  if not Editable then Invalidate;
end;

procedure TDBLookupCombo.CMEnter(var Message: TCMGotFocus);
begin
  if AutoSelect and not (csLButtonDown in ControlState) then DoSelectAll;
  inherited;
  if not Editable then Invalidate;
end;

procedure TDBLookupCombo.DoSelectAll;
begin
  if Editable then SelectAll;
end;

procedure TDBLookupCombo.SetOptions(Value: TDBLookupListOptions);
begin
  FGrid.Options := Value;
end;

function TDBLookupCombo.GetOptions: TDBLookupListOptions;
begin
  Result := FGrid.Options;
end;

procedure TDBLookupCombo.Loaded;
begin
  inherited Loaded;
  DataChange(Self);
end;

{ TLookupList }

constructor TDBLookupList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFieldLink := TFieldDataLink.Create;
  FFieldLink.Control := Self;
  FFieldLink.OnDataChange := DataChange;
  FFieldLink.OnUpdateData := UpdateData;
  FFieldLink.OnActiveChange := FieldLinkActive;
  FTitleOffset := 0;
  FUpdateFields := False;
  FHiliteRow := -1;
  inherited Options := [dgRowSelect];
  FixedCols := 0;
  FixedRows := 0;
  Width := 121;
  Height := 97;
end;

destructor TDBLookupList.Destroy;
begin
  FFieldLink.OnDataChange := nil;
  FFieldLink.Free;
  FFieldLink := nil;
  inherited Destroy;
end;

procedure TDBLookupList.CreateWnd;
begin
  inherited CreateWnd;
  DataChange(Self);
end;

procedure TDBLookupList.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FFieldLink <> nil) and
    (AComponent = DataSource) then
    DataSource := nil;
end;

function TDBLookupList.GetDataSource: TDataSource;
begin
  Result := FFieldLink.DataSource;
end;

procedure TDBLookupList.SetDataSource(Value: TDataSource);
begin
  if (Value <> nil) and ((Value = LookupSource) or ((Value.DataSet <> nil)
    and (Value.DataSet = DataLink.DataSet))) then
    raise EInvalidOperation.Create(SLookupSourceError);
  FFieldLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

function TDBLookupList.GetLookupSource: TDataSource;
begin
  Result := inherited DataSource;
end;

procedure TDBLookupList.NewLayout;
begin
  InitFields(True);
  LayoutChanged;
  FValue := '';
  DataChange(Self);
end;

procedure TDBLookupList.SetLookupSource(Value: TDataSource);
begin
  if (Value <> nil) and ((Value = DataSource) or
    ((Value.DataSet <> nil) and (Value.DataSet = FFieldLink.DataSet))) then
    raise EInvalidOperation.Create(SLookupSourceError);
  if (Value <> nil) and (Value.DataSet <> nil) and
    not (Value.DataSet.InheritsFrom(TTable)) then
    raise EInvalidOperation.Create(SLookupTableError);
  inherited DataSource := Value;
  NewLayout;
end;

procedure TDBLookupList.SetLookupDisplay(const Value: string);
begin
  if Value <> LookupDisplay then
  begin
    FLookupDisplay := Value;
    NewLayout;
  end;
end;

procedure TDBLookupList.SetLookupField(const Value: string);
begin
  if Value <> LookupField then
  begin
    FLookupField := Value;
    NewLayout;
  end;
end;

procedure TDBLookupList.SetValue(const Value: string);
begin
  if DataLink.Active and FFieldLink.Active and
    ((DataSource = LookupSource) or