[Delphi] OSD Form

[Quitter3]

Ik wil graag een On Screen Display maken in Delphi. Dit lukt al voor 90 %.
Ik krijg er alleen geen Tekst op te zien.

Code is als volgt:

code:

//Declaraties
const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY = 1;
  LWA_ALPHA = 2;

  function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; 
dwFlags:longint ):longint; stdcall; external

// Functies
procedure Tfrm_OSD.FormCreate(Sender: TObject);
var
  L   : Longint;
begin
  Application.OnMessage    := Pr_Appmessage;
  L   := GetWindowLong(Handle, GWL_EXSTYLE);

  SetWindowLong (Handle, GWL_EXSTYLE, L Or WS_EX_LAYERED  Or WS_EX_TRANSPARENT);

  SetLayeredWindowAttributes(Handle, 0, 180, 1);
end;

Procedure Tfrm_OSD.Pr_Appmessage(var Msg: TMsg; var Handled: Boolean);
Var
  DC : HDC;
  PS : TPAINTSTRUCT;
  Rect : TRect;
Begin
  Handled := FALSE;
  Case Msg.message Of
  WM_PAINT: Begin
                       DC := BeginPaint(Handle, PS);
                       SetTextColor(DC, RGB(255,0,0));
                       GetWindowRect(Handle, Rect);
                       Rect.Left := Rect.Left + 10;
                       Rect.Top  := Rect.Top  + 10;
                       SetBkMode(DC, TRANSPARENT);
                       DrawText(DC, 'TEST', 4, Rect, DT_LEFT);
                       EndPaint(Handle, PS);
                     End;
  End;
End;

Borderstyle = bsNone
FormStyle = fsStayOnTop

Ik krijg nu een lichgrijs form te zien. Deze blijft On Top en ik kan er doorheen klikken en typen. Tot zover prima.
Maar ik zie de text van DrawText niet.

Ik heb al verschillende voorbeelden gezien. (Er zijn niet echt veel te vinden)
Ik weet echt niet waar het fout gaat. Iemand hier ervaring mee?

[alienfruit]

Waarom gebruik je niet gewoon de Desktop device context?
Overigens je maakt nu gebruik van een transparente window, dit werkt never nooit niet onder Windows 98 SE, dan moet je dus echt met window regions etc. gaan werken om het ook onder win98se transparent te krijgen.

Delphi:

// UNTESTED CODE :-)
var aCanvas: TCanvas;
    aRect: TRect;
    aDC: HDC;
begin
aCanvas := TCanvas.Create;
aDC := GetDC( HWND_Desktop );
aCanvas.Handle :=  aDC; // DesktopWindow always 0??
try
  with aCanvas do
  begin
     GetWindowRect( GetDesktopWindow(), aRect ); // rect of desktop
     Canvas.Brush.Style := bsClear;
     SetBkMode( aDC,  TRANSPARENT );
     Font.Color := clLime;
     Font.Size  := 64;
     Font.Style := [ fsBold ];
     DrawText( aCanvas.Handle, 'Bla', -1, aRect, DT_LEFT or DT_VCENTER );
  end;
finally
 aCanvas.Free;
 aCanvas := nil;
end;

[ Voor 38% gewijzigd door alienfruit op 25-08-2003 11:41 ]

[Quitter3]

alienfruit schreef op 25 August 2003 @ 11:29:
Waarom gebruik je niet gewoon de Desktop device context?

Als je nu met de muis over de tekst gaat, wordt het onderliggende Window er doorheen getekent. Dit is niet de bedoeling.

Het programma zal onder W2000 of XP draaien.

[ Voor 10% gewijzigd door Quitter3 op 25-08-2003 11:42 ]

[alienfruit]

Dan zal ik gewoon een window region gebruiken

Ik heb effe een leuke sample programmatje voor je gemaakt :-)
Werkt alleen onder Windows2000/XP volgens mij
Volume Control Demo (w/crappy source)

Probeer dit eens

code:

function TForm1.GetTextRegion( const aText: string ): hRGN;
var
  aCanvas: TCanvas;
  aRegion: hRGN;
begin
  aCanvas := TCanvas.Create;
  try
    with Self.Canvas do
    begin
      Brush.Style := bsClear;
      Font.Size   := 48;
      Font.Style  := [ fsBold ];
      Font.Name   := 'Arial';
      aTextWidth := TextWidth( aText ) * 2;
      BeginPath( Handle );
        TextOut( 225, -12, aText );
      EndPath( Handle );

      aRegion := PathToRegion( Handle );
      Result := aRegion;
    end;
  finally
    FreeAndNil( aCanvas );
  end;
end;

procedure TForm1.DrawText( const aHeight: integer );
var
  hTextRgn: hRGN;
  iCaptionHeight: integer;
  aDC: HDC;
begin
  Brush.Style := bsClear;
  Brush.Color := clLime;
  hTextRgn := GetTextRegion( 'Volume Bar' );
  SetWindowRgn( Handle, hTextRgn, True );
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetWindowLong( Handle,
                GWL_STYLE,
                GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
  Self.Height := 50;
  //SetWindowPos( Handle, HWND_TOPMOST, 20, Screen.Height - ( Self.Height +  50 ), Self.Width, Self.Height, SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_SHOWWINDOW );
  DrawText( Self.Height );
end;

[ Voor 110% gewijzigd door alienfruit op 25-08-2003 14:29 ]

[alienfruit]

Nieuwere versie geupload!

[Quitter3]

Ook deze blijft niet ontop en is bovendien ook niet transparant.
De methode die ik nu gebruik, zou moeten werken en is volgens mij ook de enige goede oplossing.
Het werkt echter nog steeds niet.

[curry684]

Zou je geen Font in je DC selecten? (just a thought...)

[Quitter3]

Jippie, heb het eindelijk voorelkaar.
Iedereen bedankt voor het meedenken.

code:

procedure Tfrm_OSD.FormCreate(Sender: TObject);
begin
  SetLayeredWindowAttributes(Handle, clBlack, 0, LWA_COLORKEY);
end;

procedure TFrm_OSD.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do begin
    ExStyle := ExStyle or WS_EX_LAYERED Or WS_EX_TRANSPARENT Or WS_EX_TOPMOST;
    WndParent := GetDesktopwindow;
  end;
end;

Form properties:

fsStayOnTop
Noborder
Color = clGray.


SetLayeredWindowAttributes(Handle, clBlack, 0, LWA_COLORKEY);
Dit statement zorgt er voor, dat alles wat Black is, transparant wordt.

Op deze manier kun je labels op je form gooien met fontcolor = clLime.
De tekst is nu te lezen. Je kunt er echter doorheen clicken en typen.

de createparams zorgt ervoor dat het Window altijd topmost blijft.

[alienfruit]

Quitter3 schreef op 25 August 2003 @ 15:22:
Ook deze blijft niet ontop en is bovendien ook niet transparant.
De methode die ik nu gebruik, zou moeten werken en is volgens mij ook de enige goede oplossing.
Het werkt echter nog steeds niet.

Nou bij mij is was ie echt wel transparant hoor

[curry684]

Quitter3 schreef op 25 August 2003 @ 16:50:
Form properties:
fsStayOnTop
Noborder

Okee, dat zijn dus allemaal shortcuts voor Window-properties, om precies te zijn respectievelijk WS_EX_TOPMOST en WS_BORDER.

Op deze manier kun je labels op je form gooien met fontcolor = clLime.
De tekst is nu te lezen. Je kunt er echter doorheen clicken en typen.

En hier komen we weer bij je originele probleem... even een stukje VCL quoten:

Delphi:

procedure TCustomLabel.DoDrawText(var Rect: TRect; Flags: Longint);
var
  Text: string;
begin
  Text := GetLabelText;
  if (Flags and DT_CALCRECT <> 0) and ((Text = '') or FShowAccelChar and
    (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  if not FShowAccelChar then Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end;

Zo werkt TLabel intern, gewoon met DrawText zoals jij het eerst deed. Je bent dus om het probleem heen aan het werken.

de createparams zorgt ervoor dat het Window altijd topmost blijft.

Ja goh, erg dubbelop met fsStayOnTop ook nog enabled Gooi dan VCL helemaal overboord en zet handmatig ook even de Flags sectie naar 0

[ Voor 6% gewijzigd door curry684 op 26-08-2003 00:33 ]

[alienfruit]

Zoiets wilde je niet??