Jak poprawic transparent labeli na specjalnie zmodyfikowanej formie

0

WItam,
zrobiłem sobie formę o nietypowych krawędziach,
było trochę z tym zabawy - to nie takie proste (pisałem już wcześniej o tym w niedawnym temacie).
Wszystko fajnie działa, tylko, że na tak spreparowanej formie, labele tracą transparentność i pobierają kolor parenta tj. formatki.

Screen 1 pokazuje wyglad prze kompilacja:
http://i.imgur.com/s4jhmAh.png

Screen 2 po kompilacji:
http://i.imgur.com/qg66IQn.png

Głowny kod odpowiedzialny za forme ponizej:

...
const WM_SHOWFRAME = WM_USER+1;
...

implementation

var Wnd: TWndClass;
    Hnd: THandle;
    ComponentForm: TForm;

....
//Funkcja obsługująca zdarzenia półprzezroczystego okna
function WndNewProc(Wnd: HWND; uMsg: UINT; wPar: WPARAM; lPar: LPARAM): LRESULT; stdcall;
var Rect: TRect;
begin
Result := 0;
case uMsg of
  WM_DESTROY: PostQuitMessage(0);
  WM_LBUTTONDOWN: SendMessage(Wnd, WM_SYSCOMMAND, SC_MOVE+2, 0);
  else
    begin
    if ((uMsg = WM_MOVING) or (uMsg = WM_MOVE)) and GetWindowRect(Wnd, Rect) then
      SetWindowPos(ComponentForm.Handle, 0, Rect.Left, Rect.Top, 0, 0, SWP_NOSIZE);
    Result := DefWindowProc(Wnd, uMsg, wPar, lPar);
    end;
  end;
end;

//Funkcja odmalowująca półprzezroczyste okno z uwzględnieniem regionu
procedure PaintLayeredWindow(Hnd: THandle; Region: HRGN);
var blend: BLENDFUNCTION;
    P: TPoint;
    S: TSize;
    X, Y: integer;
    bmpRGBA: TBitmap;
    Alpha: byte;
    Linia32: PRGBQuad;
    Linia32RGBA: PRGBQuad;
begin



//Tworzenie warstwy RGB
bmpRGBA := Form1.Image1.Picture.Bitmap;
try
//Sklejenie RGB oraz wygenerowanego A
  with TBitmap.Create() do
    begin
    try
      Width := bmpRGBA.Width;
      Height := bmpRGBA.Height;
      PixelFormat := pf32bit;
      for Y := 0 to Height-1 do
        begin
        Linia32RGBA := bmpRGBA.ScanLine[Y];
        Linia32 := ScanLine[Y];
        for X := 0 to Width-1 do
          begin
          if PtInRegion(Region, X, Y) then
            Alpha := 0
          else
            Alpha := Linia32RGBA.rgbReserved;
          Linia32.rgbRed := MulDiv(Linia32RGBA.rgbRed, Alpha, 255);
          Linia32.rgbGreen := MulDiv(Linia32RGBA.rgbGreen, Alpha, 255);
          Linia32.rgbBlue := MulDiv(Linia32RGBA.rgbBlue, Alpha, 255);
          Linia32.rgbReserved := Alpha;
          inc(Linia32);
          inc(Linia32RGBA);
          end;
        end;

//Nakładanie bitmapy
      P := Point(0, 0);
      S.cx := bmpRGBA.Width;
      S.cy := bmpRGBA.Height;
      blend.BlendOp := AC_SRC_OVER;
      blend.BlendFlags := 0;
      blend.AlphaFormat := AC_SRC_ALPHA;
      blend.SourceConstantAlpha := 255;
      UpdateLayeredWindow(Hnd, GetDC(0), nil, @S, Canvas.Handle, @P, 0, @blend, ULW_ALPHA);
    finally
      Free;
      end;
    end;
finally
  end;
end;

//Tworzenie regionów, wycinanie okna komponentów i tworzenie okna półprzezroczystego
procedure CreateLayered(Form: TForm);
var Region: HRGN;
    ComponentRegion: HRGN;
    i:Integer;
const LayeredWndClass = 'LayeredWndClass';
begin
ComponentForm := Form;
ComponentForm.BorderStyle := bsNone;
Region := CreateRectRgn(0, 0, 0, 0);
for i := 0 to ComponentForm.ControlCount-1 do
  if ComponentForm.Controls[i].Visible then
    begin
    ComponentRegion := CreateRectRgn(ComponentForm.Controls[i].Left, ComponentForm.Controls[i].Top, ComponentForm.Controls[i].Width+ComponentForm.Controls[i].Left, ComponentForm.Controls[i].Height+ComponentForm.Controls[i].Top);
    CombineRgn(Region, Region, ComponentRegion, RGN_OR);
    DeleteObject(ComponentRegion);
    end;
with Wnd do
  begin
  lpfnWndProc := @WndNewProc;
  hInstance := hInstance;
  lpszClassName := LayeredWndClass;
  hbrBackground := COLOR_WINDOW;
  end;
Windows.RegisterClass(Wnd);
Hnd := CreateWindowEx(WS_EX_LAYERED, LayeredWndClass, PChar(ComponentForm.Caption), WS_VISIBLE, ComponentForm.Left, ComponentForm.Top, ComponentForm.Width, ComponentForm.Height, ComponentForm.Handle, 0, hInstance, NIL);
PaintLayeredWindow(Hnd, Region);
SetWindowRgn(ComponentForm.Handle, Region, TRUE);
DeleteObject(Region);
end;

....

procedure TForm1.FormShow(Sender: TObject);
begin
  PostMessage(Handle, WM_SHOWFRAME, 0, 0);
end;

procedure TForm1.ShowFrame(var Msg: TMessage);
begin
  CreateLayered(self);
end;

Pytanie brzmi jak zachowac transparent labeli?

prosze o pomoc
pozdro

1

Hmmm, a korzystasz z VCLowych TLabel? Bo ja słabo ogarniam temat własnego rysowania, ale jak już użył bym TStaticText albo najlepiej utworzonych własnych Labeli przez CreateWindow(Ex)/W i obsłużył ich rysowanie poprzez WM_CTLCOLORSTATIC lub WM_PAINT. W tym kierunku coś bym kombinował. Pewnie jeszcze @kAzek Ci tutaj konkretniej doradzi.

1

Tak jak napisał @olesio trzeba obsłużyć WM_CTLCOLORSTATIC. Jak nie chcesz się bawić w ręczne tworzenie kontrolek zamiast TLabel użyj TStaticText a sam kod jest prosty:

type
  TStaticText = class(StdCtrls.TStaticText)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

  TForm1 = class(TForm)
 //...
  private
    procedure WMCtlColorStatic(var Msg: TMessage); message WM_CTLCOLORSTATIC;  
  //...
implementation

{$R *.dfm}

procedure TStaticText.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle:= Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TForm1.WMCtlColorStatic(var Msg: TMessage);
begin
  SetBkMode(Msg.wParam, Windows.TRANSPARENT);
  SetTextColor(Msg.wParam, RGB(255, 0, 0)); //trzeba kolor tekstu bo przy obsludze WM_CTLCOLORSTATIC "gubi się" ustawiony w Object Inspector
  Msg.Result:= GetStockObject(NULL_BRUSH);
end;

1 użytkowników online, w tym zalogowanych: 0, gości: 1