transparenten Text auf Desktop

[luisk]

hab das hier getestet.
http://www.entwickler-ecke.de/topic_..._107786,0.html
http://delphi.about.com/cs/adptips20...ltip0104_5.htm

Text wird gezeichnet allerdings nicht transparent: (Win 8.1)

Delphi-Quellcode:

 procedure DrawTextOnDesktop(TextToDraw: string) ;
 var
    Handle: HWND;
    Dc: HDC;
    ACanvas: TCanvas;
 begin
    Handle := GetDesktopWindow;
    Dc := GetWindowDC(Handle) ;
    ACanvas := TCanvas.Create;
    try
      ACanvas.Handle := DC;
      BeginPath(ACanvas.Handle) ;
      ACanvas.Font.Color := clRed;
      ACanvas.Font.Name := 'Tahoma';
      ACanvas.Font.Size := 30;
      SetBkMode(ACanvas.Handle, TRANSPARENT) ;
      EndPath(ACanvas.Handle) ;
      ACanvas.TextOut(100, 500, TextToDraw) ;
    finally
      ReleaseDC(Handle, ACanvas.Handle) ;
      ACanvas.Free;
    end;
 end;

[Whookie]

Eine Variante die auf jeden Fall geht (..unter Windows 7):

Delphi-Quellcode:

procedure DrawTextOnDesktop(TextToDraw: string) ;
 var
    Handle: HWND;
    Dc: HDC;
    ACanvas: TCanvas;
    bmp: TBitmap;
    iSz: TSize;
 begin
    Handle := GetDesktopWindow;
    Dc := GetWindowDC(Handle) ;
    ACanvas := TCanvas.Create;
    bmp := TBitmap.Create;
    try
      ACanvas.Handle := DC;

      bmp.Canvas.Font.Color := clRed;
      bmp.Canvas.Font.Name := 'Tahoma';
      bmp.Canvas.Font.Size := 30;
      bmp.Canvas.Brush.Style := bsClear;
      iSz := bmp.Canvas.TextExtent(TextToDraw);
      bmp.SetSize(iSz.cx, iSz.cy);
      bmp.Canvas.CopyRect(Rect(0,0, iSz.cx, iSz.cy),  ACanvas, Rect(10,10,10+iSz.cx, 10+iSz.cy) );
      bmp.Canvas.TextOut(0, 0, TextToDraw) ;
      ACanvas.Draw(10,10, bmp);

    finally
      bmp.Free;
      ReleaseDC(Handle, ACanvas.Handle) ;
      ACanvas.Free;
    end;
 end;

[Der schöne Günther]

Und unter 8.1 ebenso

[luisk]

ok, erst kopieren, dann schreiben.
danke.

[DeddyH]

Kleiner Verbesserungsvorschlag:

Delphi-Quellcode:

procedure DrawTextOnDesktop(TextToDraw: string) ;
var
  Handle: HWnd;
  Dc: HDC;
  ACanvas: TCanvas;
  bmp: TBitmap;
  iSz: TSize;
begin
  bmp := nil;
  Handle := GetDesktopWindow;
  Dc := GetWindowDC(Handle);
  if Dc <> 0 then
    try      
      ACanvas := TCanvas.Create;
      ACanvas.Handle := DC;
      bmp := TBitmap.Create;
      bmp.Canvas.Font.Color := clRed;
      bmp.Canvas.Font.Name := 'Tahoma';
      bmp.Canvas.Font.Size := 30;
      bmp.Canvas.Brush.Style := bsClear;
      iSz := bmp.Canvas.TextExtent(TextToDraw);
      bmp.SetSize(iSz.cx, iSz.cy);
      bmp.Canvas.CopyRect(Rect(0,0, iSz.cx, iSz.cy), ACanvas, Rect(10,10,10+iSz.cx, 10+iSz.cy) );
      bmp.Canvas.TextOut(0, 0, TextToDraw) ;
      ACanvas.Draw(10,10, bmp);    
    finally
      bmp.Free;
      ReleaseDC(Handle, Dc) ;
      ACanvas.Free;
    end;
end;

[hathor]

Vorschlag: Programm mit ParamStr und RunOnce:
Anmerkung: Batchfile-Beispiel:
osd.exe Das.wird.ein.Spass
(ParamStr ohne Leerzeichen oder mehrere ParamStrings zusammenführen)

Delphi-Quellcode:

program Osd;

uses
  Vcl.Forms,
  Winapi.Windows,
  Winapi.Messages,
  uOSD in 'uOSD.pas' {Form1};

{$R *.RES}

const
  UM_ACTIVATE = WM_USER + 1;
var
  HndMyWindow : cardinal;
begin
  HndMyWindow := FindWindow( Nil, PWIDECHAR('OSD-2014'));
  If HndMyWindow <> 0 Then
  Begin
    PostMessage( HndMyWindow,UM_ACTIVATE, 0, 0);
    ShowWindow(HndMyWindow, SW_Normal);
    UpdateWindow(HndMyWindow);
    SetForeGroundWindow(HndMyWindow);
    Exit;
  End;

  Application.Initialize;
  Application.Title := 'OSD-2014';
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
//--------------------------------------------
unit uOSD;   //20140902

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure DrawTextOnDesktop(TextToDraw: string) ;
    procedure FormShow(Sender: TObject);

  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  HRgn: THandle;

implementation

{$R *.DFM}

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DeleteObject(HRgn);
end;

procedure TForm1.DrawTextOnDesktop(TextToDraw: string) ;
begin
    Color := clLime;
    DeleteObject(HRgn);

    Canvas.Font.Name  := 'Arial black';  // Comic Sans MS
    Canvas.Font.Size  := 50;//32;
    Canvas.Font.Style := [fsBold];

    self.width:=Canvas.TextWidth(TextToDraw)+60;
    self.height:=Canvas.TextHeight('▐');

    BeginPath(Canvas.Handle);
    SetBkMode( Canvas.Handle, TRANSPARENT );
    Canvas.TextOut(5, 0, ' '+ TextToDraw +' ');  //' Das ist ein Test ');

    Canvas.Rectangle(0,0,width,height);
    Canvas.Rectangle(5,5,width-5,height-5);

    EndPath(Canvas.Handle);
    HRgn := PathToRegion(Canvas.Handle);
    SetWindowRgn(Handle, HRgn, True);
    SetWindowPos(Handle,HWND_TOPMOST, 0, 0, 0, 0,SWP_NOMOVE + SWP_NOSIZE);
end;

procedure TForm1.FormCreate(Sender: TObject);
var MyText : String;
    j : Integer;
begin
  ShowMessage('Use RightClick to close the OSD.');
//  if ParamStr(1)<>'' then MyText:= ParamStr(1) else MyText:= 'HATHOR-2014';

  for j := 1 to ParamCount do
  MyText:= MyText + ' ' + ParamStr(j);

  If MyText='' then MyText:= 'HATHOR-2014';

  Application.ShowMainForm := TRUE;
  DrawTextOnDesktop(MyText);
end;


procedure TForm1.FormShow(Sender: TObject);
begin
//Caption:= 'OSD-1';
end;

end.

[luisk]

Danke hathor,
das ist genau das Richtige man muss in ein eigenes Fenster zeichnen.

[luisk]

nur leider werden kleine Schriften unscharf

[Bummi]

Du kannst es ja mal so versuchen, wenn Du noch glattere Schriften brauchst kannst Du statt per Canvasroutinen per hier im Formum unbeliebten GDI+ Routinen den Text auf das Bitmap aufbringen.

Delphi-Quellcode:

type
  TForm5 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form5: TForm5;

implementation

{$R *.dfm}
var
  Bitmap: TBitmap;


procedure TForm5.FormCreate(Sender: TObject);
var
  BlendFunction: TBlendFunction;
  BitmapPos: TPoint;
  BitmapSize: TSize;
  exStyle: DWORD;
begin
  BorderStyle := bsNone;
  Left := 0;
  Top := 0;
  Width := Screen.Width;
  Height := Screen.Height;
  // Enable window layering
  exStyle := GetWindowLongA(Handle, GWL_EXSTYLE);
  if (exStyle and WS_EX_LAYERED = 0) then
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);

  Bitmap := TBitmap.Create;
  Bitmap.Canvas.Brush.Color := clBlack;
  Bitmap.Width := Width;
  Bitmap.Height := height;
  Bitmap.Canvas.Font.Color := clWhite;
  Bitmap.Canvas.Font.Size := 10;
  Bitmap.Canvas.TextOut(10,10,'Hallo die ist ein Test');


  BitmapPos := Point(0, 0);
  BitmapSize.cx := Bitmap.Width;
  BitmapSize.cy := Bitmap.Height;

  BlendFunction.BlendOp := AC_SRC_OVER;
  BlendFunction.BlendFlags := 0;
  BlendFunction.SourceConstantAlpha := 255;
  BlendFunction.AlphaFormat := AC_SRC_ALPHA;

  // ... and action!
  UpdateLayeredWindow(Handle, 0, nil, @BitmapSize, Bitmap.Canvas.Handle,
    @BitmapPos, 0, @BlendFunction, ULW_ALPHA);

end;
procedure TForm5.FormDestroy(Sender: TObject);
begin
  Bitmap.Free;
end;

[hathor]

Zitat von luisk:

nur leider werden kleine Schriften unscharf

Änderungen:

Delphi-Quellcode:

...
    Canvas.Font.Name  := 'Tahoma';  // Comic Sans MS
    Canvas.Font.Size  := 20; //kleiner macht wenig Sinn...
// Canvas.Font.Style := [fsBold]; //ersatzlos entfernen
    self.width:=Canvas.TextWidth(TextToDraw)+60;
    self.height:= 2*Canvas.Font.Size;    //Canvas.TextHeight('X');
...