Aero Glass - ein Text (Label) hintergrund "machen" ?

[turboPASCAL]

Hi,

kennt sich da einer aus ?
Ich glaube Daniel 29++ :stupid: hatte da mal was mit einem Bitmap gemacht. :gruebel:

[Codewalker]

Ja in der Monumentaltrilogie zum Delphi 2007 - Text auf ein Offscreen-Bitmap gezeichnet und dann ausgegeben. Ist im Video sehr gut erklär (ich weiß leider nicht mehr welcher der Teile es war)

[turboPASCAL]

Ja ich such mir schon 'n Wolf. :stupid:

Finde aber jetzt nix genaues.

// Harrh, gefunden... leider kann man in dem Video nicht scrollen. ;)

[turboPASCAL]

War ja einfacher als ich dachte. Es hat nur den ganzen halben Tag gebraucht. ;)

Delphi-Quellcode:

function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP;
var
  bi: BITMAPINFO;
begin
  ZeroMemory(@bi, sizeof(BITMAPINFO));
  with bi.bmiHeader do
  begin
    biSize          := sizeof(BITMAPINFOHEADER);
    biWidth         := W;
    biHeight        := -H;
    biCompression   := BI_RGB;
    biBitCount      := 32;
    biPlanes        := 1;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed       := 0;
    biClrImportant  := 0;
  end;
  Result := CreateDIBSection(DC, bi, DIB_RGB_COLORS, BitmapBits, 0, 0);
end;

var
  hTheme: THandle;

procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString);
var
  tr: trect;
  txtOptions: TDTTOPTS;
  hBmp: HBITMAP;
  hBmpDC: HDC;
  hFnt: HFont;
  p: pointer;
  ts: SIZE;
begin
  hTheme := OpenThemeData(wnd, 'window');

  hBmpDC := CreateCompatibleDC(0);

  hFnt := CreateFont(-MulDiv(10, GetDeviceCaps(hBmpDC, LOGPIXELSY), 72), 0, 0, 0, FW_BOLD {FW_NORMAL}, 0, 0, 0,
     DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, 'arial');

  SelectObject(hBmpDC, hFnt);

  GetTextExtentPointW(hBmpDC, PWideChar(txt), length(txt), ts);

  SetRect(tr, 0, 0, ts.cx + 5, ts.cy + 5);

  hBmp := CreateBitmap32(hBmpDC, tr.Right, tr.Bottom, p);
  SelectObject(hBmpDC, hBmp);

  ZeroMemory(@txtOptions, sizeof(TDTTOPTS));
  txtOptions.dwSize := sizeof(TDTTOPTS);
  txtOptions.dwFlags := DTT_COMPOSITED or DTT_GLOWSIZE or DTT_TEXTCOLOR;
  txtOptions.iGlowSize := 5;
  txtOptions.crText := $00FF0000;

  DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, tr, @txtOptions);

  BitBlt(dc, x, y, tr.Right, tr.Bottom, hBmpDC, 0, 0, SRCCOPY);

  DeleteObject(hBmpDC);
  DeleteObject(hBmp);
  DeleteObject(hFnt);

  CloseThemeData(hTheme);
end;

[EWeiss]

jo schon alt..
aber hast mal ein Pic wie das bei dir aussieht?

Eventuell muss ich das auch bei meiner listbox machen wenn nach Aero umgeschaltet wird.

gruss

[turboPASCAL]

Hier zum Testen das Progrämmchen:

[EWeiss]

Zitat:

Zitat von turboPASCAL (Beitrag 1107606)

Hier zum Testen das Progrämmchen:

OH.. Die Anwendung wäre nicht nötig gewesen
dafür einen extra Dank..

Sieht gut aus ;) :thumb:

EDIT:
Scheint aber so das du hier einen fehler hast!

Delphi-Quellcode:

DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, tr, @txtOptions);

sollte so sein

Delphi-Quellcode:

DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, tr, txtOptions);

oder aber ich bekomme diese Fehlermeldung.

Zitat:

[DCC Fehler] uDrawText.pas(101): E2250 Es gibt keine überladene Version von 'DrawThemeTextEx', die man mit diesen Argumenten aufrufen kann

gruss

[turboPASCAL]

Ich habe eine steinalte "uxTheme.pas", da ist das noch so. ;)

[EWeiss]

Zitat:

Zitat von turboPASCAL (Beitrag 1107609)

Ich habe eine steinalte "uxTheme.pas", da ist das noch so. ;)

Ach so dann ist das verständlich :)

gruss

[EWeiss]

Hmm kein Fehler aber Text wird auch keiner ausgegeben.

Delphi-Quellcode:

  if SkinEngine.SK_AEROEMULATE = 0 then
    DrawText(DC, Text, length(Text), rc, DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX)
  else
  DrawAlphaText(WinHandle, DC, rc.Left, rc.Top, Text);

:gruebel:

EDIT:
Geht jetzt!
Habe aber einen unschönen Rahme um den Text.

gruss