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

Вниз

Рисунок на Bitmap и оптимизация кода   Найти похожие ветки 

← →
MVP   (2006-03-31 01:52) [0]

Моей задачей является построение секторов, которые строятся на Битмапе. После этого построения сектора выводятся сверху на рисунок карты. От секторов и их пересечения мне нужны только внешние границы. Ничего другого как попиксельное сканирование я не придумал. Способ ужасно долгий.
Вот выкладываю код:

var
btmpBex : TBitmap;
i, j : integer;
Changed : Boolean;
MyColor : TColor;

begin

btmpBex := TBitmap.Create;
MyColor := $FFFFFF-1;
btmpBex.Width := 1000;
btmpBex.Height := 700;
btmpBex.Canvas.Brush.Color := MyColor;
btmpBex.Canvas.FloodFill(0, 0, clWhite, fsSurface);

with btmpBex.Canvas do
begin
Brush.Color := clWhite;
Pen.Color := clWhite;
Pie (0, 0, 300, 300, 150, 300, 300, 150);
Pie (50, 50, 350, 350, 100, 200, 200, 100);
end;

Changed := False;

for j:=0 to btmpBex.Height-1 do
for i:=0 to btmpBex.Width-1 do
with btmpBex.Canvas do
if (Pixels [i, j] = clWhite ) and not Changed then
begin
Pixels [i, j] := clBlack;
Changed := True;
end
else if (Pixels [i, j] = MyColor) and Changed then
begin
Pixels [i - 1, j] := clBlack;
Changed := False;
end;

Changed := False;

for i:=0 to btmpBex.Height-1 do
for j:=0 to btmpBex.Width-1 do
with btmpBex.Canvas do
if ((Pixels [i, j] = clWhite ) or (Pixels [i, j] = clBlack)) and not Changed then
begin
Pixels [i, j] := clBlack;
Changed := True;
end
else if (Pixels [i, j] = MyColor) and Changed then
begin
Pixels [i, j - 1] := clBlack;
Changed := False;
end;

BitBlt (Canvas.Handle, 0, 0, btmpBex.Width, btmpBex.Height,
btmpBex.Canvas.Handle, 0, 0, SRCAND);

for j:=0 to btmpBex.Height-1 do
for i:=0 to btmpBex.Width-1 do
with btmpBex.Canvas do
if (Pixels [i, j] = clBlack) then Pixels [i , j]:= UseColor
else Pixels [i, j] := clBlack;

BitBlt (Canvas.Handle, 0, 0, btmpBex.Width, btmpBex.Height,
btmpBex.Canvas.Handle, 0, 0, SRCPAINT);

end;
Как видите у меня идет три цикла сканирования. Вот сижу кручу и два первых в один объеденить никак не удается. Помогите их объеденить в один. И возможно ещё какую-то оптимизацию кода, а то больно долго все рисуется.

---

← →
Rial ©   (2006-03-31 02:05) [1]

Во- первых, используй вот это.

Type TBitmapStream=Class
     protected
      Data:Pointer;
      BMInfo:TBitMapInfo;
      ImageSize:Integer;
      MemDC:HDC;

     public
       constructor Create(Const Bitmap:TBitmap);
       destructor Free;
       procedure Flush(Const DestBitmap:TBitmap);

       property Memory:Pointer read Data;
       property DataSize:Integer read ImageSize;
    end;

constructor TBitmapStream.Create(Const Bitmap:TBitmap);
begin
With BMinfo.bmiHeader do begin
 FillChar(BMInfo,SizeOf(BMInfo),0);
 biSize:=sizeof(TBitMapInfoHeader);
 biBitCount:=24;
 biWidth:=Bitmap.Width;
 biHeight:=Bitmap.Height;
 ImageSize:=biWidth*biHeight*3;
 biPlanes:=1;
 biCompression:=BI_RGB;
 MemDC:=CreateCompatibleDC(0);
 GetMem(Data,ImageSize);
 GetDIBits(MemDC,BitMap.Handle,0,biHeight,Data,BMInfo,DIB_RGB_COLORS);
end;
end;

destructor TBitmapStream.Free;
begin
FreeMem(Data);
end;

procedure TBitmapStream.Flush(Const DestBitmap:TBitmap);
begin
With BMinfo.bmiHeader do
 SetDIBits(MemDC,DestBitmap.Handle,0,biHeight,Data,BMInfo,DIB_RGB_COLORS);
end;

Откровенно говоря, этот класс у меня пару раз давал сбои с большими изображениями. Все руки не доходят найти ошибку.

Вот пример, как им пользоваться:


procedure FillGradient(Const Bitmap:TBitmap;Const ClientRect:TRect;Const A,B:TColor;Const GradientType:TGradientType);
Var _A,_B:Array[0..2]of Integer;
   I,J,Pix,N:Integer;
   F:Single;
   BS:TBitmapStream;
   ptRes:ptVoidArray;
   H:Integer;
   X:Integer;
begin
With ClientRect do begin
 SplitColor(A,_A[0],_A[1],_A[2]);
 SplitColor(B,_B[0],_B[1],_B[2]);
 H:=Right-Left+Top-Bottom;
 X:=Bitmap.Width;
 BS:=TBitmapStream.Create(Bitmap);
 Try
  Pix:=Integer(BS.Memory);
  For I:=Left to Right do
   For J:=Bottom to Top do begin
    ptRes:=Pointer(Pix+(I+J*X)*3);
    Case GradientType of
     igtLeftDown_RightUp:F:=(I-Left+J-Bottom)/H;
     igtLeftUp_RightDown:F:=(I-Left+Top-J)/H;
     igtRightDown_LeftUp:F:=(Right-I+J-Bottom)/H;
     igtRightUp_LeftDown:F:=(Right-I+Top-J)/H;
     else F:=0.0;
    end;//Case
    For N:=0 to 2 do ptRes^[2-N]:=Round(_A[N]-(_A[N]-_B[N])*F);
   end;
   BS.Flush(Bitmap);
  Finally
   BS.Free;
  end;
 end;
end;


---

← →
Defunct ©   (2006-03-31 04:12) [2]

MVP   (31.03.06 01:52)  

Тормозит Canvas, если точнее то свойство Canvas.Pixels[].
Хотите чтобы не тормозило - работайте с двумерным массивом. Тогда будет все быстрее в разы.

---

← →
MBo ©   (2006-03-31 06:20) [3]

>От секторов и их пересечения мне нужны только внешние границы.
Тогда воспользуйся регионами и траекториями GDI (в SDK-хелпе или MSDN - region functions и path functions)

---

← →
MVP   (2006-03-31 12:46) [4]

А цикли никто не скажет, как 2 в один запихнуть?

---

← →
TStas ©   (2006-03-31 13:31) [5]

То есть на ИМЕЮЩЕЙСя картк чего-то там дорисовать?

---

← →
MVP   (2006-03-31 13:47) [6]

for j:=0 to btmpBex.Height-1 do
for i:=0 to btmpBex.Width-1 do
with btmpBex.Canvas do
if (Pixels [i, j] = clWhite ) and not Changed then
begin
Pixels [i, j] := clBlack;
Changed := True;
end
else if (Pixels [i, j] = MyColor) and Changed then
begin
Pixels [i - 1, j] := clBlack;
Changed := False;
end;

Changed := False;

for i:=0 to btmpBex.Height-1 do
for j:=0 to btmpBex.Width-1 do
with btmpBex.Canvas do
if ((Pixels [i, j] = clWhite ) or (Pixels [i, j] = clBlack)) and not Changed then
begin
Pixels [i, j] := clBlack;
Changed := True;
end
else if (Pixels [i, j] = MyColor) and Changed then
begin
Pixels [i, j - 1] := clBlack;
Changed := False;
end;

я про этот цикл сканирования, я так подозреваю, его можно в 1 цикл сделать

---

← →
MBo ©   (2006-03-31 14:24) [7]

Еще раз - не нужно никакого сканирования.
см. пост [3]

---

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

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

Наверх

Память: 0.47 MB
Время: 0.018 c