frxgraphicutils.pas

Fastreport最新版本的补丁

            FStyle := FStyle - [fsStrikeOut];
            System.Delete(s, i, 9);
            Inc(FPosition, 9);
            continue;
          end
          else if Pos('FONT>', AnsiUpperCase(s)) = i + 2 then
          begin
            FColor := FDefColor;
            System.Delete(s, i, 7);
            Inc(FPosition, 7);
            continue;
          end
          else if (Pos('SUB>', AnsiUpperCase(s)) = i + 2) or
            (Pos('SUP>', AnsiUpperCase(s)) = i + 2) then
          begin
            FSize := FDefSize;
            FAddY := 0;
            System.Delete(s, i, 6);
            Inc(FPosition, 6);
            continue;
          end
        end

  // <font color = ...> tag
        else if Pos('FONT COLOR', AnsiUpperCase(s)) = i + 1 then
        begin
          j := i + 11;
          while (j <= Length(s)) and (s[j] <> '=') do
            Inc(j);
          Inc(j);
          while (j <= Length(s)) and (s[j] = ' ') do
            Inc(j);
          j1 := j;
          while (j <= Length(s)) and (s[j] <> '>') do
            Inc(j);

          cl := Copy(s, j1, j - j1);
          if cl <> '' then
          begin
            if (Length(cl) > 3) and (cl[1] = '"') and (cl[2] = '#') and
              (cl[Length(cl)] = '"') then
            begin
              cl := '$' + Copy(cl, 3, Length(cl) - 3);
              FColor := StrToInt(cl);
              FColor := (FColor and $00FF0000) div 65536 +
                        (FColor and $000000FF) * 65536 +
                        (FColor and $0000FF00);
              System.Delete(s, i, j - i + 1);
              Inc(FPosition, j - i + 1);
              continue;
            end
            else if IdentToColor('cl' + cl, FColor) then
            begin
              System.Delete(s, i, j - i + 1);
              Inc(FPosition, j - i + 1);
              continue;
            end;
          end;
        end
      end;

    AddTag;
    Inc(i);
    Inc(FPosition);
  end;

  if Length(s) = 0 then
  begin
    AddTag;
    s := ' ';
  end;
end;

function TfrxHTMLTagsList.FillCharSpacingArray(var ar: PIntArray; const s: WideString;
  Canvas: TCanvas; LineIndex, Add: Integer; Convert: Boolean): Integer;
var
  i, n: Integer;
  Tags: TfrxHTMLTags;
  Tag: TfrxHTMLTag;

  procedure BreakArray;
  var
    i, j, offs: Integer;
    Size: TSize;
    ansis: String;
  begin
    if (Win32Platform <> VER_PLATFORM_WIN32_NT) or (Canvas.Font.Charset <> DEFAULT_CHARSET) then
    begin
      ansis := s;
      GetTextExtentExPoint(Canvas.Handle, PChar(ansis), n, 0, nil,
        @FTempArray[0], Size);
    end
    else
      GetTextExtentExPointW(Canvas.Handle, PWideChar(s), n, 0, nil,
        @FTempArray[0], Size);
    i := 0;
    repeat
      if FTempArray[i] = 32767 then
      begin
        offs := FTempArray[i - 1];
        if (Win32Platform <> VER_PLATFORM_WIN32_NT) or (Canvas.Font.Charset <> DEFAULT_CHARSET) then
        begin
          ansis := s;
          GetTextExtentExPoint(Canvas.Handle, PChar(ansis) + i, n - i, 0, nil,
            @FTempArray[i], Size);
        end
        else
          GetTextExtentExPointW(Canvas.Handle, PWideChar(s) + i, n - i, 0, nil,
            @FTempArray[i], Size);
        for j := i to n - 1 do
          if FTempArray[j] = 32767 then
          begin
            i := j - 1;
            break;
          end
          else
            FTempArray[j] := FTempArray[j] + offs;
      end;
      Inc(i);
    until i >= n;
  end;

begin
  Result := 0;
  n := Length(s);

  Tags := Items[LineIndex];
  Tag := Tags.Items[0];
  if not Tag.Default then
    Canvas.Font.Style := Tag.Style;

  BreakArray;

  for i := 0 to n - 1 do
  begin
    Tag := Tags.Items[i];
    if (i <> 0) and not Tag.Default then
    begin
      Canvas.Font.Style := Tag.Style;
      BreakArray;
    end;

    if i > 0 then
      Ar[i] := FTempArray[i] - FTempArray[i - 1] + Add else
      Ar[i] := FTempArray[i] + Add;
    if Tag.Small then
      Ar[i] := Round(Ar[i] / 1.5);
    Inc(Result, Ar[i]);
    if Convert and (i > 0) then
      Inc(Ar[i], Ar[i - 1]);
  end;
end;


{ TfrxDrawText }

constructor TfrxDrawText.Create;
begin
  FBMP := TBitmap.Create;
  FCanvas := FBMP.Canvas;
  FDefPPI := 600;
  FScrPpi := 96;
  FHTMLTags := TfrxHTMLTagsList.Create;
  FText := TWideStrings.Create;
  FWysiwyg := True;
  GetMem(FTempArray, SizeOf(Integer) * 32768);
end;

destructor TfrxDrawText.Destroy;
begin
  FBMP.Free;
  FHTMLTags.Free;
  FText.Free;
  FreeMem(FTempArray, SizeOf(Integer) * 32768);
  inherited;
end;

procedure TfrxDrawText.SetFont(Font: TFont);
var
  h: Integer;
begin
  FFontSize := Font.Size;
  h := -Round(FFontSize * FDefPPI / 72);  // height is as in the 600 dpi printer
  FCanvas.Lock;
  try
    with FCanvas.Font do
    begin
      if Name <> Font.Name then
        Name := Font.Name;
      if Height <> h then
        Height := h;
      if Style <> Font.Style then
        Style := Font.Style;
      if Charset <> Font.Charset then
        Charset := DEFAULT_CHARSET;
      if Color <> Font.Color then
        Color := Font.Color;
    end;
  finally
    FCanvas.Unlock;
  end;
end;

procedure TfrxDrawText.SetOptions(WordWrap, HTMLTags, RTLReading,
  WordBreak, Clipped, Wysiwyg: Boolean; Rotation: Integer);
begin
  FWordWrap := WordWrap;
  FHTMLTags.AllowTags := HTMLTags;
  FRTLReading := RTLReading;
  FOptions := 0;
  if RTLReading then
    FOptions := ETO_RTLREADING;
  if Clipped then
    FOptions := FOptions or ETO_CLIPPED;
  FWordBreak := WordBreak;
  FRotation := Rotation mod 360;
  FWysiwyg := Wysiwyg;
end;

procedure TfrxDrawText.SetDimensions(ScaleX, ScaleY, PrintScale: Extended;
  OriginalRect, ScaledRect: TRect);
begin
  FScaleX := ScaleX;
  FScaleY := ScaleY;
  FPrintScale := PrintScale;
  FOriginalRect := OriginalRect;
  FScaledRect := ScaledRect;
end;

procedure TfrxDrawText.SetGaps(ParagraphGap, CharSpacing, LineSpacing: Extended);
begin
  FParagraphGap := ParagraphGap;
  FCharSpacing := CharSpacing;
  FLineSpacing := LineSpacing;
end;

procedure TfrxDrawText.SetText(Text: TWideStrings);
var
  i, j, n, Width: Integer;
  s: WideString;
  Style: TFontStyles;
  FPPI: Extended;
begin
  FCanvas.Lock;
  try
    FPlainText := '';
    FText.Clear;
  finally
    FCanvas.Unlock;
  end;

  n := Text.Count;
  if n = 0 then Exit;

  FCanvas.Lock;
  try
  // set up html engine
    FHTMLTags.SetDefaults(FCanvas.Font.Color, FFontSize, FCanvas.Font.Style);
    Style := FCanvas.Font.Style;

  // width of the wrap area
    Width := FOriginalRect.Right - FOriginalRect.Left;
    if ((FRotation >= 90) and (FRotation < 180)) or
       ((FRotation >= 270) and (FRotation < 360)) then
      Width := FOriginalRect.Bottom - FOriginalRect.Top;

    for i := 0 to n - 1 do
    begin
      j := FText.Count;
      s := Text[i];
      if s = '' then
        s := ' ';
      FPlainText := FPlainText + s + #13#10;
      FPPI := FDefPPI / FScrPPI;
      WrapTextLine(s,
        Round(Width * FPPI),
        Round((Width - FParagraphGap) * FPPI),
        Round(FCharSpacing * FPPI));
      if FText.Count <> j then
      begin
        FText.Objects[j] := Pointer(1);                 // mark the begin of paragraph:
        if FText.Count - 1 = j then                     // it will be needed in DrawText
          FText.Objects[j] := Pointer(3) else           // both begin and end at one line
          FText.Objects[FText.Count - 1] := Pointer(2); // mark the end of paragraph
      end;
    end;

    FCanvas.Font.Style := Style;
  finally
    FCanvas.Unlock;
  end;
end;

procedure TfrxDrawText.SetParaBreaks(FirstParaBreak, LastParaBreak: Boolean);
begin
  if FText.Count = 0 then Exit;

  if FirstParaBreak then
    FText.Objects[0] := Pointer(Integer(FText.Objects[0]) and not 1);
  if LastParaBreak then
    FText.Objects[FText.Count - 1] := Pointer(Integer(FText.Objects[FText.Count - 1]) and not 2);
end;

function TfrxDrawText.DeleteTags(const Txt: WideString): WideString;
begin
  Result := Txt;
  FHTMLTags.ExpandHTMLTags(Result);
end;

procedure TfrxDrawText.WrapTextLine(s: WideString;
  Width, FirstLineWidth, CharSpacing: Integer);
var
  n, i, Offset, LineBegin, LastSpace, BreakPos: Integer;
  sz: TSize;
  TheWord: WideString;
  WasBreak: Boolean;

  function BreakWord(const s: WideString; LineBegin, CurPos, LineEnd: Integer): WideString;
  var
    i, BreakPos: Integer;
    TheWord, Breaks: WideString;
  begin
    // get the whole word
    i := CurPos;
    while (i <= LineEnd) and (Pos(s[i], ' .,-;') = 0) do
      Inc(i);
    TheWord := Copy(s, LineBegin, i - LineBegin);
    // get available break positions
    Breaks := BreakRussianWord(AnsiUpperCase(TheWord));
    // find the closest position
    BreakPos := CurPos - LineBegin;
    for i := Length(Breaks) downto 1 do
      if Ord(Breaks[i]) < BreakPos then
      begin
        BreakPos := Ord(Breaks[i]);
        break;
      end;
    if BreakPos <> CurPos - LineBegin then
      Result := Copy(TheWord, 1, BreakPos) else
      Result := '';
  end;

begin
// remove all HTML tags and build the tag list
  FHTMLTags.NewLine;
  FHTMLTags.ExpandHTMLTags(s);
  FHTMLTags.FPosition := FHTMLTags.FPosition + 2;

  n := Length(s);
  if (n < 2) or not FWordWrap then  // no need to wrap a string with 0 or 1 symbol
  begin
    FText.Add(s);
    Exit;
  end;

// get the intercharacter spacing table and calculate the width
  FCanvas.Lock;
  try
    sz.cx := FHTMLTags.FillCharSpacingArray(FTempArray, s, FCanvas,
      FHTMLTags.Count - 1, CharSpacing, True);
  finally
    FCanvas.Unlock;
  end;

// text fits, no need to wrap it
  if sz.cx < FirstLineWidth then
  begin
    FText.Add(s);
    Exit;
  end;

  Offset := 0;
  i := 1;
  LineBegin := 1; // index of the first symbol in the current line
  LastSpace := 1; // index of the last space symbol in the current line

  while i <= n do
  begin
    if s[i] = ' ' then
      LastSpace := i;

    if FTempArray[i - 1] - Offset > FirstLineWidth then  // need wrap
    begin
      if LastSpace = LineBegin then  // there is only one word without spaces...
      begin
        if i <> LineBegin then       // ... and it has more than 1 symbol
        begin
          if FWordBreak then
          begin
            TheWord := BreakWord(s, LineBegin, i, n);
            WasBreak := TheWord <> '';
            if not WasBreak then
              TheWord := Copy(s, LineBegin, i - LineBegin);
            if WasBreak then
              FText.Add(TheWord + '-') else
              FText.Add(TheWord);
            BreakPos := Length(TheWord);
            FHTMLTags.Wrap(BreakPos, WasBreak);
            LastSpace := LineBegin + BreakPos - 1;
          end
          else
          begin
            FText.Add(Copy(s, LineBegin, i - LineBegin));
            FHTMLTags.Wrap(i - LineBegin, False);
            LastSpace := i - 1;
          end;
        end
        else
        begin
          FText.Add(s[LineBegin]); // can't wrap 1 symbol, just add it to the new line
          FHTMLTags.Wrap(1, False);
        end;
      end
      else // we have a space symbol inside
      begin
        if FWordBreak then
        begin
          TheWord := BreakWord(s, LastSpace + 1, i, n);
          WasBreak := TheWord <> '';
          if WasBreak then
            FText.Add(Copy(s, LineBegin, LastSpace - LineBegin + 1) + TheWord + '-') else
            FText.Add(Copy(s, LineBegin, LastSpace - LineBegin));
          BreakPos := LastSpace - LineBegin + Length(TheWord) + 1;
          FHTMLTags.Wrap(BreakPos, WasBreak);
          if WasBreak then
            LastSpace := LineBegin + BreakPos - 1;
        end
        else
        begin
          FText.Add(Copy(s, LineBegin, LastSpace - LineBegin));
          FHTMLTags.Wrap(LastSpace - LineBegin + 1, False);
        end;
      end;

      Offset := FTempArray[LastSpace - 1]; // starting a new line
      i := LastSpace;
      Inc(LastSpace);
      LineBegin := LastSpace;
      FirstLineWidth := Width; // this line is not first, so use Width
    end;

    Inc(i);
  end;

  if n - LineBegin + 1 > 0 then   // put the rest of line to FText
    FText.Add(Copy(s, LineBegin, n - LineBegin + 1));
end;

procedure TfrxDrawText.DrawTextLine(C: TCanvas; const s: WideString;
  X, Y, DX, LineIndex: Integer; Align: TfrxHAlign; var fh, oldfh: HFont);
var
  spaceAr: PIntArray;
  n, i, j, cw, neededSize, extraSize, spaceCount: Integer;
  add1, add2, add3, addCount: Integer;
  ratio: Extended;
  Sz, prnSz, PPI: Integer;
  Tag: TfrxHTMLTag;
  CosA, SinA: Extended;
  Style: TFontStyles;
  FPPI: Extended;

  function CountSpaces: Integer;
  var
    i: Integer;
  begin
    Result := 0;
    for i := 0 to n - 1 do
    begin
      spaceAr[i] := 0;
      if (s[i + 1] = ' ') or (s[i + 1] = #$A0) then
      begin
        Inc(Result);
        spaceAr[i] := 1;
      end;
    end;
  end;

  function CalcWidth(Index, Count: Integer): Integer;
  var
    i: Integer;
  begin
    Result := 0;
    for i := Index to Index + Count - 1 do
      Result := Result + FTempArray[i];
  end;

begin
  n := Length(s);
  if n = 0 then Exit;

  spaceAr := nil;
  FCanvas.Lock;

  try
    Style := C.Font.Style;
    FHTMLTags.FDefStyle := Style;
    FCanvas.Font.Style := Style;
    FPPI := FDefPPI / FScrPPI;

    PrnSz := FHTMLTags.FillCharSpacingArray(FTempArray, s, FCanvas, LineIndex,
      Round(FCharSpacing * FPPI), False) - Round(FCharSpacing * FPPI);
    Sz := FHTMLTags.FillCharSpacingArray(FTempArray, s, C, LineIndex,
      Round(FCharSpacing * FScaleX), False) - Round(FCharSpacing * FScaleX);                      //!Den

    C.Font.Style := Style;
    if FHTMLTags.AllowTags and (FRotation <> 0) then
    begin
      SelectObject(C.Handle, oldfh);
      DeleteObject(fh);
      fh := CreateRotatedFont(C.Font, FRotation);
      oldfh := SelectObject(C.Handle, fh);
    end;

    PPI := GetDeviceCaps(C.Handle, LOGPIXELSX);
    ratio := FDefPPI / PPI;
    if IsPrinter(C) then
      neededSize := Round(prnSz * FPrintScale / ratio) else
      neededSize := Round(prnSz / (FDefPPI / 96) * FScaleX);
    if not FWysiwyg then
      neededSize := Sz;
    extraSize := neededSize - Sz;

    CosA := Cos(pi / 180 * FRotation);
    SinA := Sin(pi / 180 * FRotation);
    if Align = haRight then
    begin
      X := x + Round((dx - neededSize + 1) * CosA);
      Y := y - Round((dx - neededSize + 1) * SinA);

      Dec(X, 1);
      if (fsBold in Style) or (fsItalic in Style) then
        if FRotation = 0 then
          Dec(X, 1);
    end
    else if Align = haCenter then
    begin
      X := x + Round((dx - neededSize) / 2 * CosA);
      Y := y - Round((dx - neededSize) / 2 * SinA);
    end;


    if Align = haBlock then
    begin
      GetMem(spaceAr, SizeOf(Integer) * n);
      spaceCount := CountSpaces;