Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Курс видеоуроков программирования и крэкерства 6.0
(актуальность: февраль 2017)
Свежие инструменты, новые видеоуроки!

  • 300+ видеоуроков
  • 800 инструментов
  • 80 свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Шапка в 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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS