Delphi World - Шапка в TDBGrid
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Шапка в TDBGrid

Автор: Andre

Посылает жена мужа-программера за продуктами на рынок и говорит:
- Значит так: купишь хлеба, молока, сметаны, яиц, картошки и лука. А чтобы быстрее было, встанешь в одну очередь, займешь там место и отойдешь, потом в другую и т д...
Бедный программер занял место в одной очереди, в другой. Купил яйца, бросился покупать картошку, пока покупал хлеб - забыл свое место в очереди за луком. Полез - по репе дали. Купил молока - рассыпал картошку и уронил хлеб. Поскользнулся на картошке, упал - пакет молока выронил на землю, тот взорвался. Всех молоком облило. Опять бедняга по морде получил. В процессе драки ударили по авоське с яйцами. Те разбились и вытекли прямо программеру на костюм. И вот сидит он на земле весь в синяках, яйцах, молоке и картошке, чешет репу и думает:
- Б@#! А фигово пока у меня реализована многозадачность...

Уже реализовано в виде вот этого компонента


unit bdbgrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    Grids, DBGrids, Math;

type
  TOnDrawTitleEvent = procedure(ACol: integer; ARect: TRect; var TitleText:
    string) of object;

  TBitDBGrid = class(TDBGrid)
  private
    FBitmapBrowse: TBitmap;
    FBitmapEdit: TBitmap;
    FBitmapInsert: TBitmap;
    FBitmapFill: TBitmap;
    FRealTitleFont: TFont;
    FOnDrawTitle: TOnDrawTitleEvent;
    FResizeFlag: boolean;
    { Private declarations }
    procedure SetRealTitleFont(Value: TFont);
    procedure UpdateTitlesHeight;
  protected
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
      TGridDrawState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { Public declarations }
  published
    property OnDrawTitle: TOnDrawTitleEvent read FOnDrawTitle write
      FOnDrawTitle;
    property RealTitleFont: TFont read FRealTitleFont write SetRealTitleFont;
    { Published declarations }
  end;

procedure Register;

implementation

var
  DrawBitmap: TBitmap;

function Max(X, Y: Integer): Integer;
begin
  Result := Y;
  if X > Y then
    Result := X;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text:
  string; Alignment: TAlignment);
// © Borland function :)
const
  AlignFlags: array[TAlignment] of Integer =
  (DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
    DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
    DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
var
  B, R: TRect;
  I, Left: Integer;
begin
  with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
  begin { brush origin tics in painting / scrolling. }
    Width := Max(Width, Right - Left);
    Height := Max(Height, Bottom - Top);
    R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
    B := Rect(0, 0, Right - Left, Bottom - Top);
  end;
  with DrawBitmap.Canvas do
  begin
    DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);
    Font := ACanvas.Font;
    Font.Color := ACanvas.Font.Color;
    Brush := ACanvas.Brush;
    SetBkMode(Handle, TRANSPARENT);
    DrawText(Handle, PChar(Text), Length(Text), R,
      AlignFlags[Alignment]);
  end;
  ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
end;

constructor TBitDBGrid.Create(AOwner: TComponent);
begin
  inherited Create(Aowner);
  FRealTitleFont := TFont.Create;
  FResizeFlag := false;
end;

destructor TBitDBGrid.Destroy;
begin
  FRealTitleFont.Free;
  inherited Destroy;
end;

procedure TBitDBGrid.UpdateTitlesHeight;
var
  Loop: integer;
  MaxTextHeight: integer;
  RRect: TRect;
begin
  MaxTextHeight := 0;
  for loop := 0 to Columns.Count - 1 do
  begin
    RRect := CellRect(0, 0);
    RRect.Right := Columns[Loop].Width;
    RRect.Left := 0;
    Canvas.Font := RealTitleFont;
    MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle,
      PChar(Columns[Loop].Title.Caption),
      Length(Columns[Loop].Title.Caption), RRect,
      DT_CALCRECT + DT_WORDBREAK)
      );
  end;
  if TitleFont.Height <> -MaxTextHeight then
    TitleFont.Height := -MaxTextHeight;
end;

procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
begin
  if MouseCoord(X, Y).Y = 0 then
    FResizeFlag := true;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FResizeFlag then
  begin
    FResizeFlag := false;
    UpdateTitlesHeight;
  end;
end;

procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
  TGridDrawState);
var
  Indicator: TBitmap;
  TitleText: string;
  Al: TAlignment;
begin
  if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options) and (ACol
    <> 0))) then
    inherited DrawCell(ACol, ARow, ARect, AState)
  else
  begin
    if DefaultDrawing then
    begin
      DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);
      DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);
      InflateRect(ARect, -1, -1);
      Canvas.Brush.Color := FixedColor;
      Canvas.FillRect(ARect);
    end;
    TitleText := Columns[ACol - 1].Title.Caption;
    if Assigned(OnDrawTitle) then
      OnDrawTitle(ACol, ARect, TitleText);
    if DefaultDrawing and (TitleText <> '') then
    begin
      Canvas.Brush.Style := bsClear;
      Canvas.Font := RealTitleFont;
      if ACol > 0 then
        Al := Columns[ACol - 1].Title.Alignment
      else
        Al := Columns[0].Title.DefaultAlignment;
      WriteText(Canvas, ARect, 2, 2, TitleText, Al);
    end;
  end;
end;

procedure TBitDBGrid.SetRealTitleFont(Value: TFont);
begin
  FRealTitleFont.Assign(Value);
  Repaint;
end;

procedure Register;
begin
  RegisterComponents('Andre VCL', [TBitDBGrid]);
end;

initialization
  DrawBitmap := TBitmap.Create;

finalization
  DrawBitmap.Free;

end.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования