Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Начинающим";
Текущий архив: 2008.01.06;
Скачать: [xml.tar.bz2];

Вниз

создание класса на основе TBitmap   Найти похожие ветки 

 
San1   (2007-12-11 03:26) [0]

Подскажите пожалуйста.
Мне необходимо реализовать отрисовку сетки на объекте дочернего класса (TMyBitmap) порожденного от класса TBitmap.

Например:
-создаем объект класса TMyBitmap;
- задаем в его свойствах шаг и тощину отрисовываемой сетки;
- и при вызове процедуры отрисовки объекта он отрисовывается на форме.

Каким образом в моем создаваемом классе реализовать отрисовку объекта, который еще не создан?


 
{RASkov} ©   (2007-12-11 04:20) [1]

> [0] San1   (11.12.07 03:26)

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;

type
 TMyBmp = class(TBitMap)
 private
   FCellSize: Byte;
   FLnWidth: Byte;
   FLnColor: TColor;
   procedure SetCellSize(const Value: Byte);
   procedure SetLnWidth(const Value: Byte);
   procedure SetLnColor(const Value: TColor);
 protected
   procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
 public
   procedure PaintTo(ACanvas: TCanvas); overload;
   procedure PaintTo(const X, Y: Integer; ACanvas: TCanvas); overload;
   property CellSize: Byte read FCellSize write SetCellSize;
   property LnWidth: Byte read FLnWidth write SetLnWidth;
   property LnColor: TColor read FLnColor write SetLnColor;
 end;

 TForm1 = class(TForm)
   Button1: TButton;
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

{ TMyBmp }

procedure TMyBmp.SetCellSize(const Value: Byte);
begin
 if FCellSize <> Value then begin
  if Value<3 then FCellSize := 3 else FCellSize := Value;
 end;
end;

procedure TMyBmp.SetLnWidth(const Value: Byte);
begin
 if FLnWidth <> Value then begin
  if Value<1 then FLnWidth := 1 else FLnWidth := Value;
 end;
end;

procedure TMyBmp.SetLnColor(const Value: TColor);
begin
 FLnColor := Value;
end;

procedure TMyBmp.Draw(ACanvas: TCanvas; const Rect: TRect);
var R, C, W, H: Integer;
begin
 W:=(Rect.Right-Rect.Left) div CellSize;
 H:=(Rect.Bottom-Rect.Top) div CellSize;
 with Canvas do begin
  Pen.Width:=LnWidth;
  Pen.Color:=LnColor;
  Pen.Style:=psInsideFrame;
  Brush.Style:=bsClear;
  for C:=0 to W do
   for R:=0 to H do
    Rectangle(C*CellSize, R*CellSize, C*CellSize+CellSize, R*CellSize+CellSize);
 end;
 inherited;
end;

procedure TMyBmp.PaintTo(ACanvas: TCanvas);
begin
 ACanvas.Draw(0, 0, Self);
end;

procedure TMyBmp.PaintTo(const X, Y: Integer; ACanvas: TCanvas);
begin
 ACanvas.Draw(X, Y, Self);
end;

procedure TForm1.Button1Click(Sender: TObject);
var B: TMyBmp;
begin
 B:=TMyBmp.Create;
 B.LoadFromFile(<имя бмпшки>);
 B.CellSize:=50;
 B.LnWidth:=3;
 B.LnColor:=clSilver;
 Canvas.Draw(10, 30, B);
 B.PaintTo(10, B.Height+40, Canvas);
 B.Free;
end;

end.


 
Юрий Зотов ©   (2007-12-11 13:14) [2]

А если во всех трех сеттерах в конце еще и перерисовку вызвать - полный кайф наступит. Поменяли, например, толщину линии - и все тут же само собой перерисовалось, как надо.

И в процедуре Draw я бы inherited вызвал в самом начале - чтобы сетка рисовалась поверх картинки, а не затиралась ею.

А сетку рисовал бы через MoveTo и LineTo, сразу по всей области, а не ячейками, через Rectangle - чтобы не было повторной прорисовки линий.

:o)


 
{RASkov} ©   (2007-12-11 14:11) [3]

> [2] Юрий Зотов ©   (11.12.07 13:14)

:)
Некое домашние задание автору)



Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2008.01.06;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.46 MB
Время: 0.004 c
4-1181989365
cosinus
2007-06-16 14:22
2008.01.06
Как с помощью WinAPI расшарить папку на удаленном компе?


2-1197286618
Quart
2007-12-10 14:36
2008.01.06
Выгрузка


2-1197048755
Leonid
2007-12-07 20:32
2008.01.06
ComboBox и Object


2-1196941670
Nil
2007-12-06 14:47
2008.01.06
распределение памяти в динмаическом массиве записей


15-1196689767
alsov
2007-12-03 16:49
2008.01.06
событие виндовс на email





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский