dblookup.pas

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

    (DataSource.DataSet = LookupSource.DataSet)) then
    raise EInvalidOperation.Create(SLookupSourceError);

  if (FValue <> Value) or (Row = FTitleOffset) then
    if DataLink.Active and (FValueFld <> nil) then
    begin
      FValue := Value;
      FHiliteRow := -1;
      DoLookup;
      if FFoundValue and (FValueFld <> FDisplayFld) then
        FDisplayValue := FDisplayFld.AsString
      else if (FValueFld = FDisplayFld) then FDisplayValue := FValue
      else FDisplayValue := '';
    end;
end;

procedure TDBLookupList.SetDisplayValue(const Value: string);
begin
  if (FDisplayValue <> Value) or (Row = FTitleOffset) then
  begin
    FFoundValue := False;
    if DataLink.Active and (FDisplayFld <> nil) then
    begin
      FHiliteRow := -1;
      FFoundValue := False;
      if inherited DataSource.DataSet is TTable then
        with TTable(inherited DataSource.DataSet) do
        begin
          SetKey;
          FDisplayFld.AsString := Value;
          FFoundValue := GotoKey;
        end;
      FDisplayValue := Value;
      if FValueFld = FDisplayFld then FValue := FDisplayValue
      else if not FFoundValue then
      begin
        FDisplayValue := '';
        FValue := '';
      end
      else FValue := FValueFld.AsString;
    end;
  end;
end;

procedure TDBLookupList.DoLookup;
begin
  FFoundValue := False;
  if not HandleAllocated then Exit;
  if Value = '' then Exit;
  if inherited DataSource.DataSet is TTable then
    with TTable(inherited DataSource.DataSet) do
    begin
      if (IndexFieldCount > 0) then
      begin
        if AnsiCompareText(IndexFields[0].FieldName, LookupField) <> 0 then
          raise EInvalidOperation.Create(Format(SLookupIndexError, [LookupField]));
      end;
      if State = dsSetKey then Exit;
      SetKey;
      FValueFld.AsString := Value;
      FFoundValue := GotoKey;
      if not FFoundValue then First;
    end;
end;

function TDBLookupList.GetDataField: string;
begin
  Result := FFieldLink.FieldName;
end;

procedure TDBLookupList.SetDataField(const Value: string);
begin
  FFieldLink.FieldName := Value;
end;

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

function TDBLookupList.CanEdit: Boolean;
begin
  Result := (FFieldLink.DataSource = nil) or FFieldLink.Editing;
end;

procedure TDBLookupList.SetReadOnly(Value: Boolean);
begin
  FFieldLink.ReadOnly := Value;
end;

procedure TDBLookupList.DataChange(Sender: TObject);
begin
  if (FFieldLink.Field <> nil) and not (csLoading in ComponentState) then
    Value := FFieldLink.Field.AsString else
    Value := '';
end;

procedure TDBLookupList.UpdateData(Sender: TObject);
begin
  if FFieldLink.Field <> nil then
    FFieldLink.Field.AsString := Value;
end;

procedure TDBLookupList.InitFields(ShowError: Boolean);
var
  Pos: Integer;
begin
  FDisplayFld := nil;
  FValueFld := nil;
  if not DataLink.Active or (Length(LookupField) = 0) then Exit;
  with Datalink.DataSet do
  begin
    FValueFld := FindField(LookupField);
    if (FValueFld = nil) and ShowError then
      raise EInvalidOperation.Create(Format(SFieldNotFound, [Self.Name, LookupField]))
    else if FValueFld <> nil then
    begin
      if Length(LookupDisplay) > 0 then
      begin
        Pos := 1;
        FDisplayFld := FindField(ExtractFieldName(LookupDisplay, Pos));
        if (FDisplayFld = nil) and ShowError then
        begin
          Pos := 1;
          raise EInvalidOperation.Create(Format(SFieldNotFound,
            [Self.Name, ExtractFieldName(LookupDisplay, Pos)]));
        end;
      end;
      if FDisplayFld = nil then FDisplayFld := FValueFld;
    end;
  end;
end;

procedure TDBLookupList.DefineFieldMap;
var
  Pos: Integer;
begin
  InitFields(False);
  if FValueFld <> nil then
  begin
    if Length(LookupDisplay) = 0 then
      Datalink.AddMapping (FValueFld.FieldName)
    else begin
      Pos := 1;
      while Pos <= Length(LookupDisplay) do
        Datalink.AddMapping(ExtractFieldName(LookupDisplay, Pos));
    end;
  end;
end;

procedure TDBLookupList.SetColumnAttributes;
var
  I: Integer;
  TotalWidth, BorderWidth: Integer;
begin
  inherited SetColumnAttributes;
  if FieldCount > 0 then
  begin
    BorderWidth := 0;
    if loColLines in FOptions then BorderWidth := 1;
    TotalWidth := 0;
    for I := 0 to ColCount - 2 do
      TotalWidth := TotalWidth + ColWidths[I] + BorderWidth;
    if (ColCount = 1) or (TotalWidth < (ClientWidth - 15)) then
      ColWidths[ColCount-1] := ClientWidth - TotalWidth;
  end;
end;

procedure TDBLookupList.WMSize(var Message: TWMSize);
begin
  inherited;
  SetColumnAttributes;
end;

function TDBLookupList.CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean;
var
  MyOnKeyDown: TKeyEvent;
begin
  Result := True;
  if Key = VK_INSERT then Result := False
  else if Key in [VK_UP, VK_DOWN, VK_NEXT, VK_RIGHT, VK_LEFT, VK_PRIOR,
    VK_HOME, VK_END] then
  begin
    FFieldLink.Edit;
    if (Key in [VK_UP, VK_DOWN, VK_RIGHT, VK_LEFT]) and not CanEdit then
      Result := False
    else if (inherited DataSource <> nil) and
      (inherited DataSource.State <> dsInactive) then
    begin
      if (FHiliteRow >= 0) and (FHiliteRow <> DataLink.ActiveRecord) then
      begin
        Row := FHiliteRow;
        Datalink.ActiveRecord := FHiliteRow;
      end
      else if (FHiliteRow < 0) then
      begin
        if FFoundValue then
          DoLookup
        else begin
          DataLink.DataSource.DataSet.First;
          Row := FTitleOffset;
          Key := 0;
          MyOnKeyDown := OnKeyDown;
          if Assigned(MyOnKeyDown) then MyOnKeyDown(Self, Key, Shift);
          InvalidateRow (FTitleOffset);
          ListClick;
          Result := False;
        end;
      end;
    end;
  end;
end;

procedure TDBLookupList.KeyDown(var Key: Word; Shift: TShiftState);
begin
  try
    FInCellSelect := True;
    inherited KeyDown (Key, Shift);
  finally
    FInCellSelect := False;
  end;
  if (Key in [VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR, VK_HOME, VK_END]) and
    CanEdit then ListClick;
end;

procedure TDBLookupList.KeyPress(var Key: Char);
begin
  inherited KeyPress (Key);
  case Key of
    #32..#255:
      DataLink.Edit;
    Char (VK_ESCAPE):
      begin
        FFieldLink.Reset;
        Key := #0;
      end;
  end;
end;

procedure TDBLookupList.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  CellHit: TGridCoord;
  MyOnMouseDown: TMouseEvent;
begin
  if not (csDesigning in ComponentState) and CanFocus and TabStop then
  begin
    SetFocus;
    if ValidParentForm(Self).ActiveControl <> Self then
    begin
      MouseCapture := False;
      Exit;
    end;
  end;
  if ssDouble in Shift then
  begin
    DblClick;
    Exit;
  end;
  if (Button = mbLeft) and (DataLink.DataSource <> nil) and
    (FDisplayFld <> nil) then
  begin
    CellHit := MouseCoord(X, Y);
    if (CellHit.Y >= FTitleOffset) then
    begin
      FFieldLink.Edit;
      FGridState := gsSelecting;
      SetTimer(Handle, 1, 60, nil);
      if (CellHit.Y <> (FHiliteRow + FTitleOffset)) then
      begin
        InvalidateRow(FHiliteRow + FTitleOffset);
        InvalidateRow(CellHit.Y);
      end;
      Row := CellHit.Y;
      Datalink.ActiveRecord := Row - FTitleOffset;
    end;
  end;
  MyOnMouseDown := OnMouseDown;
  if Assigned(MyOnMouseDown) then MyOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TDBLookupList.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  if (FGridState = gsSelecting) and (Row >= FTitleOffset) then
    Datalink.ActiveRecord := Row - FTitleOffset;
end;

procedure TDBLookupList.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  OldState: TGridState;
begin
  OldState := FGridState;
  inherited MouseUp(Button, Shift, X, Y);
  if OldState = gsSelecting then
  begin
    if Row >= FTitleOffset then
      Datalink.ActiveRecord := Row - FTitleOffset;
    ListClick;
  end;
end;

procedure TDBLookupList.ListClick;
begin
  if CanEdit and (FDisplayFld <> nil) then
  begin
    if FFieldLink.Editing then FFieldLink.Modified;
    FDisplayValue := FDisplayFld.AsString;
    if (FValueFld <> FDisplayFld) then
      FValue := FValueFld.AsString
    else FValue := FDisplayValue;
  end;
  if Assigned(FOnListClick) then FOnListClick(Self);
end;

function TDBLookupList.HighlightCell(DataCol, DataRow: Integer;
  const Value: string; AState: TGridDrawState): Boolean;
var
  OldActive: Integer;
begin
  Result := False;
  if not DataLink.Active or (FValueFld = nil) then Exit;
  if CanEdit and ((FGridState = gsSelecting) or FInCellSelect) then
  begin
    if Row = (DataRow + FTitleOffset) then
    begin
      Result := True;
      FHiliteRow := DataRow;
    end;
  end
  else begin
    OldActive := DataLink.ActiveRecord;
    try
      DataLink.ActiveRecord := DataRow;
      if FValue = FValueFld.AsString then
      begin
        Result := True;
        FHiliteRow := DataRow;
      end;
    finally
      DataLink.ActiveRecord := OldActive;
    end;
  end;
end;

procedure TDBLookupList.Paint;
begin
  FHiliteRow := -1;
  inherited Paint;
  if Focused and (FHiliteRow <> -1) then
    Canvas.DrawFocusRect(BoxRect(0, FHiliteRow, MaxInt, FHiliteRow));
end;

procedure TDBLookupList.Scroll(Distance: Integer);
begin
  if FHiliteRow >= 0 then
  begin
    FHiliteRow := FHiliteRow - Distance;
    if FHiliteRow >= VisibleRowCount then FHiliteRow := -1;
  end;
  inherited Scroll(Distance);
end;

procedure TDBLookupList.LinkActive(Value: Boolean);
begin
  inherited LinkActive(Value);
  if DataLink.Active then
  begin
    if not (LookupSource.DataSet.InheritsFrom(TTable)) then
      raise EInvalidOperation.Create(SLookupTableError);
    SetValue('');
    DataChange(Self);
  end;
end;

procedure TDBLookupList.FieldLinkActive(Sender: TObject);
begin
  if FFieldLink.Active and DataLink.Active then DataChange(Self);
end;

procedure TDBLookupList.CMEnter(var Message: TCMEnter);
begin
  inherited;
  if FHiliteRow <> -1 then InvalidateRow(FHiliteRow);
end;

procedure TDBLookupList.CMExit(var Message: TCMExit);
begin
  try
    FFieldLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  inherited;
  if FHiliteRow <> -1 then InvalidateRow(FHiliteRow);
end;

procedure TDBLookupList.SetOptions(Value: TDBLookupListOptions);
var
  NewGridOptions: TDBGridOptions;
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    FTitleOffset := 0;
    NewGridOptions := [dgRowSelect];
    if loColLines in Value then
      NewGridOptions := NewGridOptions + [dgColLines];
    if loRowLines in Value then
      NewGridOptions := NewGridOptions + [dgRowLines];
    if loTitles in Value then
    begin
      FTitleOffset := 1;
      NewGridOptions := NewGridOptions + [dgTitles];
    end;
    inherited Options := NewGridOptions;
  end;
end;

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

{ TPopupGrid }

constructor TPopupGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAcquireFocus := False;
  TabStop := False;
end;

procedure TPopupGrid.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.WindowClass.Style := CS_SAVEBITS;
end;

procedure TPopupGrid.CreateWnd;
begin
  inherited CreateWnd;
  if not (csDesigning in ComponentState) then
    Windows.SetParent(Handle, 0);
  CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
  FCombo.DataChange(Self);
end;

procedure TPopupGrid.WMLButtonUp(var Message: TWMLButtonUp);
begin
  inherited;
  FCombo.CloseUp;
end;

function TPopupGrid.CanEdit: Boolean;
begin
  Result := (FCombo.FFieldLink.DataSource = nil) or FCombo.FFieldLink.Editing;
end;

procedure TPopupGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FCombo.FFieldLink.Edit;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TPopupGrid.LinkActive(Value: Boolean);
begin
  if Parent = nil then Exit;
  inherited LinkActive (Value);
  if DataLink.Active then
  begin
    if FValueFld = nil then InitFields(True);
    SetValue ('');
    FCombo.DataChange(Self);
  end;
end;

procedure TPopupGrid.CMHintShow(var Message: TMessage);
begin
  Message.Result := 1;
end;

{ TComboButton }

procedure TComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  with TDBLookupCombo (Parent.Parent) do
    if not FGrid.Visible then
      if (Handle <> GetFocus) and CanFocus then
      begin
        SetFocus;
        if GetFocus <> Handle then Exit;
      end;
  inherited MouseDown (Button, Shift, X, Y);
  with TDBLookupCombo (Parent.Parent) do
    if FGrid.Visible then CloseUp
    else DropDown;
end;

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

end.