AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren

transparenten Text auf Desktop

Ein Thema von luisk · begonnen am 1. Sep 2014 · letzter Beitrag vom 3. Sep 2014
Antwort Antwort
Benutzerbild von luisk
luisk

Registriert seit: 18. Mär 2009
402 Beiträge
 
#1

transparenten Text auf Desktop

  Alt 1. Sep 2014, 18:50
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;
  Mit Zitat antworten Zitat
Whookie

Registriert seit: 3. Mai 2006
Ort: Graz
410 Beiträge
 
Delphi 10.3 Rio
 
#2

AW: transparenten Text auf Desktop

  Alt 1. Sep 2014, 21:17
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;
Whookie

Software isn't released ... it is allowed to escape!
  Mit Zitat antworten Zitat
Der schöne Günther

Registriert seit: 6. Mär 2013
4.878 Beiträge
 
Delphi 10 Seattle Enterprise
 
#3

AW: transparenten Text auf Desktop

  Alt 2. Sep 2014, 08:49
Und unter 8.1 ebenso
  Mit Zitat antworten Zitat
Benutzerbild von luisk
luisk

Registriert seit: 18. Mär 2009
402 Beiträge
 
#4

AW: transparenten Text auf Desktop

  Alt 2. Sep 2014, 09:11
ok, erst kopieren, dann schreiben.
danke.
  Mit Zitat antworten Zitat
Benutzerbild von DeddyH
DeddyH

Registriert seit: 17. Sep 2006
Ort: Barchfeld
26.776 Beiträge
 
Delphi 10.3 Rio
 
#5

AW: transparenten Text auf Desktop

  Alt 2. Sep 2014, 09:37
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;
Detlef
"Ich habe Angst vor dem Tag, an dem die Technologie unsere menschlichen Interaktionen übertrumpft. Die Welt wird eine Generation von Idioten bekommen." (Albert Einstein)
Dieser Tag ist längst gekommen
  Mit Zitat antworten Zitat
hathor
(Gast)

n/a Beiträge
 
#6

AW: transparenten Text auf Desktop

  Alt 2. Sep 2014, 11:41
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.
Angehängte Dateien
Dateityp: zip OSD_20140902.zip (554,1 KB, 27x aufgerufen)

Geändert von hathor ( 2. Sep 2014 um 12:05 Uhr)
  Mit Zitat antworten Zitat
Benutzerbild von luisk
luisk

Registriert seit: 18. Mär 2009
402 Beiträge
 
#7

AW: transparenten Text auf Desktop

  Alt 2. Sep 2014, 16:08
Danke hathor,
das ist genau das Richtige man muss in ein eigenes Fenster zeichnen.

Geändert von luisk ( 2. Sep 2014 um 16:32 Uhr)
  Mit Zitat antworten Zitat
Benutzerbild von luisk
luisk

Registriert seit: 18. Mär 2009
402 Beiträge
 
#8

AW: transparenten Text auf Desktop

  Alt 3. Sep 2014, 10:22
nur leider werden kleine Schriften unscharf
  Mit Zitat antworten Zitat
Benutzerbild von Bummi
Bummi

Registriert seit: 15. Jun 2010
Ort: Augsburg Bayern Süddeutschland
3.470 Beiträge
 
Delphi XE3 Enterprise
 
#9

AW: transparenten Text auf Desktop

  Alt 3. Sep 2014, 11:09
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;
Thomas Wassermann H₂♂
Das Problem steckt meistens zwischen den Ohren
DRY DRY KISS
H₂ (wenn bei meinen Snipplets nichts anderes angegeben ist Lizenz: WTFPL)
  Mit Zitat antworten Zitat
hathor
(Gast)

n/a Beiträge
 
#10

AW: transparenten Text auf Desktop

  Alt 3. Sep 2014, 12:21
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');
...
  Mit Zitat antworten Zitat
Themen-Optionen Thema durchsuchen
Thema durchsuchen:

Erweiterte Suche
Ansicht

Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 04:32 Uhr.
Powered by vBulletin® Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2019 by Daniel R. Wolf