autodbgrid.pas

Delphi自动缩放数据表格控件

//-----------------------------------------------------------------
//控件名称：自动缩放数据表格 AutoDBGrid V1.0                        
//控件作者：与月共舞工作室　周劲羽
//下载网址：http://yygw.126.com
//Eamil   ：[e-mail]; [e-mail]
//发布类型：明信片控件　未经作者允许请勿用于任何盈利性场合　　　　　　　　　　　　　　　　　
//开发平台：Windows 98 SE + Delphi 5.0
//最后修改：2001.3.20  　                                          
//-----------------------------------------------------------------
unit AutoDBGrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, DB, Consts, DsgnIntf;

type
  TDispTitle = class;
  TDispTitles = class;
  TAutoDBGrid = class;

{ TDispTitle }

  TDispTitle = class(TCollectionItem)
  private
    FWidth: Integer;
    FTitle: string;
    FFieldName: string;
    procedure SetFieldName(const Value: string);
    procedure SetTitle(const Value: string);
    procedure SetWidth(const Value: Integer);
    function GetDispTitles: TDispTitles;
    procedure Changed;
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    property DispTitles: TDispTitles read GetDispTitles;
  published
    property FieldName: string read FFieldName write SetFieldName;
    property Width: Integer read FWidth write SetWidth;
    property Title: string read FTitle write SetTitle;
  end;

{ TDispTitles }

  TDispTitles = class(TOwnedCollection)
  private
    FDBGrid: TAutoDBGrid;
    function GetItem(Index: Integer): TDispTitle;
    procedure SetItem(Index: Integer; const Value: TDispTitle);
    procedure SetDBGrid(const Value: TAutoDBGrid);
    procedure Changed;
  public
    constructor Create(AOwner: TAutoDBGrid);
    function IndexOf(const FieldName: string): Integer;
    property Items[Index: Integer]: TDispTitle read GetItem write SetItem; default;
    property DBGrid: TAutoDBGrid read FDBGrid write SetDBGrid;
  end;

{ TAddAllProperty }

  TAddAllProperty = class(TPropertyEditor)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
  end;

{ TAbout }

  TAbout = class(TPropertyEditor)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
    function GetValue: string; override;
  end;

{ TAutoDBGrid }

  TGetTitleEvent = procedure(Sender: TAutoDBGrid; Field: TField;
    var Title: string; var Width: Integer) of Object;

  TAutoDBGrid = class(TDBGrid)
  private
    FTitles: TDispTitles;
    FAutoSize: Boolean;
    FOnGetTitle: TGetTitleEvent;
    FOnGetTitleFail: TGetTitleEvent;
    FMinFixed: Boolean;
    FMinCharWidth: Integer;
    FAddAll: TAddAllProperty;
    FAbout: TAbout;
    procedure SetTitles(const Value: TDispTitles);
    procedure SetAutoSize(const Value: Boolean);
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure SetMinFixed(const Value: Boolean);
    procedure SetMinCharWidth(const Value: Integer);
    procedure AutoReset;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Reset;
  published
    property About: TAbout read FAbout write FAbout;
    property AddAll: TAddAllProperty read FAddAll write FAddAll;
    property Titles: TDispTitles read FTitles write SetTitles;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property MinCharWidth: Integer read FMinCharWidth write SetMinCharWidth default 7;
    property MinFixed: Boolean read FMinFixed write SetMinFixed default True;
    property OnGetTitle: TGetTitleEvent read FOnGetTitle write FOnGetTitle;
    property OnGetTitleFail: TGetTitleEvent read FOnGetTitleFail write
      FOnGetTitleFail;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Yygw', [TAutoDBGrid]);
  RegisterPropertyEditor(TypeInfo(TAddAllProperty), TAutoDBGrid, 'AddAll',
    TAddAllProperty);
  RegisterPropertyEditor(TypeInfo(TAbout), TAutoDBGrid, 'About', TAbout);
end;

{ TDispTitle }

procedure TDispTitle.Changed;
begin
  if Assigned(DispTitles) then
    DispTitles.Changed;
end;

constructor TDispTitle.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  Width := 0;
  Title := '';
  FieldName := '';
end;

function TDispTitle.GetDisplayName: string;
begin
  if FieldName <> '' then
    Result := FieldName
  else
    Result := inherited GetDisplayName;
end;

function TDispTitle.GetDispTitles: TDispTitles;
begin
  if Collection is TDispTitles then
    Result := TDispTitles(Collection)
  else
    Result := nil;
end;

procedure TDispTitle.SetFieldName(const Value: string);
begin
  if (Value <> '') and (AnsiCompareText(Value, FFieldName) <> 0) and
    (Collection is TDispTitles) and (TDispTitles(Collection).IndexOf(Value) >= 0) then
    raise Exception.Create(SDuplicateString);
  FFieldName := Value;
  if FTitle = '' then
    FTitle := FFieldName;
  if FWidth = 0 then
    FWidth := Length(FTitle);
  Changed;
end;

procedure TDispTitle.SetTitle(const Value: string);
begin
  if FTitle <> Value then
  begin
    FTitle := Value;
    if FWidth = 0 then
      FWidth := Length(FTitle);
    Changed;
  end;
end;

procedure TDispTitle.SetWidth(const Value: Integer);
begin
  if FWidth <> Value then
  begin
    FWidth := Value;
    Changed;
  end;
end;

{ TDispTitles }

procedure TDispTitles.Changed;
begin
  if Assigned(DBGrid) and DBGrid.AutoSize then
    DBGrid.Reset;
end;

constructor TDispTitles.Create(AOwner: TAutoDBGrid);
begin
  inherited Create(AOwner, TDispTitle);
  DBGrid := AOwner;
end;

function TDispTitles.GetItem(Index: Integer): TDispTitle;
begin
  Result := TDispTitle(inherited Items[Index]);
end;

function TDispTitles.IndexOf(const FieldName: string): Integer;
begin
  for Result := 0 to Count - 1 do
    if AnsiCompareText(Items[Result].FieldName, FieldName) = 0 then Exit;
  Result := -1;
end;

procedure TDispTitles.SetDBGrid(const Value: TAutoDBGrid);
begin
  FDBGrid := Value;
end;

procedure TDispTitles.SetItem(Index: Integer; const Value: TDispTitle);
begin
  inherited SetItem(Index, TCollectionItem(Value));
end;

{ TAddAllProperty }

procedure TAddAllProperty.Edit;
var
  i, j: Integer;
  Added: Integer;
begin
  Added := 0;
  for i := 0 to PropCount - 1 do
  begin
    if GetComponent(i) is TAutoDBGrid then
      with TAutoDBGrid(GetComponent(i)) do
      begin
        if Columns.Count > 1 then
        begin
          for j := 0 to Columns.Count - 1 do
          begin
            if Titles.IndexOf(Columns[j].FieldName) < 0 then
            begin
              with TDispTitle(Titles.Add) do
                FieldName := Columns[j].FieldName;
              Inc(Added);
            end;
          end;
        end;
      end;
  end;
  if Added > 0 then
    Application.MessageBox(PChar(IntToStr(Added) + ' Fields added!'),'Hint', MB_OK)
  else
    Application.MessageBox('None Field added!','Hint', MB_OK);
end;

function TAddAllProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paDialog, paReadOnly];
end;

function TAddAllProperty.GetValue: string;
begin
  Result := 'AddAllFields';
end;

{ TAbout }

procedure TAbout.Edit;
begin
  Application.MessageBox('TAutoDBGrid V1.0' + #10#13#10#13 + 'Author: Zhoujingyu'
    + '  Email: [e-mail]' + #10#13 + 'Date: 2001.3.20','About',
    MB_OK)
end;

function TAbout.GetValue: string;
begin
 Result := 'About';
end;

function TAbout.GetAttributes: TPropertyAttributes;
begin
 Result := [paMultiSelect, paDialog, paReadOnly];
end;

{ TAutoDBGrid }

constructor TAutoDBGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTitles := TDispTitles.Create(Self);
  FMinCharWidth := 7;
  FMinFixed := True;
  FAutoSize := True;
end;

destructor TAutoDBGrid.Destroy;
begin
  FTitles.Free;
  inherited;
end;

procedure TAutoDBGrid.Reset;
var
  i: Integer;
  TotalWidth: Integer;
  NewWidth: Integer;
  DispTitle: string;
  DispWidth: Integer;
  iTemp: Integer;
  procedure GetTitle(AField: TField; var ATitle: string; var AWidth: Integer);
  var
    Index: Integer;
  begin
    Index := Titles.IndexOf(AField.FieldName);
    if Index >= 0 then
    begin
      ATitle := Titles.Items[Index].Title;
      AWidth := Titles.Items[Index].Width;
    end
    else
    begin
      ATitle := AField.FieldName;
      AWidth := Length(ATitle);
      if Assigned(OnGetTitleFail) then
        OnGetTitleFail(Self, AField, ATitle, AWidth);
    end;
    if Assigned(OnGetTitle) then
      OnGetTitle(Self, AField, ATitle, AWidth);
  end;
begin
  if Columns.Count <= 1 then
    Exit;

  TotalWidth := 0;
  for i := 0 to Columns.Count - 1 do
  begin
    GetTitle(Columns[i].Field, DispTitle, DispWidth);
    TotalWidth := TotalWidth + DispWidth;
  end;

  NewWidth := ClientWidth - 6;
  if dgIndicator in Self.Options then
    NewWidth := NewWidth - 12;
  if (NewWidth < TotalWidth * MinCharWidth) and MinFixed then
    NewWidth := TotalWidth * MinCharWidth;

  BeginUpdate;
  iTemp := 0;
  for i := 0 to Columns.Count - 1 do
  begin
    GetTitle(Columns[i].Field, DispTitle, DispWidth);
    Columns[i].Width := Round((iTemp + DispWidth) * NewWidth / TotalWidth)
      - Round(iTemp * NewWidth / TotalWidth);
    iTemp := iTemp + DispWidth;
    Columns[i].Title.Caption := DispTitle;
    Columns[i].Title.Alignment := Columns[i].Alignment
  end;
  EndUpdate;
end;

procedure TAutoDBGrid.SetAutoSize(const Value: Boolean);
begin
  FAutoSize := Value;
  if FAutoSize then
    Reset;
end;

procedure TAutoDBGrid.SetTitles(const Value: TDispTitles);
begin
  FTitles.Assign(Value);
end;

procedure TAutoDBGrid.SetMinFixed(const Value: Boolean);
begin
  if FMinFixed <> Value then
  begin
    FMinFixed := Value;
    AutoReset;
  end;
end;

procedure TAutoDBGrid.SetMinCharWidth(const Value: Integer);
begin
  if (FMinCharWidth > 0) and (FMinCharWidth <= 20) and (FMinCharWidth <> Value) then
  begin
    FMinCharWidth := Value;
    AutoReset;
  end;
end;

procedure TAutoDBGrid.WMSize(var Msg: TWMSize);
begin
  AutoReset;
  inherited;
end;

procedure TAutoDBGrid.AutoReset;
begin
  if AutoSize then
    Reset;
end;

end.