Текущий архив: 2007.02.18;
Скачать: CL | DM;

Вниз

Ни как не могу убрать мерцание картинки!   Найти похожие ветки 

← →
Нулевой ©   (2006-12-24 19:56) [0]

Если не глядеть на мерцание (что не реально) вроде "все" работает! Создается Bitmap, на нем Image. Я конечно вижу много вызовов Paint, но куда бех них. Может есть способ обновить сам фон, под картинкой.
Помогите, скажите как побороть! Код (часть):

procedure TPngLVButton.Paint;
var
 BtnBmp: TBitmap;
 CaptionRect: TRect;
 PngImgLeft, PngImgTop, TextTop, TextLeft, TextWidth, TextHeight: integer;
 FaceColor, GradColor, LightColor, DarkColor, BorderColor, TextColor: TColor;
 //--- +
 PaintRect: TRect;
 //--- end
begin
 BtnBmp := TBitmap.Create;
 BtnBmp.Width := Width;
 BtnBmp.Height := Height;

 case FBtnState of
   bsNormal:
     begin
       FaceColor := FColorFace;
       GradColor := FColorGrad;
       LightColor := FColorLight;
       DarkColor := FColorDark;
       BorderColor := FColorBorder;
       TextColor := FColorText;
     end;

   bsOver:
     begin
       FaceColor := FOverColorFace;
       GradColor := FOverColorGrad;
       LightColor := FOverColorLight;
       DarkColor := FOverColorDark;
       BorderColor := FOverColorBorder;
       TextColor := FOverColorText;
     end;

   bsDown:
     begin
       FaceColor := FDownColorFace;
       GradColor := FDownColorGrad;
       LightColor := FDownColorLight;
       DarkColor := FDownColorDark;
       BorderColor := FDownColorBorder;
       TextColor := FDownColorText;
     end;
   //--- +
 else
   begin
     FaceColor := FColorFace;
     GradColor := FColorGrad;
     LightColor := FColorLight;
     DarkColor := FColorDark;
     BorderColor := FColorBorder;
     TextColor := FColorText;
   end;
   //--- end
 end;
 if not Enabled then
 begin
   FaceColor := FDisabledColorFace;
   GradColor := FDisabledColorGrad;
   LightColor := FDisabledColorLight;
   DarkColor := FDisabledColorDark;
   BorderColor := FDisabledColorBorder;
   TextColor := FDisabledColorText;
 end;

 with BtnBmp.Canvas do
 begin
   Brush.Color := FaceColor;
   Brush.Style := bsSolid;
   Rectangle(0, 0, Width, Height);
 end;

 if FGradient then
 begin
   GradientFillRect(BtnBmp.Canvas, Rect(0, 0, Width, Height), FaceColor, GradColor);
 end;

 BtnBmp.Canvas.Font := Font;
 BtnBmp.Canvas.Font.Color := TextColor;
 TextWidth := BtnBmp.Canvas.TextWidth(Caption);
 TextHeight := BtnBmp.Canvas.TextHeight(Caption);
 TextTop := (Height - TextHeight) div 2;
 TextLeft := (Width - TextWidth) div 2;

 //--- +
 if not PngImage.Empty then
 begin
   //Calculate the position of the PNG glyph
   begin
     PngImgLeft := 0;
     case FLayout of
       blGlyphLeft:
         begin
           PngImgTop := (Height - FPngImage.Height) div 2;
           PngImgLeft := TextLeft - FPngImage.Width div 2;
           inc(TextLeft, FPngImage.Width div 2);
           if not (Caption = "") then
           begin
             PngImgLeft := PngImgLeft - FSpacing div 2 - FSpacing mod 2;
             inc(TextLeft, FSpacing div 2);
           end;
         end;
       blGlyphRight:
         begin
           PngImgTop := (Height - FPngImage.Height) div 2;
           PngImgLeft := TextLeft + TextWidth - FPngImage.Width div 2;
           inc(TextLeft, -FPNGImage.Width div 2);
           if not (Caption = "") then
           begin
             PngImgLeft := PngImgLeft + FSpacing div 2 + FSpacing mod 2;
             inc(TextLeft, -FSpacing div 2);
           end;
         end;
       blGlyphTop:
         begin
           PngImgLeft := (Width - FPngImage.Width) div 2;
           PngImgTop := TextTop - FPngImage.Height div 2 - FPngImage.Height mod 2;
           inc(TextTop, FPngImage.Height div 2);
           if not (Caption = "") then
           begin
             PngImgTop := PngImgTop - FSpacing div 2 - FSpacing mod 2;
             inc(TextTop, +FSpacing div 2);
           end;
         end;
       blGlyphBottom:
         begin
           PngImgLeft := (Width - FPngImage.Width) div 2;
           PngImgTop := TextTop + TextHeight - FPngImage.Height div 2;
           inc(TextTop, -FPngImage.Height div 2);
           if not (Caption = "") then
           begin
             PngImgTop := PngImgTop + FSpacing div 2 + FSpacing mod 2;
             inc(TextTop, -FSpacing div 2);
           end;
         end;
     else
       PngImgTop := (Height - FPngImage.Height) div 2; //--- +
     end;

     if FBtnState = bsDown then
     begin
       inc(PngImgTop);
       inc(PngImgLeft);
     end;
   end;
   PaintRect := Rect(PngImgLeft, PngImgTop, PngImgLeft + FPngImage.Width, PngImgTop +
     FPngImage.Height);
 end;
 //--- end

 if FBtnState = bsDown then
 begin
   inc(TextTop);
   inc(TextLeft);
 end;
 with CaptionRect do
 begin
   Top := TextTop;
   Left := TextLeft;
   Right := Left + TextWidth;
   Bottom := Top + TextHeight;
 end;

 if Caption <> "" then
 begin
   BtnBmp.Canvas.Brush.Style := bsClear;
   DrawText(BtnBmp.Canvas.Handle,
     PChar(Caption),
     length(Caption),
     CaptionRect,
     DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOCLIP);
 end;

 with BtnBmp.Canvas do
 begin
   Pen.Style := psSolid;
   Brush.Color := FaceColor;
   Pen.Color := BorderColor;
   Brush.Style := bsClear;
   Rectangle(0, 0, Width, Height);

   if Ctl3D then
   begin
     Pen.Color := LightColor;
     MoveTo(1, Height - 2);
     LineTo(1, 1);
     LineTo(Width - 1, 1);

     Pen.Color := DarkColor;
     MoveTo(Width - 2, 1);
     LineTo(Width - 2, Height - 2);
     LineTo(1, Height - 2);
   end;
 end;

 if FFocused then
 begin
   //--- + местами
   BtnBmp.Canvas.Pen.Width := 2;
   BtnBmp.Canvas.Pen.Color := FColorBorder;
   BtnBmp.Canvas.Brush.Style := bsClear;
   BtnBmp.Canvas.Rectangle(1, 1, Width, Height);

   BtnBmp.Canvas.Pen.Width := 1;
   BtnBmp.Canvas.Pen.Color := clWhite;
   BtnBmp.Canvas.Brush.Style := bsClear;
   BtnBmp.Canvas.Rectangle(2, 2, Width - 2, Height - 2);

   BtnBmp.Canvas.Pen.Width := 1;
   BtnBmp.Canvas.Pen.Color := FColorFocusRect;
   BtnBmp.Canvas.Brush.Style := bsClear;
   BtnBmp.Canvas.Rectangle(3, 3, Width - 3, Height - 3);

   //--- end
 end;
 Canvas.Draw(0, 0, BtnBmp);
 BtnBmp.Free;
 //--- +
 if not PngImage.Empty then
 begin
   if Enabled then
     DrawPNG(FPngImage, Canvas, PaintRect, [])
   else
     DrawPNG(FPngImage, Canvas, PaintRect, FPngOptions);
 end;
 //--- end
end;


---

← →
Нулевой ©   (2006-12-24 19:57) [1]

...

constructor TPngLVButton.Create(AOwner: TComponent);
begin
 inherited;
 Width := 75;
 Height := 25;
 FCtl3D := True;
 FGradient := False;
 TabStop := True;
 FSpacing := 4;
 FCancel := False;
 FDefault := False;
 FHotTrack := False;
 ColorScheme := cs71LVNet;
 FClicked := False;
 FOverColorGrad := $00C8D0D4;
 FDownColorGrad := $00C8D0D4;
 FDisabledColorGrad := $00C8D0D4;
 //--- +
 FPngImage := TPNGObject.Create;
 FPngOptions := [pngBlendOnDisabled];
 FImageFromAction := False;
 FMargin := -1;
 //DoubleBuffered := true;
 //ControlStyle := ControlStyle + [csOpaque];
 //--- end
end;

destructor TPngLVButton.Destroy;
begin
 FPngImage.Free; //--- +
 inherited Destroy;
end;

procedure TPngLVButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
 inherited ActionChange(Sender, CheckDefaults);
 if Sender is TCustomAction then
   with TCustomAction(Sender) do
   begin
     //Copy image from action"s imagelist
     if (PngImage.Empty or FImageFromAction) and (ActionList <> nil) and
       (ActionList.Images <> nil) and (ImageIndex >= 0) and (ImageIndex <
       ActionList.Images.Count) then
     begin
       CopyImageFromImageList(FPngImage, ActionList.Images, ImageIndex);
       FImageFromAction := True;
     end;
   end;
end;

procedure TPngLVButton.Click;
begin
 if Parent <> nil then
   GetParentForm(self).ModalResult := ModalResult;
 FBtnState := bsNormal;
 //Paint;
 inherited;
end;

procedure TPngLVButton.MouseEnter(var msg: TMessage);
begin
 if csDesigning in ComponentState then
   exit;
 if not FHotTrack then
   exit;
 if FClicked then
   FBtnState := bsDown
 else
   FBtnState := bsOver;
 Paint;
end;

procedure TPngLVButton.MouseLeave(var msg: TMessage);
begin
 inherited;
 if not FHotTrack then
   exit;
 FBtnState := bsNormal;
 Paint;
end;

procedure TPngLVButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
 Integer);
begin
 inherited;
 if Button <> mbLeft then
   Exit;
 FClicked := True;
 FBtnState := bsDown;
 if TabStop then
   SetFocus;
 Paint;
end;

procedure TPngLVButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
 Integer);
begin
 inherited;
 FClicked := False;
 if (x > 0) and (y > 0) and (x < width) and (y < height) then
   if FHotTrack then
     FBtnState := bsOver
   else
     FBtnState := bsNormal;
 Paint;
end;

procedure TPngLVButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
 inherited;
end;

procedure TPngLVButton.WMSetFocus(var msg: TWMSetFocus);
begin
 FFocused := true;
 Paint;
end;

procedure TPngLVButton.WMKillFocus(var msg: TWMKillFocus);
begin
 FFocused := false;
 FBtnState := bsNormal;
 Paint;
end;

procedure TPngLVButton.WMKeyDown(var msg: TWMKeyDown);
begin
 if msg.CharCode = VK_SPACE then
   FBtnState := bsDown;
 if msg.CharCode = VK_RETURN then
   Click;
 Paint;
end;

procedure TPngLVButton.WMKeyUp(var msg: TWMKeyUp);
begin
 if (msg.CharCode = VK_SPACE) then
 begin
   FBtnState := bsNormal;
   Paint;
   Click;
 end;
end;

...

---

← →
DimaBr   (2006-12-25 09:58) [2]

Очень много кода - нечитабельно. Объясните вкраце суть вашей проблемы.

---

← →
Наиль ©   (2006-12-25 10:33) [3]

Я попытался разобраться в вопросе.
Сделал следующие выводы.
По коду:
1. Реализовывается наследник от TWinControl, скорее всего от TButton.
2. компонент выполняет функции кнопки.
3. Может имееть полупрозрачный глиф (рисунок).

По вопросу:
Причина возникновения мерцания для меня не ясна.
Возможно поможет DoubleBuffered:=true в конструктуре.
Но в любом случае PNG лучше рисовать не на компоненте, а на поверхности временого BitMap"a. А уже полностью готовое изображение (кнопки) переносить с BitMap"a  на компонент.

---

← →
DimaBr   (2006-12-25 10:45) [4]

По коду:
1. Paint,  лучше заменить на Invalidate или InvalidateRect
2. Временный BitMap можно создавать единожды а не в прорисовке.
3. Вообще можно нарисовать кнопку в трёх состояниях и просто копировать - будет работать гораздо быстрее.

---

← →
Нулевой ©   (2006-12-25 15:36) [5]

Наиль ©   (25.12.06 10:33) [3]
1.
type
 TBtnState = (bsNormal, bsOver, bsDown);
 TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
 TColorScheme = (csNeoDesert, csNeoSky, csNeoGrass, csNeoSilver, csNeoRose,
   csNeoSun,
   csDesert, csGrass, csSky, csSun, csRose, csSilver, cs71LVNet, csCustom);

 TPngLVButton = class(TCustomControl)
 private
   FColorFace: TColor;
...
2. Да
DoubleBuffered:=true использовал не помогает, см.в коде, потом закоментировал.

DimaBr   (25.12.06 10:45) [4]
1. не помогает.
3. это переписать? - лень!

Моя думает дописать типа такого... сделать дырку в BtnBmp в которую поместить картинку, тогда моргаь не будет (наверно, пока уверен). Исхожу из того, что написав FrameRect(PaintRect), где Rect это PngImage) перекрыв весь вид кнопки - мерцания нет, тока цвет последнего Brush, т.е. вид кнопки поломался.

Весь смысл кода, что создается Bitmap, поверх PngImage, потом при Paint опять Bitmap - pngImage - вот здесь при перерисовке и мерцание. А хотелось бы обновлять только фон, т.е. BtnBmp.

Уже зарапортавался - а как из BtnBmp (TBitmap) вырезать PngImage, если есть Rect этого PngImage. Может использовать регионы? Чёт уже готов плюнут на мерцание!!!! ПОМОГИТЕ-ТЕ-ТЕ!

---

← →
DimaBr   (2006-12-25 16:22) [6]

Моргает потому что перерисовывается фон. Запретите перерисовывание фона (WMEraseBkgnd -> Message.Result := 1;)

---

← →
Нулевой ©   (2006-12-25 16:38) [7]

DimaBr   (25.12.06 16:22) [6]
Наоборот нужно перерисовать только фон! А картинку оставить.

---

← →
DimaBr   (2006-12-25 16:42) [8]


procedure TWinControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
 { Only erase background if we"re not doublebuffering or painting to memory. }
 if not FDoubleBuffered or
   (TMessage(Message).wParam = TMessage(Message).lParam) then
   FillRect(Message.DC, ClientRect, FBrush.Handle);
 Message.Result := 1;
end;
По умолчанию фон перерисовывается путём такой вот прорисовки - моргание которой вы и наблюдаете. После вы уже и рисуете на чистом полотне в методе Paint

---

← →
Нулевой ©   (2006-12-25 17:08) [9]

DimaBr   (25.12.06 16:22) [6]
Добавил:
procedure TPngLVButton.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
 Message.Result := 1;
end;
Результата нет.

---

← →
Нулевой ©   (2006-12-25 17:23) [10]

Попробовал на Image - 24x24 - можно сказать не вижу верцания.
На Image 128x128 - осталось почти также.
NB. В принцепе оно и было то не сильное.

---

← →
DimaBr   (2006-12-26 08:52) [11]

> Нулевой ©   (25.12.06 17:08) [9]

А использование сообщения описали ?
Проще всего проверить поставив брейкпоинт на первую строчку метода Paint и "нажать на кнопку". В этот момент ваша "нарисованная кнопочка" должна ещё быть нарисованной. Если этого не происходит (вы рисуете на чистом полотне) - кто-то его уже очищает.

---

← →
Наиль ©   (2006-12-26 08:53) [12]

> Нулевой ©   (25.12.06 17:23) [10]

У тебя всё ещё
DrawPNG(FPngImage, Canvas, PaintRect, [])
или уже
DrawPNG(FPngImage, BtnBmp.Canvas, PaintRect, [])?

---

← →
Нулевой ©   (2006-12-26 11:15) [13]

Наиль ©   (26.12.06 08:53) [12]
Если DrawPNG(FPngImage, BtnBmp.Canvas, PaintRect, [])
картинки нет вообще, ни в среде... ни при click!

---

← →
Нулевой ©   (2006-12-26 11:39) [14]

DimaBr   (26.12.06 08:52) [11]
Не совсем понял? где поставить брейкпоинт.

---

← →
Нулевой ©   (2006-12-26 11:47) [15]

Забываю написать - мерцает толька картинка (для моих глаз так). Мерцания за картинкой не наблюдаю, или это происходит очень быстро.

---

← →
Нулевой ©   (2006-12-26 11:49) [16]

А есть смысл создание BtnBmp вынести в Create

procedure TPngLVButton.Paint;
var
 BtnBmp: TBitmap;
 CaptionRect: TRect;
 PngImgLeft, PngImgTop, TextTop, TextLeft, TextWidth, TextHeight: integer;
 FaceColor, GradColor, LightColor, DarkColor, BorderColor, TextColor: TColor;
 //--- +
 PaintRect: TRect;
 //--- end+
begin
 BtnBmp := TBitmap.Create;
 BtnBmp.Width := Width;
 BtnBmp.Height := Height;

или ничего не даст!

---

← →
Нулевой ©   (2006-12-26 12:33) [17]

1. Созданию на Canvase CustomControl картинку TBitmap, со всеми своими свойствами BtnBmp.Canvas... и др. (внешний вид)
2. Созданию на Canvase CustomControl картинку TPngImage.
3. В Paint: 1-2-1-2-1 видимо здесь и заметно моргание Image. Одно закрывает другое.
И почему Наиль ©   (26.12.06 08:53) [12] не рисует на Canvase BtnBmp?

---

← →
Нулевой ©   (2006-12-26 13:06) [18]

Сделал очень большую кнопку.
Точно 3. идет переключение канвы(канвов) с одной на другую.
PngImage зарисовывает BtnBmp.Canvas, потом BtnBmp.Canvas - PngImage.

---

← →
Нулевой ©   (2006-12-26 13:11) [19]

Как сделать в BtnBmp типа TBitmap дырку размером PaintRect?

---

← →
Наиль ©   (2006-12-26 17:12) [20]

> или ничего не даст!

даст некоторое ускорение, но не избавит от мерцания.

> И почему Наиль ©   (26.12.06 08:53) [12] не рисует на Canvase
> BtnBmp?

Покажи как ты это делаешь. И проверь PaintRect.

---

← →
Нулевой ©   (2006-12-27 16:09) [21]

Если правильно понял показать DrawPNG(FPngImage, Canvas, PaintRect, []), то:

procedure DrawPNG(Png: TPNGObject; Canvas: TCanvas; const Rect: TRect; const Options:
 TPngOptions);
var
 PngCopy: TPNGObject;
begin
 if Options <> [] then
 begin
   PngCopy := TPNGObject.Create;
   try
     PngCopy.Assign(Png);
     if pngBlendOnDisabled in Options then
       MakeImageBlended(PngCopy);
     if pngGrayscaleOnDisabled in Options then
       MakeImageGrayscale(PngCopy);
     PngCopy.Draw(Canvas, Rect);
   finally
     PngCopy.Free;
   end;
 end
 else
   Png.Draw(Canvas, Rect);
end;


---

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

Текущий архив: 2007.02.18;
Скачать: CL | DM;

Наверх

Память: 0.55 MB
Время: 0.036 c