AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Zurück Delphi-PRAXiS Code-Bibliothek Neuen Beitrag zur Code-Library hinzufügen Delphi Text-Rotation - Textausgabe mit beliebiger Gradzahl

Text-Rotation - Textausgabe mit beliebiger Gradzahl

Ein Thema von Dr.MAD · begonnen am 9. Mär 2010 · letzter Beitrag vom 9. Mär 2010
Antwort Antwort
Dr.MAD

Registriert seit: 16. Jan 2006
18 Beiträge
 
#1

Text-Rotation - Textausgabe mit beliebiger Gradzahl

  Alt 9. Mär 2010, 18:07
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.

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:

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
Angehängte Dateien
Dateityp: rar rotation_107.rar (236,3 KB, 48x aufgerufen)
Matthias
  Mit Zitat antworten Zitat
Benutzerbild von Matze
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

  Alt 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.
  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 12:07 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz