toolctrlseh.pas

delphi控件类

function TDBLookupControlEh.GetDataField: TField;
begin
  if Length(FDataFields) = 0
    then Result := nil
    else Result := FDataFields[0];
end;

{ TDBLookupListBoxEh }

constructor TDBLookupListBoxEh.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csDoubleClicks];
  Width := 121;
  FBorderStyle := bsSingle;
  RowCount := 7;
end;

procedure TDBLookupListBoxEh.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    if FBorderStyle = bsSingle then
      if NewStyleControls and Ctl3D
        then ExStyle := ExStyle or WS_EX_CLIENTEDGE
        else Style := Style or WS_BORDER;
end;

procedure TDBLookupListBoxEh.CreateWnd;
begin
  inherited CreateWnd;
  UpdateScrollBar;
end;

function TDBLookupListBoxEh.GetKeyIndex: Integer;
var
  FieldValue: Variant;
begin
  if not VarIsNull(KeyValue) then
    for Result := 0 to FRecordCount - 1 do
    begin
      ListLink.ActiveRecord := Result;
      FieldValue := FListLink.DataSet.FieldValues[FKeyFieldName];//  FKeyField.Value;
      ListLink.ActiveRecord := FRecordIndex;
      if VarEquals(FieldValue, KeyValue) then Exit;
    end;
  Result := -1;
end;

procedure TDBLookupListBoxEh.KeyDown(var Key: Word; Shift: TShiftState);
var
  Delta, KeyIndex: Integer;
begin
  inherited KeyDown(Key, Shift);
  if CanModify then
  begin
    Delta := 0;
    case Key of
      VK_UP, VK_LEFT: Delta := -1;
      VK_DOWN, VK_RIGHT: Delta := 1;
      VK_PRIOR: Delta := 1 - FRowCount;
      VK_NEXT: Delta := FRowCount - 1;
      VK_HOME: Delta := -Maxint;
      VK_END: Delta := Maxint;
    end;
    if Delta <> 0 then
    begin
      SearchText := '';
      if Delta = -Maxint
        then ListLink.DataSet.First
      else if Delta = Maxint
        then ListLink.DataSet.Last
      else
      begin
        KeyIndex := GetKeyIndex;
        if KeyIndex >= 0 then
          ListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
        else
        begin
          KeyValueChanged;
          Delta := 0;
        end;
        ListLink.DataSet.MoveBy(Delta);
      end;
      SelectCurrent;
    end;
  end;
end;

procedure TDBLookupListBoxEh.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  ProcessSearchKey(Key);
end;

procedure TDBLookupListBoxEh.KeyValueChanged;
begin
  if ListActive and not FLockPosition then
    if not LocateKey then ListLink.DataSet.First;
  if FListField <> nil
    then FSelectedItem := FListField.DisplayText
    else FSelectedItem := '';
end;

procedure TDBLookupListBoxEh.UpdateListFields;
var
  DataSet: TDataSet;
  FKeyFieldName:String;
  ResultField: TField;
  FLookupMode:Boolean;
begin
  try
    inherited UpdateListFields;

    //FKeyField := nil;
    FLookupMode := (Field <> nil) and (Field.FieldKind = fkLookup);
    if FLookupMode
      then FKeyFieldName := Field.LookupKeyFields
      else FKeyFieldName := KeyField;
    if ListLink.Active and (FKeyFieldName <> '') then
    begin
      DataSet := ListLink.DataSet;
      FKeyFields := GetFieldsProperty(DataSet, Self, FKeyFieldName);
      if FLookupMode then
      begin
        ResultField := GetFieldProperty(DataSet, Self, Field.LookupResultField);
        FListField := ResultField;
      end else
      begin
        if (ListFieldIndex >= 0) and (ListFieldIndex < ListFields.Count)
          then FListField := ListFields[ListFieldIndex]
          else FListField := ListFields[0];
      end;
    end;

  finally
    if ListActive
      then KeyValueChanged
      else ListLinkDataChanged;
  end;
end;

procedure TDBLookupListBoxEh.ListLinkDataChanged;
begin
  if ListActive then
  begin
    FRecordIndex := ListLink.ActiveRecord;
    FRecordCount := ListLink.RecordCount;
    FKeySelected := not VarIsNull(KeyValue) or
      not ListLink.DataSet.BOF;
  end else
  begin
    FRecordIndex := 0;
    FRecordCount := 0;
    FKeySelected := False;
  end;
  if HandleAllocated then
  begin
    UpdateScrollBar;
    Invalidate;
  end;
end;

procedure TDBLookupListBoxEh.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    SearchText := '';
    if not FPopup then
    begin
      SetFocus;
      if not HasFocus then Exit;
    end;
    if CanModify then
      if ssDouble in Shift then
      begin
        if FRecordIndex = (Y-FTitleHeight) div GetTextHeight then DblClick;
      end else
      begin
        MouseCapture := True;
        FTracking := True;
        if Y > FTitleHeight then
          SelectItemAt(X, Y);
      end;
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TDBLookupListBoxEh.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if FTracking then
  begin
    SelectItemAt(X, Y);
    FMousePos := Y;
    TimerScroll;
  end;
  inherited MouseMove(Shift, X, Y);
end;

procedure TDBLookupListBoxEh.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if FTracking then
  begin
    StopTracking;
    if Y > FTitleHeight then
      SelectItemAt(X, Y);
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TDBLookupListBoxEh.Paint;
var
  I, J, W, X, TextWidth, TextHeight, LastFieldIndex: Integer;
  S: string;
  R: TRect;
  Selected: Boolean;
  Field: TField;
  AAlignment: TAlignment;
begin
  Canvas.Font := Font;
  TextWidth := Canvas.TextWidth('0');
  TextHeight := Canvas.TextHeight('0');
  LastFieldIndex := ListFields.Count - 1;
  if ShowTitles then  //ShowTitles
  begin
    R.Top := 0;
    R.Bottom := R.Top + FTitleHeight;
    R.Right := 0;
    for J := 0 to LastFieldIndex do
    begin
      Field := ListFields[J];
      if J < LastFieldIndex
        then W := Field.DisplayWidth * TextWidth + 4
        else W := ClientWidth - R.Right;
      S := Field.DisplayLabel;
      AAlignment := taCenter;
      X := (W - Canvas.TextWidth(S)) div 2;
      R.Left := R.Right;
      R.Right := R.Right + W;
      Canvas.Brush.Color := clBtnFace;
      Canvas.TextRect(R, R.Left + X, R.Top, S);
      if J < LastFieldIndex then
      begin
        Canvas.Pen.Color := clGray;
        Canvas.MoveTo(R.Right, R.Top);
        Canvas.LineTo(R.Right, R.Bottom);
        Inc(R.Right);
        if R.Right >= ClientWidth then Break;
      end;
    end;
  end;
  if ColorToRGB(Color) <> ColorToRGB(clBtnFace)
    then Canvas.Pen.Color := clBtnFace
    else Canvas.Pen.Color := clBtnShadow;
  for I := 0 to FRowCount - 1 do
  begin
    if Enabled
      then Canvas.Font.Color := Font.Color
      else Canvas.Font.Color := clGrayText;
    Canvas.Brush.Color := Color;
    Selected := not FKeySelected and (I = 0);
    R.Top := I * TextHeight + FTitleHeight;
    R.Bottom := R.Top + TextHeight;
    if I < FRecordCount then
    begin
      ListLink.ActiveRecord := I;
      if not VarIsNull(KeyValue) and
        VarEquals(FListLink.DataSet.FieldValues[FKeyFieldName], KeyValue) then
      begin
        Canvas.Font.Color := clHighlightText;
        Canvas.Brush.Color := clHighlight;
        Selected := True;
      end;
      R.Right := 0;
      for J := 0 to LastFieldIndex do
      begin
        Field := ListFields[J];
        if J < LastFieldIndex then
          W := Field.DisplayWidth * TextWidth + 4 else
          W := ClientWidth - R.Right;
        S := Field.DisplayText;
        X := 2;
        AAlignment := Field.Alignment;
        if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
        case AAlignment of
          taRightJustify: X := W - Canvas.TextWidth(S) - 3;
          taCenter: X := (W - Canvas.TextWidth(S)) div 2;
        end;
        R.Left := R.Right;
        R.Right := R.Right + W;
        if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags;
        Canvas.TextRect(R, R.Left + X, R.Top, S);
        if J < LastFieldIndex then
        begin
          Canvas.MoveTo(R.Right, R.Top);
          Canvas.LineTo(R.Right, R.Bottom);
          Inc(R.Right);
          if R.Right >= ClientWidth then Break;
        end;
      end;
    end;
    R.Left := 0;
    R.Right := ClientWidth;
    if I >= FRecordCount
      then Canvas.FillRect(R);
    if Selected and (HasFocus or FPopup) then
      Canvas.DrawFocusRect(R);
  end;
  if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex;
end;

procedure TDBLookupListBoxEh.SelectCurrent;
begin
  FLockPosition := True;
  try
    if not VarEquals(FListLink.DataSet.FieldValues[FKeyFieldName],KeyValue) then
      SelectKeyValue(FListLink.DataSet.FieldValues[FKeyFieldName]);
  finally
    FLockPosition := False;
  end;
end;

procedure TDBLookupListBoxEh.SelectItemAt(X, Y: Integer);
var
  Delta: Integer;
begin
  if Y < FTitleHeight then Y := FTitleHeight;
  if Y >= ClientHeight then Y := ClientHeight - 1 ;
  Delta := (Y - FTitleHeight) div GetTextHeight - FRecordIndex;
//  if (Delta <> 0) or (KeyValue = Null) then
//  begin
  ListLink.DataSet.MoveBy(Delta);
  SelectCurrent;
//  end;
end;

procedure TDBLookupListBoxEh.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    RecreateWnd;
    RowCount := RowCount;
  end;
end;

procedure TDBLookupListBoxEh.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
  BorderSize, TextHeight, Rows: Integer;
begin
  BorderSize := GetBorderSize;
  TextHeight := GetTextHeight;
  if ShowTitles then FTitleHeight := TextHeight + 1 else FTitleHeight := 0;
  Rows := (AHeight - BorderSize - FTitleHeight) div TextHeight;
  if Rows < 1 then Rows := 1;
  FRowCount := Rows;
  if ListLink.BufferCount <> Rows then
  begin
    ListLink.BufferCount := Rows;
    ListLinkDataChanged;
  end;
  inherited SetBounds(ALeft, ATop, AWidth, Rows * TextHeight + BorderSize + FTitleHeight);
end;

function TDBLookupListBoxEh.UseRightToLeftAlignment: Boolean;
begin
  Result := DBUseRightToLeftAlignment(Self, Field);
end;

procedure TDBLookupListBoxEh.SetRowCount(Value: Integer);
begin
  if Value < 1 then Value := 1;
  if Value > 100 then Value := 100;
  Height := Value * GetTextHeight + GetBorderSize + FTitleHeight;
end;

procedure TDBLookupListBoxEh.StopTimer;
begin
  if FTimerActive then
  begin
    KillTimer(Handle, 1);
    FTimerActive := False;
  end;
end;

procedure TDBLookupListBoxEh.StopTracking;
begin
  if FTracking then
  begin
    StopTimer;
    FTracking := False;
    MouseCapture := False;
  end;
end;

procedure TDBLookupListBoxEh.TimerScroll;
var
  Delta, Distance, Interval: Integer;
begin
  Delta := 0;
  Distance := 0;
  if FMousePos < 0 then
  begin
    Delta := -1;
    Distance := -FMousePos;
  end;
  if FMousePos >= ClientHeight then
  begin
    Delta := 1;
    Distance := FMousePos - ClientHeight + 1;
  end;
  if Delta = 0
    then StopTimer
  else
  begin
    if ListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
    Interval := 200 - Distance * 15;
    if Interval < 0 then Interval := 0;
    SetTimer(Handle, 1, Interval, nil);
    FTimerActive := True;
  end;
end;

procedure TDBLookupListBoxEh.UpdateScrollBar;
var
  Pos, Max: Integer;
  Page: Cardinal;
  ScrollInfo: TScrollInfo;
begin