unit FontUtl;

interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TAnchorStyle = (asNone, asTextLeft, asTextCenter, asTextRight);
  TTrueTypeAlert = (ttaNone, ttaMessage, ttaAbort, ttaAbortMessage);
  TRectangleMode = (rmNone, rmFixed, rmAutoSize);

  TAngledValues = record
    fntWidth,
    fntHeight,
    txtWidth,
    txtHeight,
    gapTxtWidth,
    gapTxtHeight,
    totWidth,
    totHeight,
    posLeft,
    posTop,
    posX,
    posY: Integer
  end;

  TAngleText = class(TObject)
  private
    FAngle: integer;
      { This property indicates the angle of text in degrees. The value for
        this property can be any integer value, and this value is automaticaly
        reduced to 0..359 range. }
    FZoom: integer;
    FAnchorStyle: TAnchorStyle;
      { This property replaces the Alignment property of normal labels. It's
        to supply the text alignment in any angle. If AutoSize is True,
        the position of component (Left and Top) is modified to maintain
        the position of text. Otherwise, if AutoSize is False, the position
        of text is adjusted inside the component.
            +--------------+--------------------------+
            | Value        | Meaning                  |
            +==============+==========================+
            |*asNone       | Normal behavior          |
            +--------------+--------------------------+
            | asTextLeft   | Achor to left of text    |
            +--------------+--------------------------+
            | asTextCenter | Anchor on center of text |
            +--------------+--------------------------+
            | asTextRight  | Anchor to right of text  |
            +--------------+--------------------------+
            * Default value }
    {    TrueTypeAlert: TTrueTypeAlert
      This property prevents the use of non TrueType Fonts in the component. The Font
      property normaly accept any font, but only TrueType Fonts can be cornered.
      +-----------------+------------------------------------------------------------+
      | Value           | Meaning                                                    |
      +=================+============================================================+
      | ttaNone         | Normal behavior. Accept any font                           |
      +-----------------+------------------------------------------------------------+
      | ttaMessage      | Accept any font, but raise an alert message                |
      +-----------------+------------------------------------------------------------+
      |*ttaAbort        | Don't accept non TrueType fonts. A valid font is assigned  |
      +-----------------+------------------------------------------------------------+
      | ttaAbortMessage | Don't accept non TrueType fonts and raise an alert message |
      +-----------------+------------------------------------------------------------+
      * Default value
    }
    FLeft, FTop, FWidth, FHeight: integer;
     { Calculated from X,Y parameters and from FValues (see FRectangleMode) }
    FRectangleMode: TRectangleMode;
      { rmNone - only FLeft and FTop values used a starting point for drawing
        the text, all text will be rendered,
        rmFixed - the text will be drawn inside the rectangle given by TextOut
                  X,Y parameters (will be set to FLeft, FTop) and constant
                  FWidth and FHeight parameters.}
    {FAutoSize: boolean;
      { Always false, not real meaning }
    FValues: TAngledValues;
    FTTFonts: TStringList;
    FFontName: string;
      { if not empty, assign as the font name }
    {FFont: TFont;
      { Angled font, assigned to FCanvas during TextOut }
    FOldFont: TFont;
      { Original ACanvas font }
    FScrFont: TFont;
    FCanvas: TCanvas;
      { Used to find TTFonts and to write onto }
    FTransparent: boolean;
    FBrushColor: TColor;
      { Set to FCanvas.Brush.Color in create, can be changed to
        get different text background color }
  protected
    procedure CalculateAngledValues(const pCaption: shortstring);
    procedure SetAngle(AAngle: integer);
    procedure SetCanvas(ACanvas: TCanvas);
  public
    constructor Create({ACanvas: TCanvas; }AAngle: integer);reintroduce;
    procedure TextOut(IsScr:boolean; ACanvas: TCanvas; AColor: TColor;
      X, Y: integer; const AText: shortstring);
    destructor Destroy;override;
    property Angle: integer read FAngle write SetAngle;
    property Canvas: TCanvas read FCanvas write SetCanvas;
  end;

implementation

function DegToRad(pDegrees: Real): Real;
begin
  Result := (pDegrees * PI / 180);
end;

function EnumTTFontsProc(var pLogFont: TLogFont; var pTextMetric: TTextMetric;
 pFontType: Integer; pData: Pointer): Integer; export;
 {$IFDEF WIN32} StdCall; {$ENDIF}
begin
  if (pFontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE) then
    TStringList(pData^).Add(StrPas(pLogFont.lfFaceName))
  ;
  Result := 1;
end;

procedure BuildTTFontsList(DC: HDC; FTTFonts: TStringList);
var
{  DC: HDC;}
  EnumProc: TFarProc;
begin
{  DC := GetDC(Handle);{or 0}
  FTTFonts.Clear;
  try
    EnumProc := MakeProcInstance(@EnumTTFontsProc, HInstance);
    try
      EnumFonts(DC, nil, EnumProc, @FTTFonts);
    finally
      FreeProcInstance(EnumProc);
    end;
  finally
    {ReleaseDC(0, DC);}
  end;
end;

procedure CreateAngledCanvasFont(ACanvas: TCanvas; AFontName: string; pAngle: Integer);
{ Create angled font. Procedure writen by Keith Wood }
var
  FntLogRec: TLogFont { Storage area for font information };
begin
  if AFontName <> '' then
    ACanvas.Font.Name := AFontName;
  { Get the current font information. We only want to modify the angle }
  GetObject(ACanvas.Font.Handle, SizeOf(FntLogRec), Addr(FntLogRec));

  { Modify the angle. "The angle, in tenths of a degrees, between the base
    line of a character and the x-axis." (Windows API Help file.) }
  FntLogRec.lfEscapement := (pAngle * 10);
  FntLogRec.lfOrientation := (pAngle * 10);

  FntLogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;  { Request TrueType precision }
  { Delphi will handle the deallocation of the old font handle }
  ACanvas.Font.Handle := CreateFontIndirect(FntLogRec);
end;

procedure CreateAngledFont(var AFont: TFont; AFontName: string; pAngle: Integer);
{ Create angled font. Procedure writen by Keith Wood }
var
  FntLogRec: TLogFont { Storage area for font information } ;
begin
  if AFontName <> '' then
    AFont.Name := AFontName;
  { Get the current font information. We only want to modify the angle }
  GetObject(AFont.Handle, SizeOf(FntLogRec), Addr(FntLogRec));

  { Modify the angle. "The angle, in tenths of a degrees, between the base
    line of a character and the x-axis." (Windows API Help file.) }
  FntLogRec.lfEscapement := (pAngle * 10);
  FntLogRec.lfOrientation := (pAngle * 10);
  FntLogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;  { Request TrueType precision }
  { Delphi will handle the deallocation of the old font handle }
  AFont.Handle := CreateFontIndirect(FntLogRec);
end;


{TAngleText}

constructor TAngleText.Create({ACanvas: TCanvas; }AAngle: integer);
begin
  inherited Create;
  FZoom := 100;
  FAnchorStyle := asTextLeft;
  FRectangleMode := rmNone;
  FTransparent := false;
  FTTFonts := TStringList.Create;
  FOldFont := TFont.Create;
  FScrFont := TFont.Create;
{  Canvas := ACanvas;}
  Angle := AAngle;
end;

procedure TAngleText.SetCanvas(ACanvas: TCanvas);
var i: integer;
begin
  if ACanvas <> FCanvas then begin
    FCanvas := ACanvas;
    FBrushColor := FCanvas.Brush.Color;
    BuildTTFontsList(FCanvas.Handle, FTTFonts);
    if FTTFonts.Count > 0 then begin
      if FTTFonts.IndexOf(FCanvas.Font.Name) < 0 then begin
        i := FTTFonts.IndexOf('Arial');
        if i >= 0 then
          FFontName := FTTFonts[i]
        else
          FFontName := FTTFonts[0];
      end else
        FFontName := '';
    end;
    {FOldFont.Assign(FCanvas.Font);
    Angle := FAngle;}
  end;
end;

procedure TAngleText.SetAngle(AAngle: Integer);
begin
{  FFont.Free;}
  FAngle := AAngle mod 360;
{ CreateAngledFont(FFont, FAngle);}
end;

procedure TAngleText.CalculateAngledValues(const pCaption: shortstring);
var
  angB: Real;
  nCenterX, nCenterY: Integer;
begin
  if FCanvas.Font.Size <> Round(FOldFont.Size * FZoom / 100) then
    FCanvas.Font.Size := Round(FOldFont.Size * FZoom / 100);

  { Calculate intermediate FValues }
  FValues.fntWidth := FCanvas.TextWidth(pCaption);
  FValues.fntHeight := FCanvas.TextHeight(pCaption);

  case FAngle of
    0..89   : angB := DegToRad(90 - FAngle);
    90..179 : angB := DegToRad(FAngle - 90);
    180..269: angB := DegToRad(270 - FAngle);
  else { 270..359 }
    angB := DegToRad(FAngle - 270)
  end;

  FValues.txtWidth := Round(sin(angB) * FValues.fntWidth);
  FValues.gapTxtWidth := Round(cos(angB) * FValues.fntHeight);
  FValues.txtHeight := Round(cos(angB) * FValues.fntWidth);
  FValues.gapTxtHeight := Round(sin(angB) * FValues.fntHeight);

  { Calculate new sizes of component }
  FValues.totWidth := (FValues.txtWidth + FValues.gapTxtWidth);
  FValues.totHeight := (FValues.txtHeight + FValues.gapTxtHeight);

  case FRectangleMode of
    rmNone: begin
      FWidth := FValues.totWidth;
      FHeight := FValues.totHeight;
    end;
  end;

  { Calculate Anchor positon of component }
  if FAnchorStyle in [asNone] then
  begin
    FValues.posLeft := FLeft;
    FValues.posTop := FTop;
  end else begin

    if FAnchorStyle in [asTextLeft] then
    begin
      { Calculate FLeft position }
      case FAngle of
        0..89: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posLeft := FLeft;
            end;
          else
            FValues.posLeft := FLeft;
          end;
        end;

        270..359: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posLeft := FLeft - FValues.gapTxtWidth;
            end;
          else
            FValues.posLeft := FLeft;
          end;
        end;

        90..179: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posLeft := FLeft - FValues.txtWidth;
            end;
          else
            FValues.posLeft := (FLeft + FWidth - FValues.totWidth)
          end;
        end;

        180..269: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posLeft := FLeft - FValues.totWidth;
            end;
          else
            FValues.posLeft := (FLeft + FWidth - FValues.totWidth)
          end;
        end;

      end;

      { Calculate FTop position }
      case FAngle of
        180..269: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posTop := FTop - FValues.gapTxtHeight;
            end;
          else
            FValues.posTop := FTop
          end;
        end;
        270..359: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posTop := FTop;
            end;
          else
            FValues.posTop := FTop;
          end;
        end;
        0..89: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posTop := FTop - FValues.txtHeight; 
            end;
          else
            FValues.posTop := (FTop + FHeight - FValues.totHeight)
          end;
        end;
        90..179: begin
          case FRectangleMode of
            rmNone: begin
              FValues.posTop := FTop - FValues.totHeight;
            end;
          else
            FValues.posTop := (FTop + FHeight - FValues.totHeight)
          end;
        end;
      end;
    end
    else
      if FAnchorStyle in [asTextRight] then
      begin
        { Calculate FLeft position }
        case FAngle of 90..179, 180..269:
          FValues.posLeft := FLeft
        else { 0..89, 270..359 }
          FValues.posLeft := (FLeft + FWidth - FValues.totWidth)
        end;
        { Calculate FTop position }
        case FAngle of 0..89, 90..179:
          FValues.posTop := FTop
        else { 180..269, 270..359 }
          FValues.posTop := (FTop + FHeight - FValues.totHeight)
        end;
      end
      else { asTextCenter }
      begin
        FValues.posLeft := (FLeft + Round((FWidth - FValues.totWidth) / 2));
        FValues.posTop := (FTop + Round((FHeight - FValues.totHeight) / 2));
      end
  end;


  { Calculate draw position of text }
  case FAngle of
    0..89: begin
      case FRectangleMode of
        rmNone: begin
          FValues.posX := 0;
          FValues.posY := 0;
        end;
      else
        FValues.posX := 0;
        FValues.posY := FValues.txtHeight
      end;
    end;

    90..179: begin
      case FRectangleMode of
        rmNone: begin
          FValues.posX := 0;
          FValues.posY := 0;
        end;
      else
        FValues.posX := FValues.txtWidth;
        FValues.posY := FValues.totHeight
      end;
    end;

    180..269: begin
      case FRectangleMode of
        rmNone: begin
          FValues.posX := 0;
          FValues.posY := 0;
        end;
      else
        FValues.posX := FValues.totWidth;
        FValues.posY := FValues.gapTxtHeight
      end;
    end;
  else { 270..359 }
    begin
      case FRectangleMode of
        rmNone: begin
          FValues.posX := 0;
          FValues.posY := 0;
        end;
      else
        FValues.posX := FValues.gapTxtWidth;
        FValues.posY := 0
      end;
    end;
  end;

  { Calculate draw position of text inside area of component }
  if (FAnchorStyle in [asTextLeft, asTextRight, asTextCenter]) and
     (FRectangleMode = rmFixed)
  then begin
    if FAnchorStyle in [asTextLeft] then begin
      case FAngle of
        0..89: begin
          FValues.posX := 0;
          FValues.posY := (FHeight - FValues.gapTxtHeight);
        end;
        90..179: begin
          FValues.posX := (FWidth - FValues.gapTxtWidth);
          FValues.posY := FHeight;
        end;
        180..279: begin
          FValues.posX := FWidth;
          FValues.posY := FValues.gapTxtHeight;
        end;
      else { 280..359 }
        FValues.posX := FValues.gapTxtWidth;
        FValues.posY := 0;
      end
    end else begin
      if FAnchorStyle in [asTextRight] then begin
        case FAngle of
          0..89:
          begin
            FValues.posX := (FWidth - FValues.txtWidth - FValues.gapTxtWidth);
            FValues.posY := FValues.txtHeight;
          end;
          90..179:
          begin
            FValues.posX := FValues.txtWidth;
            FValues.posY := (FValues.txtHeight + FValues.gapTxtHeight);
          end;
          180..279:
          begin
            FValues.posX := (FValues.txtWidth + FValues.gapTxtWidth);
            FValues.posY := (FHeight - FValues.txtHeight);
          end;
        else { 280..359 }
          begin
            FValues.posX := (FWidth - FValues.txtWidth);
            FValues.posY := (FHeight - FValues.txtHeight - FValues.gapTxtHeight);
          end;
        end
      end else begin{ asTextCenter }
        begin
          nCenterX := Round((FWidth - FValues.txtWidth - FValues.gapTxtHeight) / 2);
          nCenterY := Round((FHeight - FValues.txtHeight - FValues.gapTxtHeight) / 2);
          case FAngle of
            0..89:
            begin
              FValues.posX := nCenterX;
              FValues.posY := (nCenterY + FValues.txtHeight);
            end;
            90..179:
            begin
              FValues.posX := (nCenterX + FValues.txtWidth);
              FValues.posY := (nCenterY + FValues.txtHeight + FValues.gapTxtHeight);
            end;
            180..279:
            begin
              FValues.posX := (nCenterX + FValues.txtWidth + FValues.gapTxtWidth);
              FValues.posY := (nCenterY + FValues.gapTxtHeight);
            end;
          else { 280..359 }
            begin
              FValues.posX := (nCenterX + FValues.gapTxtWidth);
              FValues.posY := nCenterY;
            end;
          end
        end
      end;
    end;
  end;
end;


procedure TAngleText.TextOut(IsScr:boolean; ACanvas: TCanvas;
  AColor: TColor;
  X, Y: integer; const AText: shortstring);
var
  aRect: TRect;
  bc: TColor;
{  i: integer;}
  fc: TColor;
begin
  Canvas := ACanvas;
  FLeft := X;
  FTop := Y;
  FOldFont.Assign(FCanvas.Font);
  try
    if false{IsScr }then begin
      CreateAngledFont(FScrFont, FFontName, FAngle);
      FCanvas.Font.Assign(FScrFont);
    end else begin
      CreateAngledCanvasFont(FCanvas, FFontName, FAngle);
    end;
    CalculateAngledValues(AText);
    fc := FCanvas.Font.Color;
    FCanvas.Font.Color := AColor;
    case FRectangleMode of
      rmNone: begin
        FWidth :=  FValues.totWidth;
        FHeight := FValues.totHeight;
      end;
      rmAutoSize: begin
        FLeft := FValues.posLeft;
        FTop := FValues.posTop;
        FWidth :=  FValues.totWidth;
        FHeight := FValues.totHeight;
      end;
    end;

    with FCanvas do
    begin
      case FRectangleMode of
        rmNone: begin
          aRect := Rect(FValues.posLeft, FValues.posTop, FValues.posLeft + FValues.totWidth,
            FValues.posTop + FValues.totHeight);
        end;
      else
        aRect := Rect(FLeft, FTop, FLeft + FWidth, FTop + FHeight);
      end;
      if not FTransparent then
      begin
        bc := Brush.Color;
        Brush.Color := FBrushColor;
        Brush.Style := bsSolid;
        FillRect(aRect);
        {Rectangle(arect.left, arect.top, arect.right, arect.bottom);}
        Brush.Color := bc;
      end;
      case FRectangleMode of
        rmNone: begin
          {DebLog('ExtTextOut(' + IntToStr(X) + '+' +IntToStr(FValues.posX) +
            ',' + IntToStr(Y) + '+' + IntToStr(FValues.posY) + ' ' + AText);}
          if not ExtTextOut(Handle, X{FLeft} + FValues.posX, Y{FTop} + FValues.posY,
            0{ETO_CLIPPED}, nil, @AText[1], Length(AText), nil)
          then begin
            {DebLog('FontUtl.ExtTextOut ER: ' + IntToStr(GetLastError));}
          end;
        end;
      else
        if not ExtTextOut(Handle, FLeft + FValues.posX, FTop + FValues.posY, ETO_CLIPPED, @aRect,
           @AText[1], Length(AText), nil)
        then begin
          {DebLog('FontUtl.ExtTextOut ER: ' + IntToStr(GetLastError));}
        end;
      end;
    end;
    FCanvas.Font.Color := fc;
  finally
    FCanvas.Font.Assign(FOldFont);
  end;
end;

destructor TAngleText.Destroy;
begin
  FTTFonts.Free;
  FOldFont.Free;
  FScrFont.Free;
  {FFont.Free;}
  inherited Destroy;
end;
{/TAngleText}

end.
