Componentes.Terceros.DevExpressVCL/official/x.36/ExpressPrinting System/Sources/dxPSTextOut.pas

{*******************************************************************}
{                                                                   }
{       Developer Express Visual Component Library                  }
{       ExpressPrinting System(tm) COMPONENT SUITE                  }
{                                                                   }
{       Copyright (C) 1998-2008 Developer Express Inc.              }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{   The entire contents of this file is protected by U.S. and       }
{   International Copyright Laws. Unauthorized reproduction,        }
{   reverse-engineering, and distribution of all or any portion of  }
{   the code contained in this file is strictly prohibited and may  }
{   result in severe civil and criminal penalties and will be       }
{   prosecuted to the maximum extent possible under the law.        }
{                                                                   }
{   RESTRICTIONS                                                    }
{                                                                   }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES           }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE    }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS   }
{   LICENSED TO DISTRIBUTE THE EXPRESSPRINTINGSYSTEM AND            }
{   ALL ACCOMPANYING VCL CONTROLS AS PART OF AN                     }
{   EXECUTABLE PROGRAM ONLY.                                        }
{                                                                   }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED      }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE        }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE       }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT  }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                      }
{                                                                   }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON       }
{   ADDITIONAL RESTRICTIONS.                                        }
{                                                                   }
{*******************************************************************}

unit dxPSTextOut;

interface

{$I cxVer.inc}

uses 
  Windows, Classes, Graphics, {$IFDEF DELPHI5} Contnrs, {$ENDIF} dxPSGlbl;

{type  
  TdxTextAlignX = (taLeft, taCenterX, taRight, taJustifyX, taDistributeX);
  TdxTextAlignY = (taTop, taCenterY, taBottom, taDistributeY);}

const  
  DXTO_LEFT                    = $00000000;
  DXTO_CENTER_HORIZONTALLY     = $00000001;
  DXTO_RIGHT                   = $00000002;
  DXTO_JUSTIFY_HORIZONTALLY    = $00000003;
  DXTO_DISTRIBUTE_HORIZONTALLY = $00000004;

  DXTO_TOP                     = $00000000;
  DXTO_CENTER_VERTICALLY       = $00000010;
  DXTO_BOTTOM                  = $00000020;
  DXTO_DISTRIBUTE_VERTICALLY   = $00000030;

  DXTO_WORDBREAK               = $00000100;  
  DXTO_SINGLELINE              = $00000200;
  DXTO_EXPANDTABS              = $00000400;
  DXTO_END_ELLIPSIS            = $00000800;

  DXTO_PATTERNEDTEXT           = $00001000;
  DXTO_EXTERNALLEADING         = $00002000;
  DXTO_EDITCONTROL             = $00004000;
  DXTO_NOCLIP                  = $00008000;
  
  DXTO_AUTOINDENTS             = $00010000;
  DXTO_CHARBREAK               = $00020000;
  DXTO_PREVENT_LEFT_EXCEED     = $00040000;
  DXTO_PREVENT_TOP_EXCEED      = $00080000;

  DXTO_CALCRECT                = $00100000;
  DXTO_CALCROWCOUNT            = $00200000;
  
  DXTO_NOPREFIX                = $00000000;
  DXTO_HIDEPREFIX              = $01000000;
  
  DXTO_DEFAULT_FORMAT          = DXTO_AUTOINDENTS or DXTO_PATTERNEDTEXT;

type
  TdxVerticalTextOutDirection = (vtdTopToBottom, vtdBottomToTop);

  TdxTextParams = record
    RowHeight: Integer;
    tmExternalLeading: Integer;
    FullRowHeight: Integer;
    OnePixel: Integer;
    EndEllipsisWidth: Integer;
    BreakChar: Char;
    Bold: Boolean;
    TextAlignX: TdxTextAlignX;
    TextAlignY: TdxTextAlignY;
    WordBreak: Boolean;
    SingleLine: Boolean;
    ExpandTabs: Boolean;
    EndEllipsis: Boolean;
    PatternedText: Boolean;
    ExternalLeading: Boolean;
    EditControl: Boolean;
    NoClip: Boolean;
    AutoIndents: Boolean;
    PreventLeftExceed: Boolean;
    PreventTopExceed: Boolean;
    CharBreak: Boolean;
    CalcRowCount: Boolean;
    CalcRect: Boolean;
    HidePrefix: Boolean;
  end;
  
  TdxTextRow = class
  public
    Text: PChar;
    CharCount: Integer;
    TextExtents: TSize;
    BreakCount: Integer;
    TextOriginX: Integer;
    TextOriginY: Integer;
    procedure CalculateExtents(DC: HDC; const ATextParams: TdxTextParams); virtual;
  end;

  TdxTextRows = class({$IFDEF DELPHI5}TObjectList{$ELSE}TList{$ENDIF})
  private
    function GetItem(Index: Integer): TdxTextRow;
    procedure SetItem(Index: Integer; Value: TdxTextRow);
  public
    function CalculateMaxWidth: Integer;
   {$IFNDEF DELPHI5}
    procedure Clear; override;
   {$ENDIF} 
    property Items[Index: Integer]: TdxTextRow read GetItem write SetItem; default;
  end;

function dxCalcTextParams(DC: HDC; AFormat: DWORD; const ALineSpacingFactor: Double = 1.0): TdxTextParams;
function dxCalcTextExtents(DC: HDC; AText: PChar; ATextLength: Integer; AExpandTabs: Boolean): TSize; 
function dxMakeFormat(ATextAlignX: TdxTextAlignX; ATextAlignY: TdxTextAlignY): DWORD;  
function dxMakeTextRows(DC: HDC; const Source: string; const R: TRect; 
  const ATextParams: TdxTextParams): TdxTextRows;
procedure dxPlaceTextRows(DC: HDC; const R: TRect; var ATextParams: TdxTextParams; 
  ATextRows: TdxTextRows; ARowCount: Integer);
function dxPrepareRect(const R: TRect; const ATextParams: TdxTextParams;
  ALeftIndent: Integer = 0; ARightIndent: Integer = 0): TRect;  
procedure dxTextRowsOut(DC: HDC; const R: TRect; const ATextParams: TdxTextParams; 
  ATextRows: TdxTextRows; ARowCount: Integer);
  
function dxTextOut(DC: HDC; S: string; var R: TRect; AFormat: DWORD;
  AFont: TFont = nil; AMaxLineCount: Integer = 0; ALeftIndent: Integer = 0;
  ARightIndent: Integer = 0; ATextColor: TColor = clDefault; // -> current TextColor is used
  const ALineSpacingFactor: Double = 1.0): Integer;

procedure dxRotatedTextOut(DC: HDC; const ABounds: TRect; const AText: string; AFont: TFont;
  AAlignHorz: TdxTextAlignX = taCenterX; AAlignVert: TdxTextAlignY = taCenterY; AWordBreak: Boolean = True;
  ALeftExceed: Boolean = True; ARightExceed: Boolean = True; ADirection: TdxVerticalTextOutDirection = vtdBottomToTop;
  AFontSize: Integer = 0);

const
  dxEndEllipsisChars = '...';
  dxMinVisuallyVisibleTextHeight = 6;
  dxTextSpace = 2;

implementation

uses
  SysUtils, cxClasses, cxControls, cxGraphics, dxPSUtl;

function GetTabbedTextExtent(hDC: HDC; lpString: PChar; nCount, nTabPositions: Integer; 
  lpnTabStopPositions: Pointer): DWORD; stdcall; external user32 name 'GetTabbedTextExtentA';
function TabbedTextOut(hDC: HDC; X, Y: Integer; lpString: PChar; nCount, nTabPositions: Integer;
  lpnTabStopPositions: Pointer; nTabOrigin: Integer): Longint; stdcall; external user32 name 'TabbedTextOutA';

const
  Tab: Char = #9;
  CR: Char = #13;
  LF: Char = #10;
  Space: Char = ' ';

  DXTO_HORZ_ALIGN_MASK   = DXTO_CENTER_HORIZONTALLY or DXTO_RIGHT or DXTO_JUSTIFY_HORIZONTALLY or DXTO_DISTRIBUTE_HORIZONTALLY;
  DXTO_VERT_ALIGN_MASK   = DXTO_CENTER_VERTICALLY or DXTO_BOTTOM or DXTO_DISTRIBUTE_VERTICALLY;
  DXTO_VERT_ALIGN_OFFSET = 4;
  
var
  FillPatterns: array[Boolean] of HBRUSH;

{ TdxTextRow }

procedure TdxTextRow.CalculateExtents(DC: HDC; const ATextParams: TdxTextParams);
begin
  TextExtents := dxCalcTextExtents(DC, Text, CharCount, ATextParams.ExpandTabs);
end;
  
{ TdxTextRows }

function TdxTextRows.CalculateMaxWidth: Integer;
var
  I, V: Integer;
begin
  Result := 0;
  for I := 0 to Count - 1 do
  begin
    V := Items[I].TextExtents.cX;
    if V > Result then Result := V;
  end;  
end;

{$IFNDEF DELPHI5}
procedure TdxTextRows.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do 
    Items[I].Free;
  inherited;
end;
{$ENDIF}

function TdxTextRows.GetItem(Index: Integer): TdxTextRow;
begin
  Result := TdxTextRow(inherited Items[Index]);
end;

procedure TdxTextRows.SetItem(Index: Integer; Value: TdxTextRow);
begin
  inherited Items[Index] := Value;
end;

{ utility routines }  

function CreateTextRow(DC: HDC; var Source: PChar; var ALength: Integer; 
  AWidth: Integer; AIsLastRow: Boolean; const ATextParams: TdxTextParams): TdxTextRow;

  function GetCharAt(P: PChar; ACharIndex: Integer; ACharSize: Integer): Char;
  begin
    Result := P[ACharIndex];
  end;

  function CharIsBreak(Ch: Char): Boolean; overload;
  begin
    Result := (Ch = Space) or (Ch = Tab); //Q99343 don't use ATextParams.BreakChar (bug with Segoe UI)
  end;

  function CharIsBreak(P: PChar; ACharIndex: Integer; ACharSize: Integer): Boolean; overload;
  begin
    Result := CharIsBreak(GetCharAt(P, ACharIndex, ACharSize));
  end;

  procedure IncPChar(var P: PChar; AnOffset: Integer);
  begin
    Inc(P, AnOffset);
  end;

var
  R: TRect;
  TotalTextWidth, BreakPos, CharSize, I: Integer;
  PDBCSSource: PChar;
  BreakByWords, BreakByChars, IsSpecialProcessedRow, HasCRSequence: Boolean;
  Ch: Char;
  Size: TSize;
begin
  Result := TdxTextRow.Create;
  if Source = nil then Exit;
  
  TotalTextWidth := 0;
  BreakPos := -1;
  CharSize := 1; 
  PDBCSSource := Source;
 
  with ATextParams do 
  begin
    BreakByWords := not SingleLine and (WordBreak or (TextAlignX in [taJustifyX, taDistributeX]));
    BreakByChars := BreakByWords and CharBreak;
    IsSpecialProcessedRow := not NoClip and not (TextAlignX in [taJustifyX, taDistributeX]) and AIsLastRow and EndEllipsis;
  end;
  
  with Result do 
  begin
    for I := 0 to ALength - 1 do
    begin
      if SysLocale.FarEast then
      begin
        CharSize := cxStrCharLength(PDBCSSource);
        if StrByteType(Source, I) = mbTrailByte then
          Continue;
        Inc(PDBCSSource, CharSize);
      end;
      CharCount := I + 1  + CharSize - 1 ;
      
      Ch := GetCharAt(Source, I, CharSize);
      
      if CharIsBreak(Ch) then
      begin
        Inc(BreakCount);
        BreakPos := I;
      end;                            

      //todo: DB53862
      if ((Ch = CR) or (Ch = LF)) {and not IsSpecialProcessedRow and not ATextParams.SingleLine} then
      begin
        Dec(CharCount);
        if ATextParams.TextAlignX = taJustifyX then BreakCount := 0;
        Break;
      end;  

      if BreakByWords or IsSpecialProcessedRow or ATextParams.SingleLine then
      begin
        if not ATextParams.ExpandTabs then
        begin
          Windows.GetTextExtentPoint32(DC, @Ch, CharSize, Size);
          Inc(TotalTextWidth, Size.cX);
        end
        else
        begin
          if AWidth > High(Word) then
          begin
            R := NullRect;
            DrawText(DC, Source, CharCount, R,
              DT_SINGLELINE or DT_NOPREFIX or DT_CALCRECT or DT_EXPANDTABS);
            TotalTextWidth := R.Right - R.Left;
          end
          else
            TotalTextWidth := LoWord(GetTabbedTextExtent(DC, Source, CharCount, 0, nil));
        end;

        if TotalTextWidth >= AWidth then
        begin
          if ATextParams.SingleLine or IsSpecialProcessedRow or
            ((TotalTextWidth = AWidth) and ((I = ALength - 1) or CharIsBreak(Source, I + 1, CharSize))) then
            Break
          else
            if (BreakPos <> -1) then//and ((TotalTextWidth > AWidth) or ATextParams.CalcRect) then
            begin
              if not ATextParams.CalcRect then
                CharCount := BreakPos + 1;
              Break;
            end
            else
              if BreakByChars then
              begin
                if (TotalTextWidth > AWidth) and (CharCount > CharSize) then 
                  Dec(CharCount, CharSize);
                Break;
              end;  
        end;
      end;
    end;
    Text := Source;

    // truncate trailing spaces
    if ATextParams.TextAlignX in [taJustifyX, taDistributeX] then
      while (CharCount > 0) and CharIsBreak(Source, CharCount - 1, CharSize) do
      begin
        if BreakCount > 0 then Dec(BreakCount);
        Dec(CharCount,  CharSize );
      end;
  end;

  Result.CalculateExtents(DC, ATextParams);

  HasCRSequence := False;  
  IncPChar(Source,  Result.CharCount);
  Dec(ALength, Result.CharCount);
  I := 0;
  while (I < ALength) and (GetCharAt(Source, I, CharSize) = Space) do //Q99343 don't use ATextParams.BreakChar (bug with Segoe UI)
    Inc(I);
  if I < ALength then
  begin
    if GetCharAt(Source, I, CharSize) = Tab then Inc(I);
    HasCRSequence := GetCharAt(Source, I, CharSize) = CR;
    if GetCharAt(Source, I, CharSize) = CR then Inc(I);
    if GetCharAt(Source, I, CharSize) = LF then Inc(I);
  end;
  IncPChar(Source,  I);
  Dec(ALength, I);
    
  // doesn't justify last row like Excel does?
  if ((ALength = 0) or HasCRSequence) and (ATextParams.TextAlignX = taJustifyX) then
    Result.BreakCount := 0;
end;

function dxCalcTextParams(DC: HDC; AFormat: DWORD; const ALineSpacingFactor: Double = 1.0): TdxTextParams;
var
  TextMetric: TTextMetric;
  R: TRect;
begin
  FillChar(Result, SizeOf(Result), 0);
  GetTextMetrics(DC, TextMetric);
  with Result do 
  begin
    BreakChar := TextMetric.tmBreakChar;
    RowHeight := dxCalcTextExtents(DC, 'Wg', 2, False).cY;
    Bold := TextMetric.tmWeight >= FW_BOLD;
    
    TextAlignX := TdxTextAlignX(AFormat and DXTO_HORZ_ALIGN_MASK);
    TextAlignY := TdxTextAlignY(AFormat and DXTO_VERT_ALIGN_MASK shr DXTO_VERT_ALIGN_OFFSET);

    AutoIndents := AFormat and DXTO_AUTOINDENTS <> 0;
    CalcRect := AFormat and DXTO_CALCRECT <> 0;
    CalcRowCount := AFormat and DXTO_CALCROWCOUNT <> 0;
    CharBreak := (AFormat and DXTO_CHARBREAK <> 0) or SysLocale.FarEast;
    EditControl := AFormat and DXTO_EDITCONTROL <> 0;
    EndEllipsis := AFormat and DXTO_END_ELLIPSIS <> 0;
    ExternalLeading := AFormat and DXTO_EXTERNALLEADING <> 0;
    ExpandTabs := AFormat and DXTO_EXPANDTABS <> 0;
    NoClip := AFormat and DXTO_NOCLIP <> 0;
    PatternedText := AFormat and DXTO_PATTERNEDTEXT <> 0;
    PreventLeftExceed := AFormat and DXTO_PREVENT_LEFT_EXCEED <> 0;
    PreventTopExceed := AFormat and DXTO_PREVENT_TOP_EXCEED <> 0;
    SingleLine := AFormat and DXTO_SINGLELINE <> 0;
    WordBreak := AFormat and DXTO_WORDBREAK <> 0;
    HidePrefix := AFormat and DXTO_HIDEPREFIX <> 0;
    
    R := Rect(0, 0, 1, 1);
    DPtoLP(DC, R, 2);
    OnePixel := R.Right - R.Left;
    
    if ExternalLeading then
      tmExternalLeading := TextMetric.tmExternalLeading;
    FullRowHeight := Round((RowHeight + tmExternalLeading) * ALineSpacingFactor);

    if PatternedText then  
    begin
      R := Rect(0, 0, dxMinVisuallyVisibleTextHeight, dxMinVisuallyVisibleTextHeight);
      DPtoLP(DC, R, 2);
      PatternedText := RowHeight < R.Bottom - R.Top;
    end;
    
    EndEllipsisWidth := dxCalcTextExtents(DC, dxEndEllipsisChars, Length(dxEndEllipsisChars), False).cX;
  end;  
end;

function dxCalcTextExtents(DC: HDC; AText: PChar; ATextLength: Integer;
  AExpandTabs: Boolean): TSize;
var
  R: TRect;
begin
  if AExpandTabs then
  begin
{   //todo: CB41669 textextent.cx can greate then max of LoWord
    V := GetTabbedTextExtent(DC, AText, ATextLength, 0, nil);
    Result.cX := LoWord(V);
    Result.cY := HiWord(V);}
    R := Rect(0, 0, 0, 0);
    DrawText(DC, AText, ATextLength, R, DT_SINGLELINE or DT_NOPREFIX or DT_CALCRECT or DT_EXPANDTABS);
    Result.cx := R.Right - R.Left;
    Result.cy := R.Bottom - R.Right;
  end
  else
    GetTextExtentPoint32(DC, AText, ATextLength, Result);
end;

function dxMakeFormat(ATextAlignX: TdxTextAlignX; ATextAlignY: TdxTextAlignY): DWORD;  
begin
  Result := Byte(ATextAlignX) or (Byte(ATextAlignY) shl DXTO_VERT_ALIGN_OFFSET);
end;

function dxMakeTextRows(DC: HDC; const Source: string; const R: TRect; const ATextParams: TdxTextParams): TdxTextRows;

  function CheckIsLastRow(ATotalHeight, H: Integer): Boolean;
  begin
    with ATextParams do
      if SingleLine then
        Result := True
      else
        if (R.Bottom <> MaxInt) and (TextAlignY = taTop) and not CalcRect then 
        begin
          if (EditControl{ or EndEllipsis}) and not NoClip then
            Result := ATotalHeight + FullRowHeight > H
          else
            Result := ATotalHeight > H
        end    
        else
          Result := False;
  end;

var
  P: PChar;
  TextRow: TdxTextRow;
  IsLastRow: Boolean;
  TotalHeight, L, H, W: Integer;
begin
  if (Source <> '') and (Source[1] <> #0) then
  begin
      P := Pointer(Source);
      Result := TdxTextRows.Create;
      if ATextParams.CalcRect and ATextParams.SingleLine then 
      begin
        TextRow := TdxTextRow.Create;
        TextRow.Text := P;
        TextRow.CharCount := Length(Source);
        TextRow.CalculateExtents(DC, ATextParams); 
        Result.Add(TextRow);
      end
      else
      begin
        IsLastRow := False;
        TotalHeight := 0;
        L := Length(Source);
        W := R.Right - R.Left;
        H := R.Bottom - R.Top;

        while (P^ <> #0) and  not IsLastRow do 
        begin
          Inc(TotalHeight, ATextParams.FullRowHeight);
          IsLastRow := CheckIsLastRow(TotalHeight, H);
          TextRow := CreateTextRow(DC, P, L, W, IsLastRow, ATextParams);
          Result.Add(TextRow);
          if not IsLastRow then IsLastRow := L = 0;
        end;
      end;
  end  
  else
    Result := nil;  
end;  

procedure dxPlaceTextRows(DC: HDC; const R: TRect; var ATextParams: TdxTextParams; 
  ATextRows: TdxTextRows; ARowCount: Integer);
  
  procedure CalcExtraAndTopRowOffset(out AExtra, ATopRowOffset: Integer);
  var
    H: Integer;
  begin
    AExtra := 0;
    with ATextParams do
    begin
      if (ARowCount > 1) and (TextAlignY = taDistributeY) then
      begin
        H := R.Bottom - R.Top;      
        Dec(H, RowHeight);
        if H / (ARowCount - 1) > RowHeight then 
        begin   
          FullRowHeight := H div (ARowCount - 1);
          AExtra := H mod (ARowCount - 1);
        end;
      end;
      
      case TextAlignY of
        taCenterY:
          ATopRowOffset := R.Top + (R.Bottom - R.Top - ARowCount * FullRowHeight) div 2;
        taBottom:  
          ATopRowOffset := R.Bottom - ARowCount * FullRowHeight + tmExternalLeading;
      else  
        ATopRowOffset := R.Top;
      end;  
        
      if PreventTopExceed and (ATopRowOffset < R.Top) then 
        ATopRowOffset := R.Top;
    end;    
  end;

  procedure PlaceRows(AExtra, ATopRowOffset: Integer);
  var
    I: Integer;
  begin  
    for I := 0 to ARowCount - 1 do
      with ATextRows[I] do 
      begin
        // Horizontally
        case ATextParams.TextAlignX of
          taCenterX:
            TextOriginX := R.Left + (R.Right - R.Left - TextExtents.cX) div 2;
          taRight:
            TextOriginX := R.Right - TextExtents.cX;
        else  
          TextOriginX := R.Left;
        end;    
        if ATextParams.PreventLeftExceed and (TextOriginX < R.Left) then
          TextOriginX := R.Left;

        // Vertically
        TextOriginY := ATopRowOffset;
        Inc(ATopRowOffset, ATextParams.FullRowHeight);
        if AExtra > 0 then 
        begin
          Inc(ATopRowOffset);
          Dec(AExtra);
        end;  
      end;
  end;

var
  Extra, TopRowOffset: Integer;
begin
  CalcExtraAndTopRowOffset(Extra, TopRowOffset);
  PlaceRows(Extra, TopRowOffset);
end;

function dxPrepareRect(const R: TRect; const ATextParams: TdxTextParams;
  ALeftIndent, ARightIndent: Integer): TRect;
begin
  Result := R;
  with Result, ATextParams do
  begin
    if AutoIndents then
      InflateRect(Result, -dxTextSpace * OnePixel, -dxTextSpace * OnePixel);
    Inc(Left, ALeftIndent * OnePixel);
    Dec(Right, ARightIndent * OnePixel);
  end;
end;

function dxUnprepareRect(const R: TRect; const ATextParams: TdxTextParams;
  ALeftIndent: Integer = 0; ARightIndent: Integer = 0): TRect;
begin
  Result := R;
  with Result, ATextParams do
  begin
    Dec(Left, ALeftIndent * OnePixel);
    Inc(Right, ARightIndent * OnePixel);
    if AutoIndents then
      InflateRect(Result, dxTextSpace * OnePixel, dxTextSpace * OnePixel);
  end;
end;

procedure dxTextRowsOut(DC: HDC; const R: TRect; const ATextParams: TdxTextParams; 
  ATextRows: TdxTextRows; ARowCount: Integer);

  procedure OutTextRowAsPattern(const ATextRow: TdxTextRow; R: TRect);
  var
    BkColor: COLORREF;
  begin
    InflateRect(R, 0, -ATextParams.OnePixel);
    with R do 
    begin
      if Bottom <= Top then 
        Bottom := Top + ATextParams.OnePixel;
      Left := ATextRow.TextOriginX;
      if Right > Left + ATextRow.TextExtents.cX then
        Right := Left + ATextRow.TextExtents.cX;
    end;
    
    BkColor := SetBkColor(DC, ColorToRGB(clWindow));
    FillRect(DC, R, FillPatterns[ATextParams.Bold]);
    SetBkColor(DC, BkColor);    
  end;

  procedure OutTextRow(const ATextRow: TdxTextRow);
  begin
    with ATextRow do 
      if ATextParams.ExpandTabs then
        TabbedTextOut(DC, TextOriginX, TextOriginY, Text, CharCount, 0, nil, 0)
      else
        ExtTextOut(DC, TextOriginX, TextOriginY, 0, nil, Text, CharCount, nil);
  end;

  procedure PrepareEndEllipsis(var ATextRow: TdxTextRow; var AWidth: Integer);
  var
    CharNumber: Integer;
    Size: TSize;
  begin
    Dec(AWidth, ATextParams.EndEllipsisWidth);
    if AWidth < 0 then AWidth := 0;
    with ATextRow do 
    begin
      GetTextExtentExPoint(DC, Text, CharCount, AWidth, @CharNumber, nil, Size);
      if CharNumber = 0 then Inc(CharNumber);
      CharCount := CharNumber;
    end;  
    ATextRow.CalculateExtents(DC, ATextParams);
  end;  
  
  procedure OutEndEllipsis(const ATextRow: TdxTextRow; var ARowRect: TRect);
  var
    fuOptions: UINT;
  begin
    Inc(ARowRect.Left, ATextRow.TextExtents.cX);
    if ARowRect.Left < ARowRect.Right then
    begin
      fuOptions := 0;
      if not ATextParams.NoClip and (ARowRect.Left + ATextParams.EndEllipsisWidth > ARowRect.Right) then 
        fuOptions := ETO_CLIPPED;
      ExtTextOut(DC, ARowRect.Left, ATextRow.TextOriginY, fuOptions, @ARowRect, 
        dxEndEllipsisChars, Length(dxEndEllipsisChars), nil);
    end;  
  end;
  
  function IntersectClipRect(const R: TRect): HRGN;
  begin
    Result := CreateRectRgn(0, 0, 0, 0);
    if GetClipRgn(DC, Result) = -1 then
    begin
      DeleteObject(Result);
      Result := 0;
    end;
    with R do
      Windows.IntersectClipRect(DC, Left, Top, Right, Bottom);
  end;

  procedure RestoreClipRgn(var ARgn: HRGN);
  begin
    SelectClipRgn(DC, ARgn);
    if ARgn <> 0 then
    begin
      DeleteObject(ARgn);
      ARgn := 0
    end;
  end;

var
  RowRect: TRect;
  W, I, BreakExtra, PrevBkMode: Integer;
  NeedClipping, NeedEndEllipsis: Boolean;
  TextRow: TdxTextRow;
  AClipRgn: HRGN;
  AIsMetaFile: Boolean;
begin
  W := R.Right - R.Left;
  RowRect := R;
  AIsMetaFile := IsMetaFileDC(DC);
  AClipRgn := 0;
  PrevBkMode := SetBkMode(DC, Windows.TRANSPARENT);
  for I := 0 to ARowCount - 1 do
  begin
    TextRow := ATextRows[I];
    with TextRow, ATextParams do
    begin
      if CharCount <> 0 then
      begin
        RowRect.Top := TextOriginY;
        RowRect.Bottom := RowRect.Top + FullRowHeight;
        if RectVisible(DC, RowRect) then
        begin
          if PatternedText then
            OutTextRowAsPattern(TextRow, RowRect)
          else
          begin
            NeedEndEllipsis := EndEllipsis and (TextExtents.cX > W) and (I = ARowCount - 1);

            BreakExtra := 0;
            if (TextAlignX in [taJustifyX, taDistributeX]) and not NeedEndEllipsis then
            begin
              BreakExtra := W - TextExtents.cX;
              if (BreakCount <> 0) and (BreakExtra > 0) then
                SetTextJustification(DC, BreakExtra, BreakCount);
            end;

            NeedClipping := not NoClip and ((TextExtents.cX > W) or (RowRect.Top < R.Top) or (RowRect.Bottom > R.Bottom));

            if NeedClipping then
            begin
              if RowRect.Top < R.Top then RowRect.Top := R.Top;
              if RowRect.Bottom > R.Bottom then RowRect.Bottom := R.Bottom;
              if not AIsMetaFile then
                AClipRgn := IntersectClipRect(RowRect);
            end;

            if NeedEndEllipsis then PrepareEndEllipsis(TextRow, W);
            OutTextRow(TextRow);
            if NeedEndEllipsis then OutEndEllipsis(TextRow, RowRect);

            if NeedClipping and not AIsMetaFile then
              RestoreClipRgn(AClipRgn);

            if BreakExtra > 0 then SetTextJustification(DC, 0, 0);
          end;
        end;
      end;
    end;
  end;
  SetBkMode(DC, PrevBkMode);
end;

function dxTextOut(DC: HDC; S: string; var R: TRect; AFormat: DWORD;
  AFont: TFont = nil; AMaxLineCount: Integer = 0; ALeftIndent: Integer = 0; 
  ARightIndent: Integer = 0; ATextColor: TColor = clDefault;
  const ALineSpacingFactor: Double = 1.0): Integer;  

  function ProcessText(const ATextParams: TdxTextParams; const ATextRect: TRect): Boolean;
  begin
    if ATextParams.CalcRect then
      Result := (ATextRect.Right - ATextRect.Left) > 0
    else
      Result := not IsRectEmpty(ATextRect);
  end;

var
  PrevFont: HFONT;
  PrevFontColor: COLORREF;
  TextHeight: Integer;
  TextParams: TdxTextParams;
  TextRect: TRect;
  TextRows: TdxTextRows;
  RowCount: Integer;
begin
  PrevFont := GetCurrentObject(DC, OBJ_FONT);
  PrevFontColor := GetTextColor(DC);  
  if AFont <> nil then
  begin
    PrevFont := SelectObject(DC, AFont.Handle);
    SetTextColor(DC, ColorToRGB(AFont.Color));
  end;
  if ATextColor <> clDefault then 
    SetTextColor(DC, ColorToRGB(ATextColor));

  TextParams := dxCalcTextParams(DC, AFormat, ALineSpacingFactor);
  TextRect := dxPrepareRect(R, TextParams, ALeftIndent, ARightIndent);

  TextHeight := 0;
  RowCount := 0;
  if ProcessText(TextParams, TextRect) then
  begin
    if TextParams.HidePrefix then S := RemoveAccelChars(S, False);

    TextRows := dxMakeTextRows(DC, S, TextRect, TextParams);
    if TextRows <> nil then
    try
      RowCount := TextRows.Count;
      if TextParams.CalcRect then    
      begin
        TextRect.Right := TextRect.Left + TextRows.CalculateMaxWidth;
        if not TextParams.SingleLine then 
        begin
          TextRows.Free;
          TextRows := dxMakeTextRows(DC, S, TextRect, TextParams);
          RowCount := TextRows.Count;
        end;  
        dxPlaceTextRows(DC, TextRect, TextParams, TextRows, RowCount);
        TextRect.Bottom := TextRect.Top + TextRows[RowCount - 1].TextOriginY + TextParams.RowHeight;
        R := dxUnprepareRect(TextRect, TextParams, ALeftIndent, ARightIndent);
      end
      else  
      begin
        if (AMaxLineCount > 0) and (RowCount > AMaxLineCount) then
          RowCount := AMaxLineCount;
        dxPlaceTextRows(DC, TextRect, TextParams, TextRows, RowCount);
        dxTextRowsOut(DC, TextRect, TextParams, TextRows, RowCount);
      end;
      TextHeight := TextRows[RowCount - 1].TextOriginY + TextParams.RowHeight - TextRect.Top;
    finally
      TextRows.Free;
    end;
  end;

  if TextParams.CalcRowCount or (TextHeight = 0) then 
    Result := RowCount
  else  
    Result := TextHeight;
    
  SelectObject(DC, PrevFont);
  SetTextColor(DC, PrevFontColor);
end;

procedure CreateFillPatterns;
const
  BoldPatternBits: array[0..7] of Word = ($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000);
  StandardPatternBits: array[0..7] of Word = ($5555, $AAAA, $5555, $AAAA, $5555, $AAAA, $5555, $AAAA);

  function AllocPBits(AnIsBold: Boolean):  Pointer ;
  begin
    if AnIsBold then
      Result := @BoldPatternBits
    else  
      Result := @StandardPatternBits;
  end;

  procedure FreePBits(var APBits:  Pointer );
  begin
  end;

  function CreateFillPattern(AnIsBold: Boolean): HBRUSH;
  var
    PBits:  Pointer ;
    Bitmap: HBITMAP;
  begin
    PBits := AllocPBits(AnIsBold);
    try
      Bitmap := CreateBitmap(8, 8, 1, 1, PBits);
      try
        Result := CreatePatternBrush(Bitmap);
      finally
        DeleteObject(Bitmap);
      end;
    finally
      FreePBits(PBits);
    end;    
  end;
  
begin
  FillPatterns[False] := CreateFillPattern(False);
  FillPatterns[True] := CreateFillPattern(True);
end;

procedure DestroyFillPatterns;
begin
  if FillPatterns[False] <> 0 then DeleteObject(FillPatterns[False]);
  if FillPatterns[True] <> 0 then DeleteObject(FillPatterns[True]);
end;

procedure dxRotatedTextOut(DC: HDC; const ABounds: TRect; const AText: string; AFont: TFont;
  AAlignHorz: TdxTextAlignX = taCenterX; AAlignVert: TdxTextAlignY = taCenterY; AWordBreak: Boolean = True;
  ALeftExceed: Boolean = True; ARightExceed: Boolean = True; ADirection: TdxVerticalTextOutDirection = vtdBottomToTop;
  AFontSize: Integer = 0);

const
  Angles: array[TdxVerticalTextOutDirection] of Integer = (-900, 900);
  Flags: array[TdxVerticalTextOutDirection] of Integer =
    (TA_LEFT or TA_BOTTOM or TA_NOUPDATECP, TA_LEFT or TA_TOP or TA_NOUPDATECP);

  procedure AddRow(AList: TList; AFirstChar: PChar; ACount, AWidth: Integer);
  begin
    AList.Add(AFirstChar);
    AList.Add(Pointer(ACount));
    AList.Add(Pointer(AWidth));
  end;

  function CreateRotatedFont: HFONT;
  var
    ALogFont: TLogFont;
  begin
    FillChar(ALogFont, SizeOf(ALogFont), 0);
    cxGetFontData(AFont.Handle, ALogFont);
    if AFontSize <> 0 then
      ALogFont.lfHeight := -MulDiv(AFontSize, GetDeviceCaps(DC, LOGPIXELSY), 72);
    ALogFont.lfEscapement := Angles[ADirection];
    ALogFont.lfOutPrecision := OUT_TT_ONLY_PRECIS;
    Result := CreateFontIndirect(ALogFont);
  end;

  function TextSize(ACurrentChar: PChar; ACharCount: Integer): TSize;
  begin
    GetTextExtentPoint32(DC, ACurrentChar, ACharCount, Result);
  end;

  function GetNextChar(AFirstChar: PChar; ALen: Integer = 1): PChar;
  begin
    Result := AFirstChar;
    while ALen > 0 do
    begin
      if Result^ in LeadBytes then
        Inc(Integer(Result));
      Inc(Integer(Result));
      Dec(ALen);
    end;
  end;

  function TextWidth(const AFirstChar: PChar; ACharCount: Integer): Integer;
  var
    ASize: TSize;
  begin
    GetTextExtentPoint32(DC, AFirstChar, ACharCount, ASize);
    Result := ASize.cx;
  end;

  function MakeRow(var AFirstChar: PChar; ALastChar: PChar;
    ACharCount, ARowCharCount: Integer; ATextRows: TList): Integer;
  begin
    // make break and move first point to current point
    AddRow(ATextRows, AFirstChar, ARowCharCount, TextWidth(AFirstChar, ARowCharCount));
    if ALastChar^ = ' ' then
    begin
      Dec(ACharCount);
      ALastChar := GetNextChar(ALastChar);
    end;
    AFirstChar := ALastChar;
    Result := ACharCount - ARowCharCount;
  end;

  procedure CalculateWordWrappedTextRows(AFirstChar: PChar;
    ACharCount, ATextWidth: Integer; ATextRows: TList);
  var
    ACurrentChar, APrevBreakChar: PChar;
    AIsBreakChar, AHasPrevBreak: Boolean;
    APos, APrevBreakPos, AWidth: Integer;
  begin
    while ACharCount > 0 do
    begin
      ACurrentChar := AFirstChar;
      APos := 0;
      AHasPrevBreak := False;
      AWidth := 0;
      APrevBreakPos := 0;
      APrevBreakChar := ' ';
      while APos < ACharCount do
      begin
        ACurrentChar := GetNextChar(ACurrentChar);
        Inc(APos);
        AIsBreakChar := (ACurrentChar^ = Space) or (ACurrentChar^ = #13) or (ACurrentChar^ = #10);
        if AIsBreakChar or (APos = ACharCount) then
        begin
          AWidth := TextWidth(AFirstChar, APos);
          if AWidth < ATextWidth then
          begin
            AHasPrevBreak := AIsBreakChar;
            APrevBreakPos := APos;
            APrevBreakChar := ACurrentChar;
          end;
        end;
        if (AIsBreakChar and ((AWidth > ATextWidth) or (ACurrentChar^ in [#13, #10]))) or (APos = ACharCount) then
        begin
          if AHasPrevBreak and (AWidth > ATextWidth) then
          begin
            APos := APrevBreakPos;
            ACurrentChar := APrevBreakChar;
          end;
          ACharCount := MakeRow(AFirstChar, ACurrentChar, ACharCount, APos, ATextRows);
          Break;
        end;
      end;
    end;
  end;

  function ProcessHorizontalAlignemnt(const ATextBounds: TRect;
    AWidth: Integer): Integer;
  var
    ARightPos, ALeftPos: Integer;
  begin
    if ADirection = vtdBottomToTop then
    begin
      ARightPos := ATextBounds.Top + AWidth;
      ALeftPos := ATextBounds.Bottom;
    end
    else
    begin
      ALeftPos := ATextBounds.Top;
      ARightPos := ATextBounds.Bottom - AWidth;
    end;
    if AAlignHorz = taLeft then
      Result := ALeftPos
    else
      if AAlignHorz = taRight then
        Result := ARightPos
      else
      begin
        if ADirection = vtdBottomToTop then
          Result := (ATextBounds.Top + ATextBounds.Bottom + AWidth) div 2
        else
          Result := (ATextBounds.Top + ATextBounds.Bottom - AWidth) div 2
      end;
    if AWidth > (ATextBounds.Bottom - ATextBounds.Top) then
    begin
      if ARightExceed then
        Result := ARightPos
      else
        if ALeftExceed then
          Result := ALeftPos;
    end;
  end;                                                                            

  function ProcessVerticalAlignemnt(const ATextBounds: TRect;
    ARowHeight, ARowCount: Integer): Integer;
  begin
    if ADirection = vtdBottomToTop then
    begin
      // align by horizontally
      if AAlignVert = taBottom then
      begin
        Result := ATextBounds.Right - ARowHeight * ARowCount;
        if Result < ATextBounds.Left then
          Result := ATextBounds.Left;
      end
      else
        if AAlignVert = taCenterY then
          Result := (ATextBounds.Left + ATextBounds.Right - ARowHeight * ARowCount) div 2
        else
          Result := ATextBounds.Left;
      if Result < ATextBounds.Left then
        Result := ATextBounds.Left;
    end
    else
    begin
      if AAlignVert = taTop then
        Result := ATextBounds.Right - ARowHeight
      else
        if AAlignVert = taCenterY then
          Result := (ATextBounds.Left - ARowHeight + ATextBounds.Right + ARowHeight * (ARowCount - 1)) div 2
        else
          Result := ATextBounds.Left + ARowHeight * (ARowCount - 1);
      if Result > (ATextBounds.Right - ARowHeight) then
        Result := ATextBounds.Right - ARowHeight;
    end;
  end;

  procedure PlaceTextRows(ATextRows: TList; ATextBounds: TRect);
  var
    ASize: TSize;
    I, ALeft, ATop, ARowCount, AWidth: Integer;
  begin
    GetTextExtentPoint32(DC, 'Wg', 2, ASize);
    ARowCount := ATextRows.Count div 3;
    ALeft := ProcessVerticalAlignemnt(ATextBounds, ASize.cy, ARowCount);
    for I := 0 to ARowCount - 1 do
    begin
     // align by vertically
      AWidth := Integer(ATextRows.List^[I * 3 + 2]);
      ATop := ProcessHorizontalAlignemnt(ATextBounds, AWidth);
      // out text row
      ExtTextOut(DC, ALeft, ATop, 0{ETO_CLIPPED}, @ATextBounds,
        PChar(ATextRows.List^[I * 3]), Integer(ATextRows.List^[I * 3 + 1]), nil);
      // offset place and check visibility
      if ADirection = vtdBottomToTop then
        Inc(ALeft, ASize.cy)
      else
        Dec(ALeft, ASize.cy);
      if (ALeft < ATextBounds.Left) or (ALeft > ATextBounds.Right) then
        Break;
    end;
  end;

var
//  ASize: TSize;
  ATextRows: TList;
  AFontHandle: HFONT;
  ATextBounds: TRect;
  ACharCount, AMode, AWidth: Integer;
begin
  ACharCount := Length(AText);
  if ACharCount = 0 then Exit;
  ATextBounds := ABounds;
  InflateRect(ATextBounds, -2, -2);
  AWidth := ATextBounds.Bottom - ATextBounds.Top;
  AFontHandle := SelectObject(DC, CreateRotatedFont);
  AMode := SetBkMode(DC, Windows.TRANSPARENT);
  ATextRows := TList.Create;
  try
    ATextRows.Capacity := Length(AText) * 3;
    SetTextAlign(DC, Flags[ADirection]);
    if not AWordBreak then
      AddRow(ATextRows, @AText[1], ACharCount, TextWidth(@AText[1], ACharCount))
    else
      CalculateWordWrappedTextRows(@AText[1], ACharCount, AWidth, ATextRows);
    PlaceTextRows(ATextRows, ATextBounds);
  finally
    SetBkMode(DC, AMode);
    AFontHandle := SelectObject(DC, AFontHandle);
    DeleteObject(AFontHandle);
    ATextRows.Free;
  end;
end;   

initialization
  CreateFillPatterns;
  
finalization
  DestroyFillPatterns;

end.