Text-Rotation - Textausgabe mit beliebiger Gradzahl

**Dr.MAD**

Hallo,

ich war auf der Suche nach einer Möglichkeit einen Text vertikal auf die Tabs eines PageControl zu "zeichnen".

Nach der Durchforstung des Forums habe ich mir nun eine ordentliche procedure geschrieben, die es erlaubt in beliebiger Schrift, Farbe usw. einen Text in einer bestimmten Gradzahl mit Bezug auf einen Mittelpunkt auszugeben.

zusammenfalten · markieren

Delphi-Quellcode:

			(* ---------------------------- Text - Rotation ----------------------------- *)

procedure TForm1.TextRotation(rText, fName: String;

                              fSize: Integer; fColor: TColor; fStyles: TFontStyles;

                              fBrushStyle: TBrushStyle; fBrushColor:TColor;

                              Grad: Real; aCanvas: TCanvas; Mittelpunkt: TPoint);

var hFont, FontOld, fnWeight: Integer;

    fdwItalic, fdwUnderline, fdwStrikeOut: DWord;

    Radius: Real;

    KorrX, KorrY: Integer;

    TextMetric: TTextMetric;

begin

  (* Funktioniert nur mit TrueType oder Vektor - Schriftarten *)

  if (Length(rText)=0) or (Screen.Fonts.IndexOf(fName)=-1) or (fSize<1) or (aCanvas=nil) then Exit;

  (* Font - Styles extrahieren *)

  if fsBold IN fStyles then fnWeight:=FW_BOLD else fnWeight:=FW_NORMAL;

  if fsItalic IN fStyles then fdwItalic:=1 else fdwItalic:=0;

  if fsUnderline IN fStyles then fdwUnderline:=1 else fdwUnderline:=0;

  if fsStrikeOut IN fStyles then fdwStrikeOut:=1 else fdwStrikeOut:=0;

  (* Schrift-Farbe *)

  aCanvas.Font.Color:=fColor;

  (* Schrift-Hintergrund *)

  aCanvas.Brush.Color:=fBrushColor;

  aCanvas.Brush.Style:=fBrushStyle;

  (* Neue Font erstellen *)

  hFont:=CreateFont(-fSize,0,Round(Grad*10),0,

                    fnWeight, fdwItalic, fdwUnderline, fdwStrikeOut,

                    1,4,$10,2,4,PChar(fName));

  (* Alte Font sichern und Neue anwenden *)

  FontOld:=SelectObject(aCanvas.Handle, hFont);

  (* Referenzpunkt auf die horizontale Mitte des Textes legen *)

  SetTextAlign(aCanvas.Handle,TA_CENTER);

  (* TextMetric abfragen *)

  GetTextMetrics(aCanvas.Handle,TextMetric);

  (* Auf True Type prüfen *)

  if TextMetric.tmPitchAndFamily and (TMPF_TRUETYPE or TMPF_VECTOR)= 0 then rText:='Nur True-Type oder Vektor - Schriftarten!';

  (* Radius ( = Halbe Texthöhe) ermitteln *)

  Radius:=TextMetric.tmHeight div 2;

  (* X- und Y-Verschiebung über cos-phi und sin-phi ermitteln *)

  KorrX:=Round(sin(DegToRad(Grad))*Radius);

  KorrY:=Round(cos(DegToRad(Grad))*Radius);

  (* Text zeichnen *)

  TextOut(aCanvas.Handle, Mittelpunkt.X-KorrX ,Mittelpunkt.Y-KorrY ,PChar(rText) ,Length(rText));

  (* Alte Font wiederherstellen *)

  SelectObject(aCanvas.Handle,FontOld);

  (* Neue Font löschen *)

  DeleteObject(hFont);

end;

rText = Ausgabetext
fName = Schriftname
fSize = Schriftgröße
fColor = Schriftfarbe
fStyles = Style [fsBold,fsItalic,fsUnderline]
fBrushStyle = Hintergrund-Style der Schrift
fBrushColor = Hintergrundfarbe der Schrift
Grad = Gradzahl (0,0..180,5..360,0)
aCanvas = Zeichenfläche
Mittelpunkt = Drehachse

Zum Schnelltest legt ein neue VCL-Formularanwendung Win32 an und überschreibt alles in der Unit1.pas mit folgendem Code:

zusammenfalten · markieren

Delphi-Quellcode:

			unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls, ExtCtrls, Math;

type

  TForm1 = class(TForm)

    procedure FormResize(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure FormDestroy(Sender: TObject);

    procedure FormPaint(Sender: TObject);

  private

    procedure TextRotation(rText, fName: String;

                           fSize: Integer; fColor: TColor; fStyles: TFontStyles;

                           fBrushStyle: TBrushStyle; fBrushColor:TColor;

                           Grad: Real; aCanvas: TCanvas; Mittelpunkt: TPoint);

    procedure MakeObjects;

    procedure FreeObjects;

    procedure MakeBmp;

    procedure PaintBmp;

    procedure SBScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);

    procedure Change(Sender: TObject);

    procedure ChangeColor(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

    procedure FullScreen(Sender: TObject);

    procedure NormalScreen(Sender: TObject);

    procedure OnTime(Sender: TObject);

    { Private-Deklarationen }

  public

    { Public-Deklarationen }

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

(* ------------------------------- Variablen -------------------------------- *)

var Bmp: TBitmap;

    SBGrad, SBFontSize, SBAuto, SBAutoStep: TScrollBar;

    EGrad, EText, EFontSize, EAuto, EAutoStep: TEdit;

    LAusgabe, LGrad, LFonts, LFontSize, LFontStyle, LFontColor, LFontBackColor, LAuto, LAuto2, LAutoStep, LAutoStep2: TLabel;

    CBFonts: TComboBox;

    CBFontBold, CBFontItalic, CBFontUnderline, CBCross, CBAuto, CBDirection: TCheckBox;

    SFontColor, SFontBackColor: TShape;

    BFullScreen, BFullScreenExtended: TButton;

    OldBounds: TRect;

    TAuto: TTimer;

    TimerBusy: Boolean;

(* -------------------------------- Events ---------------------------------- *)

procedure TForm1.FormCreate(Sender: TObject);

begin

  Form1.Position:=poScreenCenter;

  Form1.Caption:='Text - Rotation';

  Form1.OnClick:=NormalScreen;

  MakeObjects;

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

  MakeBmp;

  PaintBmp;

end;

procedure TForm1.FormResize(Sender: TObject);

begin

  Form1.Repaint;

end;

procedure TForm1.Change(Sender: TObject);

begin

  if TComponent(Sender)=EAuto then begin

    TAuto.Interval:=StrToInt(EAuto.Text);

    Exit;

  end;

  MakeBmp;

  PaintBmp;

end;

procedure TForm1.SBScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);

begin

  if TScrollBar(Sender)=SBGrad then EGrad.Text:=Format('%1.1f',[ScrollPos/10]);

  if TScrollBar(Sender)=SBFontSize then EFontSize.Text:=IntToStr(ScrollPos);

  if TScrollBar(Sender)=SBAuto then EAuto.Text:=IntToStr(ScrollPos);

  if TScrollBar(Sender)=SBAutoStep then EAutoStep.Text:=IntToStr(ScrollPos);

end;

procedure TForm1.ChangeColor(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

var ColorDlg: TColorDialog;

begin

  ColorDlg:=TColorDialog.Create(Self);

  ColorDlg.Color:=TShape(Sender).Brush.Color;

  if ColorDlg.Execute then begin

    if (TShape(Sender)=SFontBackColor) and (ColorDlg.Color=clWhite) then begin

      TShape(Sender).Brush.Style:=bsClear;

    end else begin

      TShape(Sender).Brush.Color:=ColorDlg.Color;

    end;

    Change(Self);

  end;

  FreeAndNil(ColorDlg);

end;

procedure TForm1.FullScreen(Sender: TObject);

var NewBounds: TRect;

begin

  if (Form1.FormStyle=fsStayOnTop) or

     (MessageDlg('Den Vollbild-Modus können Sie mit einem Klick auf die Zeichenfläche wieder beenden.',

                 mtInformation,[mbOK,mbAbort],0,mbOK)=mrAbort) then Exit;

  OldBounds:=Form1.BoundsRect;

  Form1.BorderStyle:=bsNone;

  Form1.FormStyle:=fsStayOnTop;

  if TButton(Sender)=BFullScreen then NewBounds:=Screen.MonitorFromPoint(Point(Form1.Left+Round(Form1.Width div 2),Form1.Top+Round(Form1.Height div 2))).BoundsRect;

  if TButton(Sender)=BFullScreenExtended then NewBounds:=Screen.DesktopRect;

  NewBounds.Left:=NewBounds.Left-10;

  NewBounds.Top:=NewBounds.Top-10;

  NewBounds.Right:=NewBounds.Right+210;

  NewBounds.Bottom:=NewBounds.Bottom+10;

  Form1.BoundsRect:=NewBounds;

end;

procedure TForm1.NormalScreen(Sender: TObject);

begin

  if Form1.FormStyle=fsNormal then Exit;

  Form1.BorderStyle:=bsSizeable;

  Form1.FormStyle:=fsNormal;

  Form1.BoundsRect:=OldBounds;

end;

procedure TForm1.OnTime(Sender: TObject);

var Grad: Real;

begin

  if (CBAuto.Checked=False) or (TimerBusy) then Exit;

  TimerBusy:=True;

  if CBDirection.Checked then begin

    Grad:=StrToFloat(EGrad.Text)-StrToInt(EAutoStep.Text);

    if Grad<SBGrad.Min then Grad:=359;

  end else begin

    Grad:=StrToFloat(EGrad.Text)+StrToInt(EAutoStep.Text);

    if SBGrad.Max-1<Grad then Grad:=0;

  end;

  EGrad.Text:=Format('%1.1f',[Grad]);

  TimerBusy:=False;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

  TAuto.Enabled:=False;

  FreeObjects;

end;

(* ------------------------------ Objekte ----------------------------------- *)

procedure TForm1.MakeObjects;

var X, Y: Integer;

begin

  X:=Form1.ClientWidth-200;

  Y:=10;

  Bmp:=TBitmap.Create;

  LAusgabe:=TLabel.Create(Self);

  LAusgabe.Parent:=Form1;

  LAusgabe.Left:=X;

  LAusgabe.Top:=Y;

  LAusgabe.Caption:='Ausgabe - Text:';

  LAusgabe.Font.Style:=[fsBold,fsUnderline];

  LAusgabe.Anchors:=[akTop,akRight];

  Y:=Y+LAusgabe.Height+5;

  EText:=TEdit.Create(Self);

  EText.Parent:=Form1;

  EText.Left:=X;

  EText.Top:=Y;

  EText.Width:=190;

  EText.Text:='Rotation';

  EText.Anchors:=[akTop,akRight];

  EText.OnChange:=Change;

  Y:=Y+EText.Height+5;

  LGrad:=TLabel.Create(Self);

  LGrad.Parent:=Form1;

  LGrad.Left:=X;

  LGrad.Top:=Y;

  LGrad.Caption:='Grad';

  LGrad.Font.Style:=[fsBold,fsUnderline];

  LGrad.Anchors:=[akTop,akRight];

  Y:=Y+LGrad.Height+5;

  EGrad:=TEdit.Create(Self);

  EGrad.Parent:=Form1;

  EGrad.Left:=X;

  EGrad.Top:=Y;

  EGrad.Width:=40;

  EGrad.Text:='0,0';

  EGrad.Anchors:=[akTop,akRight];

  EGrad.ReadOnly:=True;

  EGrad.OnChange:=Change;

  Y:=Y+EGrad.Height+5;

  SBGrad:=TScrollBar.Create(Self);

  SBGrad.Parent:=Form1;

  SBGrad.Kind:=sbVertical;

  SBGrad.Left:=X;

  SBGrad.Width:=30;

  SBGrad.Top:=Y;

  SBGrad.Height:=Form1.ClientHeight-Y-10;

  SBGrad.Max:=3600;

  SBGrad.Position:=0;

  SBGrad.LargeChange:=150;

  SBGrad.OnScroll:=SBScroll;

  SBGrad.Anchors:=[akTop,akRight,akBottom];

  X:=EGrad.Left+EGrad.Width+10;

  Y:=LGrad.Top;

  LFonts:=TLabel.Create(Self);

  LFonts.Parent:=Form1;

  LFonts.Left:=X;

  LFonts.Top:=Y;

  LFonts.Caption:='Schriften:';

  LFonts.Font.Style:=[fsBold,fsUnderline];

  LFonts.Anchors:=[akTop,akRight];

  Y:=Y+LFonts.Height+5;

  CBFonts:=TComboBox.Create(Self);

  CBFonts.Parent:=Form1;

  CBFonts.Left:=X;

  CBFonts.Top:=Y;

  CBFonts.Width:=Form1.ClientWidth-X-10;

  CBFonts.Items.AddStrings(Screen.Fonts);

  CBFonts.ItemIndex:=CBFonts.Items.IndexOf('Arial');

  CBFonts.DropDownCount:=20;

  CBFonts.Anchors:=[akTop,akRight];

  CBFonts.OnChange:=Change;

  Y:=Y+CBFonts.Height+5;

  LFontSize:=TLabel.Create(Self);

  LFontSize.Parent:=Form1;

  LFontSize.Left:=X;

  LFontSize.Top:=Y;

  LFontSize.Caption:='Schrift - Größe:';

  LFontSize.Font.Style:=[fsBold,fsUnderline];

  LFontSize.Anchors:=[akTop,akRight];

  Y:=Y+LFontSize.Height+5;

  EFontSize:=TEdit.Create(Self);

  EFontSize.Parent:=Form1;

  EFontSize.Left:=X;

  EFontSize.Top:=Y;

  EFontSize.Width:=30;

  EFontSize.Text:='50';

  EFontSize.Anchors:=[akTop,akRight];

  EFontSize.ReadOnly:=True;

  EFontSize.OnChange:=Change;

  Y:=Y+EFontSize.Height+5;

  SBFontSize:=TScrollBar.Create(Self);

  SBFontSize.Parent:=Form1;

  SBFontSize.Kind:=sbHorizontal;

  SBFontSize.Left:=X;

  SBFontSize.Width:=Form1.ClientWidth-X-10;

  SBFontSize.Top:=Y;

  SBFontSize.Height:=15;

  SBFontSize.Min:=1;

  SBFontSize.Max:=5000;

  SBFontSize.Position:=StrToInt(EFontSize.Text);

  SBFontSize.LargeChange:=100;

  SBFontSize.OnScroll:=SBScroll;

  SBFontSize.Anchors:=[akTop,akRight];

  Y:=Y+SBFontSize.Height+5;

  LFontStyle:=TLabel.Create(Self);

  LFontStyle.Parent:=Form1;

  LFontStyle.Left:=X;

  LFontStyle.Top:=Y;

  LFontStyle.Caption:='Schrift - Style:';

  LFontStyle.Font.Style:=[fsBold,fsUnderline];

  LFontStyle.Anchors:=[akTop,akRight];

  Y:=Y+LFontStyle.Height+5;

  CBFontBold:=TCheckBox.Create(Self);

  CBFontBold.Parent:=Form1;

  CBFontBold.Left:=X;

  CBFontBold.Top:=Y;

  CBFontBold.Caption:='Fett';

  CBFontBold.Anchors:=[akTop,akRight];

  CBFontBold.OnClick:=Change;

  Y:=Y+CBFontBold.Height+5;

  CBFontItalic:=TCheckBox.Create(Self);

  CBFontItalic.Parent:=Form1;

  CBFontItalic.Left:=X;

  CBFontItalic.Top:=Y;

  CBFontItalic.Caption:='Kursiv';

  CBFontItalic.Anchors:=[akTop,akRight];

  CBFontItalic.OnClick:=Change;

  Y:=Y+CBFontItalic.Height+5;

  CBFontUnderline:=TCheckBox.Create(Self);

  CBFontUnderline.Parent:=Form1;

  CBFontUnderline.Left:=X;

  CBFontUnderline.Top:=Y;

  CBFontUnderline.Caption:='Unterstrichen';

  CBFontUnderline.Anchors:=[akTop,akRight];

  CBFontUnderline.OnClick:=Change;

  Y:=Y+CBFontUnderline.Height+5;

  LFontColor:=TLabel.Create(Self);

  LFontColor.Parent:=Form1;

  LFontColor.Left:=X;

  LFontColor.Top:=Y;

  LFontColor.Caption:='Schrift - Farbe:';

  LFontColor.Font.Style:=[fsBold,fsUnderline];

  LFontColor.Anchors:=[akTop,akRight];

  Y:=Y+LFontColor.Height+5;

  SFontColor:=TShape.Create(Self);

  SFontColor.Parent:=Form1;

  SFontColor.Left:=X;

  SFontColor.Top:=Y;

  SFontColor.Width:=Form1.ClientWidth-X-10;

  SFontColor.Height:=15;

  SFontColor.Pen.Style:=psClear;

  SFontColor.Brush.Color:=clBlack;

  SFontColor.Anchors:=[akTop,akRight];

  SFontColor.OnMouseUp:=ChangeColor;

  Y:=Y+SFontColor.Height+5;

  LFontBackColor:=TLabel.Create(Self);

  LFontBackColor.Parent:=Form1;

  LFontBackColor.Left:=X;

  LFontBackColor.Top:=Y;

  LFontBackColor.Caption:='Schrift - Hintergundfarbe:';

  LFontBackColor.Font.Style:=[fsBold,fsUnderline];

  LFontBackColor.Anchors:=[akTop,akRight];

  Y:=Y+LFontBackColor.Height+5;

  SFontBackColor:=TShape.Create(Self);

  SFontBackColor.Parent:=Form1;

  SFontBackColor.Left:=X;

  SFontBackColor.Top:=Y;

  SFontBackColor.Width:=Form1.ClientWidth-X-10;

  SFontBackColor.Height:=15;

  SFontBackColor.Brush.Style:=bsClear;

  SFontBackColor.Anchors:=[akTop,akRight];

  SFontBackColor.OnMouseUp:=ChangeColor;

  Y:=Y+SFontBackColor.Height+5;

  CBCross:=TCheckBox.Create(Self);

  CBCross.Parent:=Form1;

  CBCross.Left:=X;

  CBCross.Top:=Y;

  CBCross.Font.Style:=[fsBold];

  CBCross.Caption:='Fadenkreuz';

  CBCross.Checked:=True;

  CBCross.Anchors:=[akTop,akRight];

  CBCross.OnClick:=Change;

  Y:=Y+CBFontBold.Height+5;

  BFullScreen:=TButton.Create(Self);

  BFullScreen.Parent:=Form1;

  BFullScreen.Left:=X;

  BFullScreen.Top:=Y;

  BFullScreen.Caption:='Vollbild';

  BFullScreen.Anchors:=[akTop,akRight];

  BFullScreen.OnClick:=FullScreen;

  Y:=Y+BFullScreen.Height+5;

  BFullScreenExtended:=TButton.Create(Self);

  BFullScreenExtended.Parent:=Form1;

  BFullScreenExtended.Left:=X;

  BFullScreenExtended.Top:=Y;

  BFullScreenExtended.Width:=Form1.ClientWidth-X-10;

  BFullScreenExtended.Caption:='Vollbild - Alle Monitore';

  BFullScreenExtended.Anchors:=[akTop,akRight];

  BFullScreenExtended.OnClick:=FullScreen;

  Y:=Y+BFullScreenExtended.Height+5;

  TimerBusy:=False;

  TAuto:=TTimer.Create(Self);

  TAuto.Interval:=50;

  TAuto.Enabled:=True;

  TAuto.OnTimer:=OnTime;

  LAuto:=TLabel.Create(Self);

  LAuto.Parent:=Form1;

  LAuto.Left:=X;

  LAuto.Top:=Y;

  LAuto.Caption:='Automatik:';

  LAuto.Font.Style:=[fsBold,fsUnderline];

  LAuto.Anchors:=[akTop,akRight];

  Y:=Y+LAuto.Height+5;

  EAuto:=TEdit.Create(Self);

  EAuto.Parent:=Form1;

  EAuto.Left:=X;

  EAuto.Top:=Y;

  EAuto.Width:=40;

  EAuto.Text:=IntToStr(TAuto.Interval);

  EAuto.Anchors:=[akTop,akRight];

  EAuto.ReadOnly:=True;

  EAuto.OnChange:=Change;

  LAuto2:=TLabel.Create(Self);

  LAuto2.Parent:=Form1;

  LAuto2.Left:=X+EAuto.Width+5;

  LAuto2.Top:=Y+2;

  LAuto2.Caption:='Millisekunden';

  LAuto2.Anchors:=[akTop,akRight];

  Y:=Y+EAuto.Height+5;

  SBAuto:=TScrollBar.Create(Self);

  SBAuto.Parent:=Form1;

  SBAuto.Kind:=sbHorizontal;

  SBAuto.Left:=X;

  SBAuto.Width:=Form1.ClientWidth-X-10;

  SBAuto.Top:=Y;

  SBAuto.Height:=SBFontSize.Height;

  SBAuto.Min:=1;

  SBAuto.Max:=1000;

  SBAuto.Position:=StrToInt(EAuto.Text);

  SBAuto.LargeChange:=50;

  SBAuto.OnScroll:=SBScroll;

  SBAuto.Anchors:=[akTop,akRight];

  Y:=Y+SBFontSize.Height+5;

  LAutoStep:=TLabel.Create(Self);

  LAutoStep.Parent:=Form1;

  LAutoStep.Left:=X;

  LAutoStep.Top:=Y;

  LAutoStep.Caption:='Schritte:';

  LAutoStep.Font.Style:=[fsUnderline];

  LAutoStep.Anchors:=[akTop,akRight];

  Y:=Y+LAutoStep.Height+5;

  EAutoStep:=TEdit.Create(Self);

  EAutoStep.Parent:=Form1;

  EAutoStep.Left:=X;

  EAutoStep.Top:=Y;

  EAutoStep.Width:=40;

  EAutoStep.Text:='15';

  EAutoStep.Anchors:=[akTop,akRight];

  EAutoStep.ReadOnly:=True;

  LAutoStep2:=TLabel.Create(Self);

  LAutoStep2.Parent:=Form1;

  LAutoStep2.Left:=X+EAutoStep.Width+5;

  LAutoStep2.Top:=Y+2;

  LAutoStep2.Caption:='Grad';

  LAutoStep2.Anchors:=[akTop,akRight];

  Y:=Y+EAutoStep.Height+5;

  SBAutoStep:=TScrollBar.Create(Self);

  SBAutoStep.Parent:=Form1;

  SBAutoStep.Kind:=sbHorizontal;

  SBAutoStep.Left:=X;

  SBAutoStep.Width:=Form1.ClientWidth-X-10;

  SBAutoStep.Top:=Y;

  SBAutoStep.Height:=SBFontSize.Height;

  SBAutoStep.Min:=1;

  SBAutoStep.Max:=180;

  SBAutoStep.Position:=StrToInt(EAutoStep.Text);

  SBAutoStep.LargeChange:=6;

  SBAutoStep.OnScroll:=SBScroll;

  SBAutoStep.Anchors:=[akTop,akRight];

  Y:=Y+SBAutoStep.Height+5;

  CBDirection:=TCheckBox.Create(Self);

  CBDirection.Parent:=Form1;

  CBDirection.Left:=X;

  CBDirection.Top:=Y;

  CBDirection.Width:=Form1.ClientWidth-X-10;

  CBDirection.Font.Style:=[fsBold];

  CBDirection.Caption:='im Uhrzeigersinn';

  CBDirection.Checked:=True;

  CBDirection.Anchors:=[akTop,akRight];

  Y:=Y+CBDirection.Height+5;

  CBAuto:=TCheckBox.Create(Self);

  CBAuto.Parent:=Form1;

  CBAuto.Left:=X;

  CBAuto.Top:=Y;

  CBAuto.Font.Style:=[fsBold];

  CBAuto.Caption:='Timer';

  CBAuto.Anchors:=[akTop,akRight];

  Y:=Y+CBAuto.Height+5;

end;

procedure TForm1.MakeBmp;

var X, Y: Integer;

    fs: TFontStyles;

begin

  Bmp.Width:=LAusgabe.Left-20;

  Bmp.Height:=Form1.ClientHeight-20;

  X:=Round(Bmp.Width div 2);

  Y:=Round(Bmp.Height div 2);

  with Bmp.Canvas do begin

    Brush.Style:=bsSolid;

    Brush.Color:=clWhite;

    FillRect(Rect(0,0,Bmp.Width,Bmp.Height));

    if CBCross.Checked then begin

      Pen.Style:=psSolid;

      Pen.Color:=clBlack;

      Pen.Width:=1;

      MoveTo(X,0); LineTo(X,Bmp.Height);

      MoveTo(0,Y); LineTo(Bmp.Width,Y);

    end;

  end;

  if CBFontBold.Checked then fs:=fs+[fsBold];

  if CBFontItalic.Checked then fs:=fs+[fsItalic];

  if CBFontUnderline.Checked then fs:=fs+[fsUnderline];

  TextRotation(EText.Text, CBFonts.Text,StrToInt(EFontSize.Text), SFontColor.Brush.Color, fs,

               SFontBackColor.Brush.Style, SFontBackColor.Brush.Color,

               StrToFloat(EGrad.Text),

               Bmp.Canvas,

               Point(Round(Bmp.Width div 2), Round(Bmp.Height div 2)));

end;

procedure TForm1.FreeObjects;

begin

  FreeAndNil(Bmp);

  FreeAndNil(LAusgabe);

  FreeAndNil(EText);

  FreeAndNil(LGrad);

  FreeAndNil(EGrad);

  FreeAndNil(SBGrad);

  FreeAndNil(LFonts);

  FreeAndNil(CBFonts);

  FreeAndNil(LFontSize);

  FreeAndNil(EFontSize);

  FreeAndNil(SBFontSize);

  FreeAndNil(LFontStyle);

  FreeAndNil(CBFontBold);

  FreeAndNil(CBFontItalic);

  FreeAndNil(CBFontUnderline);

  FreeAndNil(LFontColor);

  FreeAndNil(SFontColor);

  FreeAndNil(LFontBackColor);

  FreeAndNil(SFontBackColor);

  FreeAndNil(CBCross);

  FreeAndNil(BFullScreen);

  FreeAndNil(BFullScreenExtended);

  FreeAndNil(LAuto);

  FreeAndNil(EAuto);

  FreeAndNil(LAuto2);

  FreeAndNil(SBAuto);

  FreeAndNil(LAutoStep);

  FreeAndNil(EAutoStep);

  FreeAndNil(LAutoStep2);

  FreeAndNil(SBAutoStep);

  FreeAndNil(CBDirection);

  FreeAndNil(CBAuto);

end;

(* ---------------------------- Text - Rotation ----------------------------- *)

procedure TForm1.TextRotation(rText, fName: String;

                              fSize: Integer; fColor: TColor; fStyles: TFontStyles;

                              fBrushStyle: TBrushStyle; fBrushColor:TColor;

                              Grad: Real; aCanvas: TCanvas; Mittelpunkt: TPoint);

var hFont, FontOld, fnWeight: Integer;

    fdwItalic, fdwUnderline, fdwStrikeOut: DWord;

    Radius: Real;

    KorrX, KorrY: Integer;

    TextMetric: TTextMetric;

begin

  (* Funktioniert nur mit TrueType oder Vektor - Schriftarten *)

  if (Length(rText)=0) or (Screen.Fonts.IndexOf(fName)=-1) or (fSize<1) or (aCanvas=nil) then Exit;

  (* Font - Styles extrahieren *)

  if fsBold IN fStyles then fnWeight:=FW_BOLD else fnWeight:=FW_NORMAL;

  if fsItalic IN fStyles then fdwItalic:=1 else fdwItalic:=0;

  if fsUnderline IN fStyles then fdwUnderline:=1 else fdwUnderline:=0;

  if fsStrikeOut IN fStyles then fdwStrikeOut:=1 else fdwStrikeOut:=0;

  (* Schrift-Farbe *)

  aCanvas.Font.Color:=fColor;

  (* Schrift-Hintergrund *)

  aCanvas.Brush.Color:=fBrushColor;

  aCanvas.Brush.Style:=fBrushStyle;

  (* Neue Font erstellen *)

  hFont:=CreateFont(-fSize,0,Round(Grad*10),0,

                    fnWeight, fdwItalic, fdwUnderline, fdwStrikeOut,

                    1,4,$10,2,4,PChar(fName));

  (* Alte Font sichern und Neue anwenden *)

  FontOld:=SelectObject(aCanvas.Handle, hFont);

  (* Referenzpunkt auf die horizontale Mitte des Textes legen *)

  SetTextAlign(aCanvas.Handle,TA_CENTER);

  (* TextMetric abfragen *)

  GetTextMetrics(aCanvas.Handle,TextMetric);

  (* Auf True Type prüfen *)

  if TextMetric.tmPitchAndFamily and (TMPF_TRUETYPE or TMPF_VECTOR)= 0 then rText:='Nur True-Type oder Vektor - Schriftarten!';

  (* Radius ( = Halbe Texthöhe) ermitteln *)

  Radius:=TextMetric.tmHeight div 2;

  (* X- und Y-Verschiebung über cos-phi und sin-phi ermitteln *)

  KorrX:=Round(sin(DegToRad(Grad))*Radius);

  KorrY:=Round(cos(DegToRad(Grad))*Radius);

  (* Text zeichnen *)

  TextOut(aCanvas.Handle, Mittelpunkt.X-KorrX ,Mittelpunkt.Y-KorrY ,PChar(rText) ,Length(rText));

  (* Alte Font wiederherstellen *)

  SelectObject(aCanvas.Handle,FontOld);

  (* Neue Font löschen *)

  DeleteObject(hFont);

end;

(* -------------------------------- Zeichnen -------------------------------- *)

procedure TForm1.PaintBmp;

begin

  Form1.Canvas.Draw(10,10,Bmp);

end;

end.

Lediglich noch diese vier Events mit Form1 im Objektinspektor verbinden:

-OnCreate -> FormCreate
-OnDestroy -> FormDestroy
-OnPaint -> FormPaint
-OnResize -> FormResize

Alternativ zur Selbst-Compilierung habe ich noch die fertige Anwendung angehängt!
!!!!

Noch schneller zum Testen

!!!!

PS: Beim Multi-Monitoring ergibt die Anwendung echt tolle Effekte.

Grüße an Alle!

Dr. MAD

**Matze**

Hallo Dr. MAD, herzlich Willkommen! (du bist zwar schon lange registriert, aber das ist dein erster Beitrag)

Ich habe mir die Anwendung angeschaut und muss sagen: Wow! Das sieht richtig gut aus.

Text-Rotation - Textausgabe mit beliebiger Gradzahl

Text-Rotation - Textausgabe mit beliebiger Gradzahl

Re: Text-Rotation - Textausgabe mit beliebiger Gradzahl

Forumregeln

Matze (Co-Admin) Registriert seit: 7. Jul 2003 Ort: Schwabenländle 14.929 Beiträge Turbo Delphi für Win32	#2 Re: Text-Rotation - Textausgabe mit beliebiger Gradzahl 9. Mär 2010, 18:14 Hallo Dr. MAD, herzlich Willkommen! (du bist zwar schon lange registriert, aber das ist dein erster Beitrag) Ich habe mir die Anwendung angeschaut und muss sagen: Wow! Das sieht richtig gut aus.
	Zitat