ietextc.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

begin
  ResetCache(0,fTextLength);  // 2.2.4
  invalidate;
end;

procedure TIETextControl.WMKillFocus(var Msg: TWMKillFocus);
begin
  inherited;
  HideCaret(handle);
  DestroyCaret;
end;

procedure TIETextControl.WMSetFocus(var Msg: TWMSetFocus);
begin
  inherited;
end;

function TIETextControl.FindCharInfo(info: PIECharInfo): integer;
begin
  for result := 0 to fCharInfo.Count - 1 do
    if comparemem(@pbytearray(fCharInfo[result])[sizeof(integer)], @pbytearray(info)[sizeof(integer)], sizeof(TIECharInfo) - sizeof(integer)) then
    begin // [sizeof(integer)] to bypass reference count
      exit;
    end;
  result := -1;
end;

procedure TIETextControl.SaveCharInfo(idx: integer; charinf: PIECharInfo);
var
  i: integer;
  ci: PIECharInfo;
begin
  i := FindCharInfo(charinf);
  if i < 0 then
  begin
    // not saved, save now
    getmem(ci, sizeof(TIECharInfo));
    move(charinf^, ci^, sizeof(TIECharInfo));
    ci^.refcount := 0;
    i := fCharInfo.Add(ci)
  end;
  fCharRef[idx] := i;
  inc(PIECharInfo(fCharInfo[fCharRef[idx]])^.refcount);
end;

procedure TIETextControl.CopyCharInfoTo(source: integer; charinf: PIECharInfo);
begin
  source := imin(imax(0, source), fTextLength - 1);
  if source>=0 then
    move(PIECharInfo(fCharInfo[fCharRef[source]])^, charinf^, sizeof(TIECharInfo));
end;

procedure TIETextControl.RestoreCharInfo(idx: integer; XCanvas: TCanvas);
begin
  if not fFontLocked then
  begin
    with PIECharInfo(fCharInfo[fCharRef[idx]])^ do
    begin
      if XCanvas.Font.Name <> name then
        XCanvas.Font.Name := name;
      if XCanvas.Font.Height <> height then
        XCanvas.Font.Height := height;
      if XCanvas.Font.Style <> style then
        XCanvas.Font.Style := style;
      if (XCanvas.Font.Color <> color) and (not fForceDefaultColors) then
        XCanvas.Font.Color := color;
      if (XCanvas.Brush.Color <> brushColor) and (not fForceDefaultColors) then
        XCanvas.Brush.Color := brushColor;
      if XCanvas.Brush.Style <> brushStyle then
        XCanvas.Brush.Style := brushStyle;
    end;
  end
  else
  begin
    if XCanvas.Font.Name <> fDefaultFont.Name then
      XCanvas.Font.Name := fDefaultFont.Name;
    if XCanvas.Font.Height <> fDefaultFont.height then
      XCanvas.Font.Height := fDefaultFont.height;
    if XCanvas.Font.Style <> fDefaultFont.style then
      XCanvas.Font.Style := fDefaultFont.style;
    if (XCanvas.Font.Color <> color) and (not fForceDefaultColors) then
      XCanvas.Font.Color := fDefaultFont.Color;
    if (XCanvas.Brush.Color <> fDefaultFontBrush.Color) and (not fForceDefaultColors) then
      XCanvas.Brush.Color := fDefaultFontBrush.Color;
    if XCanvas.Brush.Style <> fDefaultFontBrush.Style then
      XCanvas.Brush.Style := fDefaultFontBrush.Style;
  end;
end;

// fText is simple ASCII test, except for following special tags:
//   #10 : carriage return and new line
//   #0 : end of stream

procedure TIETextControl.PaintTo(DestCanvas: TCanvas; DestX, DestY, NonZoomDestWidth, NonZoomDestHeight: integer);
type
  TDiff = record
    x, y: integer;
    c: char;
    idx: integer;
  end;
  PDiff = ^TDiff;
var
  c: pchar;
  printed, enters, fetched, x, y, xx: integer;
  firstpos: integer;
  i, j, il, idx: integer;
  fetch: boolean; // false=draw directly, true=fetching the row
  fetchpos: pchar;
  maxh, maxi, h, w: integer;
  posx, posy, rposx, prevend: integer;
  lasth, lasti: integer;
  tm: TTEXTMETRIC;
  PixelMult: double;
  oldta: integer;
  fStopAt: pchar;
  ofx, ofy: integer;
  diffbuf, diff, nextdiff: PDiff;
  difflen: integer;
  //
  // set also PixelMult
  function CalcJust(lastpos: integer): integer;
  var
    d: integer;
    just: TIEAlignment;
  begin
    PixelMult := 1;
    result := 0;
    d := imax(0, lastpos - 1);
    if d < fTextLength then
      just := PIECharInfo(fCharInfo[fCharRef[d]])^.align
    else
      just := fInsertingCharInfo^.align;
    if fFontLocked then
      just := fDefaultAlign;
    if just <> iejLeft then
    begin
      dec(lastpos);
      if fText[lastpos] = #0 then
        dec(lastpos);
      if fText[lastpos] = #10 then
        dec(lastpos);
      if fText[lastpos] = #32 then
        dec(lastpos);
      if lastpos = -1 then
        lastpos := 0;
      result := 0;
      if lastpos >= 0 then
        case Just of
          iejCenter: result := (NonZoomDestWidth - fposxarray[lastpos] - fcache_w[lastpos]) div 2;
          iejRight: result := NonZoomDestWidth - fposxarray[lastpos] - fcache_w[lastpos] - 1; // -1 for the cursor
          iejJustify:
            begin
              if (fText[lastpos + 1] <> #0) and ((lastpos + 2 < fTextLength) or (fText[lastpos + 2] <> #0)) and (fText[lastpos + 1] <> #10) then
              begin
                d := fposxarray[lastpos] + fcache_w[lastpos] + 1;
                if d <> 0 then
                  PixelMult := NonZoomDestWidth / d
                else
                  PixelMult := 1;
              end;
            end;
        end;
    end;
  end;
  // new line (new paragraph)
  procedure DoNewLine;
  begin
    if fetch then
    begin
      // now write
      fetch := false;
      posx := CalcJust(idx);
      rposx := posx;
      prevend := 0;
      c := fetchpos; // backtrack
    end
    else
    begin
      // continue to next row
      if fWriteFormattedString then
        fFormattedString := fFormattedString + #10;
      inc(posy, maxh + fLineSpace);
      fetchpos := c;
      fetch := true;
      maxh := lasth;
      maxi := lasti;
      fStopAt := nil;
      posx := 0;
      rposx := posx;
      prevend := 0;
      PixelMult := 1;
    end;
  end;
  // new line because the line is too much large - only fetching
  procedure LineLarge;
  var
    cc, o: pchar;
  begin
    // go back to the last #32
    cc := c;
    while (integer(cc) > integer(fetchpos)) and (cc^ <> #32) do
    begin
      o := cc;
      GoBack(cc);
      if cc = o then
        break; // not moved, exit
    end;
    if integer(cc) <= integer(fetchpos) then
      cc := c;
    if (cc^ = #32) then
      inc(cc); // bypass the #32
    fStopAt := cc;
    // now write
    fetch := false;
    c := fetchpos; // backtrack
    posx := CalcJust(integer(fStopAt) - integer(fText));
    rposx := posx;
    prevend := 0;
  end;
  procedure CalcSizes;
  var
    cc: char;
  begin
    if (c^ < #31) or (c^ = #127) then
      cc := #32
    else
      cc := c^;
    RestoreCharInfo(idx, DestCanvas); // load only when font changes
    if fcache_w[idx] = 0 then
      fcache_w[idx] := DestCanvas.TextWidth(cc);
    w := fcache_w[idx];
    if fcache_h[idx] = 0 then
    begin
      if fFixedHeight = 0 then
      begin
        GetTextMetrics(DestCanvas.Handle, tm);
        fcache_h[idx] := tm.tmHeight;
        fcache_InternalLeading[idx] := abs(tm.tmInternalLeading);
      end
      else
      begin
        fcache_h[idx] := fFixedHeight;
        fcache_InternalLeading[idx] := 0;
      end;
    end;
    h := fcache_h[idx];
    il := fcache_internalLeading[idx];
    if fetch then
    begin
      // only calc the max height
      lasth := h;
      lasti := il;
      if h > maxh then
        maxh := h;
      if il > maxi then
        maxi := il;
    end;
  end;
  //
begin
  if (NonZoomDestWidth <= 1) or (NonZoomDestHeight <= 1) then
    exit;
  fFormattedString := '';
  printed := 0;
  enters := 0;
  fetched := 0;
  firstpos := -1;
  PixelMult := 1;
  fStopAt := nil;
  difflen := 0;
  if fZoom <> 1 then
  begin
    getmem(diffbuf, fTextLength * 10 * sizeof(TDiff));
    diff := diffbuf;
  end
  else
  begin
    diffbuf := nil;
    diff := nil;
  end;

  DestCanvas.Pen.Width := 1;
  DestCanvas.Font.Color := DefaultFont.Color;
  DestCanvas.Pen.Color := DefaultFont.Color;
  DestCanvas.Pen.Style := fBorderPen.Style;
  DestCanvas.Pen.Color := fBorderPen.Color;
  DestCanvas.Pen.Mode := pmCopy;
  DestCanvas.Brush.Color := fBrush.Color;
  DestCanvas.Brush.Style := fBrush.Style;
  DestCanvas.Rectangle(DestX, DestY, DestX + round(NonZoomDestWidth * fZoom), DestY + round(NonZoomDestHeight * fZoom));
  DestCanvas.Pen.Style := psSolid;

  (*
  ofx := 1;
  ofy := 1;
  dec(NonZoomDestWidth, 2);
  dec(NonZoomDestHeight, 2);
  *)
  x:=NonZoomDestWidth;
  y:=NonZoomDestHeight;
  NonZoomDestWidth:=trunc( NonZoomDestWidth - NonZoomDestWidth*fMarginRight/100 -NonZoomDestWidth*fMarginLeft/100)-2;
  NonZoomDestHeight:=trunc( NonZoomDestHeight - NonZoomDestHeight*fMarginBottom/100 -NonZoomDestHeight*fMarginTop/100)-2;
  ofx:=1+trunc( x*fMarginLeft/100 );
  ofy:=1+trunc( y*fMarginTop/100 );

  // draw text
  oldta := SetTextAlign(DestCanvas.Handle, TA_BASELINE);
  c := fText;
  if c <> nil then
  begin
    fetch := true;
    fetchpos := c;
    maxh := 0;
    maxi := 0;
    posy := 0;
    posx := 0;
    rposx := 0;
    prevend := 0;
    lasth := 0;
    lasti := 0;
    repeat
      idx := integer(c) - integer(fText);
      fposxarray[idx] := ofx + rposx;
      fposyarray[idx] := ofy + posy;
      case c^ of
        #0: // end of stream
          begin
            if (not fetch) then
              break; // exit loop
            DoNewLine;
            fStopAt := nil;
          end;
        #10: // new line
          begin
            if firstpos = -1 then
              firstpos := idx;
            CalcSizes; // we need at least a size
            inc(c);
            if (fInsertPos = firstpos) and (idx = firstpos) then
            begin
              fCaretX := ofx + 0;
              fCaretY := ofy + 0;
              fCaretH := maxh;
            end;
            if idx < fInsertPos then
            begin
              fCaretX := ofx + 0;
              fCaretY := ofy + posy + maxh;
              fCaretH := maxh;
            end;
            if (not fetch) then
              inc(enters);
            if (not fetch) and (c^ = #0) then
              break; // exit loop
            DoNewLine;
          end;
      else
        begin
          // printable character
          if firstpos = -1 then
            firstpos := idx;
          if fetch then
            inc(fetched);
          if (not fetch) and (c = fStopAt) then
          begin
            DoNewLine;
            continue;
          end;
          CalcSizes; // set also w with the char width
          if fetch and (rposx + w + 2 >= NonZoomDestWidth) then
          begin
            LineLarge; // new line because the line is too much large
            if fStopAt = c then
              break;
            continue;
          end;
          if (not fetch) then
          begin
            // print the character
            x := DestX + ofx + rposx;
            y := DestY + ofy + (posy + maxh - maxi);
            if y < DestY + ofy + NonZoomDestHeight then
            begin
              if (idx >= fSelStart) and (idx < fSelStop) then
              begin
                // selected
                DestCanvas.Brush.Color := $00FFFFFF and (not DestCanvas.Brush.Color);
                DestCanvas.Font.Color := $00FFFFFF and (not DestCanvas.Font.Color);
                DestCanvas.Brush.Style := bsSolid;
              end;
              if posx <> rposx then
              begin
                // full justify, draw intra-spaces
                while prevend < rposx do
                begin
                  xx := DestX + ofx + prevend;
                  if diff <> nil then
                  begin
                    diff^.x := xx;
                    diff^.y := y;
                    diff^.c := ' ';
                    diff^.idx := idx;
                    inc(difflen);
                    inc(diff);
                  end
                  else
                    DestCanvas.TextOut(xx, y, ' ');
                  inc(prevend);
                end;
              end;
              if diff <> nil then
              begin
                diff^.x := x;
                diff^.y := y;
                diff^.c := c^;
                diff^.idx := idx;
                inc(diff);
                inc(difflen);
              end
              else
              begin
                DestCanvas.TextOut(x, y, c^);
              end;
              if fWriteFormattedString then
                fFormattedString := fFormattedString + c^;
            end
            else
            begin
              if fAutoSize and Visible then
              begin
                // only in edit mode
                Height := Height + h;
                if diffbuf <> nil then
                  freemem(diffbuf);
                exit;
              end;
            end;
            inc(printed);
            if idx = fInsertPos then
            begin
              fCaretX := ofx + rposx;
              fCaretY := ofy + posy;
              fCaretH := maxh;
            end
            else if idx < fInsertPos then
            begin
              fCaretX := ofx + rposx + w;
              fCaretY := ofy + posy;
              fCaretH := maxh;
            end;
          end;
          inc(posx, w);
          prevend := rposx + w;
          rposx := trunc(posx * PixelMult);
          inc(c);
        end;
      end;
    until False;
  end;
  if (printed + fetched + enters = 0) then
  begin