fctext.pas

一套及时通讯的原码

function TfcText.GetTextSize: TSize;
var s: string;
  r:TRect;
  sz:TSize;
  xoffset:integer;
  yoffset:integer;
begin
  if toShowAccel in Options then
    s := fcStripAmpersands(Text)
  else s := Text;
  r:=Rect(TextRect.Left,TextRect.Top,TextRect.Right,TextRect.Bottom);
  sz := ExtrudeEffects.EffectiveDepth(False);
  xoffset := Max(Shadow.effectiveoffset.x,sz.cx);
  yoffset := Max(Shadow.effectiveoffset.y,sz.cy);
  r.Right := r.right-xoffset;
  r.Bottom := r.Bottom-yoffset;
  with fcMultiLineTextSize(Canvas, s, LineSpacing, ord(WordWrap) * fcRectWidth(r), Flags) do
    result := fcSize(cx, cy);
  result.cx:= result.cx+1; // 11/9/01 RSW - Fix boldface problem where it was showing trailing ellipsis even when it fit
end;

procedure TfcText.DrawHighlight;
var r: TRect;
begin
  r := FRect;
  with OFFSETCOORD[ExtrudeEffects.Orientation] do OffsetRect(r, -x, -y);

  Canvas.Font.Color := HighlightColor;
  DrawText(r);
  Canvas.Font.Color := Font.Color;
  DrawText(FRect);
end;

procedure TfcText.DrawShadow(r: TRect);
begin
  if not Shadow.Enabled then Exit;
  OffsetRect(r, Shadow.XOffset, Shadow.YOffset);
  Canvas.Font.Color := fcThisThat(Callbacks.GetTextEnabled, Shadow.Color, DisabledColors.ShadeColor);
  DrawText(r);
end;

procedure TfcText.DrawOutline;
var i: TfcOrientation;
    r: TRect;
begin
  for i := Low(OFFSETCOORD) to HIGH(OFFSETCOORD) do with OFFSETCOORD[i] do
  begin
    r := FRect;
    OffsetRect(r, x, y);
    Canvas.Font.Color := fcThisThat(Callbacks.GetTextEnabled, OutlineColor, DisabledColors.ShadeColor);
    DrawText(r);
  end;
  r := FRect;
  Canvas.Font.Color := fcThisThat(Callbacks.GetTextEnabled, Font.Color, DisabledColors.HighlightColor);
  DrawText(r);
end;

procedure TfcText.DrawEmbossed(Raised: Boolean);
var r: TRect;
    HighlightColor, ShadeColor: TColor;
begin
  HighlightColor := fcThisThat(Callbacks.GetTextEnabled, self.HighlightColor, DisabledColors.HighlightColor);
  ShadeColor := fcThisThat(Callbacks.GetTextEnabled, self.ShadeColor, DisabledColors.ShadeColor);//clBtnShadow);

  if Callbacks.GetTextEnabled and not
    (((ShadeColor = clNone) and not Raised) or
     ((HighlightColor = clNone) and Raised)) then
  begin
    r := FRect;
    OffsetRect(r, -1, -1);
    Canvas.Font.Color := fcThisThat(Raised, HighlightColor, ShadeColor);
    DrawText(r);
  end;

  if not (((HighlightColor = clNone) and not Raised) or
      ((ShadeColor = clNone) and Raised)) then
  begin
    r := FRect;
    OffsetRect(r, 1, 1);
    Canvas.Font.Color := fcThisThat(Raised, ShadeColor, HighlightColor);
    DrawText(r);
  end;

  r := FRect;
  Canvas.Font.Color := fcThisThat(Callbacks.GetTextEnabled, Font.Color, DisabledColors.ShadeColor);
  DrawText(r);
end;

procedure TfcText.DrawText(r: TRect);
var i: Integer;
    s: string;
    Angle: Extended;
    CurLineHeight: Integer;
    tempr:TRect;

    n, extra, blanks: Integer;
    juststr: string;
    linecount:integer;
    curpos,priorpos,curwidth:integer;
    tokenword:string;
    paragraphend:boolean;
    k:integer;
    oldbkmode:integer;
    Delimiter:string;
begin
  Angle := self.Angle;

  CurLineHeight := fcLineHeight(Canvas, Flags, max(5,fcRectWidth(r){-10}), 'AgTpjW');// + LineSpacing -2;

  LineCount := (fcRectHeight(r) div CurLineHeight) + 1;
  OldBkMode := SetBkMode(Canvas.Handle, TRANSPARENT);
  if Wordwrap and (toFullJustify in Options) then begin
    if fcCountTokens(Text,#10#10) > 1 then Delimiter := #10#10
    else Delimiter := #13#10;

    for k := 0 to fcCountTokens(Text, Delimiter) - 1 do begin
      s := fcGetToken(Text, Delimiter, k);
      curPos := 1;
      for i := 0 to LineCount +1 do begin
        curwidth := 0;
        tokenword := fcgetWord(s,curPos,[],[' ',#9]);
        if tokenword = '' then begin
           OffsetRect(r, fcTrunc(Sin(Angle) * CurLineHeight), fcTrunc(Cos(Angle) * CurLineHeight));
           break;
        end;
        juststr := '';
        paragraphend := false;
        blanks := 0;
        priorpos:=curpos;
        while (curwidth+Canvas.TextWidth(Tokenword)<fcRectWidth(r){-10}) {and (tokenword <> '')} do begin
          if (length(tokenword)=1) and (tokenword <> ' ') then
           juststr := juststr+tokenword+' '
          else juststr := juststr+tokenword{+' '};
          priorpos:=curpos;
          tokenword := fcgetWord(s,curPos,[],[#32,#9]);
          if (tokenword = '') then begin
             paragraphend := true;
             break;
          end;
          curwidth := Canvas.TextWidth(juststr);
        end;
        if not (curwidth+Canvas.TextWidth(Tokenword)<fcRectWidth(r)) then
           curpos:=priorpos;
        JustStr := Trim(JustStr);
        for n:= 1 to length(juststr) do
          if juststr[n] = ' ' then inc( blanks );
        extra := fcRectWidth(r) {- 10}- Canvas.textwidth(juststr);
        if (not paragraphend) and (blanks > 0) then//and (i< fcCountTokens(Text, #13#10)-1) then
           settextjustification(Canvas.handle, extra, blanks );
        Canvas.textout(r.Left, r.top, juststr);
        settextjustification(Canvas.handle, 0, 0 );
        OffsetRect(r, fcTrunc(Sin(Angle) * CurLineHeight), fcTrunc(Cos(Angle) * CurLineHeight));
        if paragraphend then begin
           OffsetRect(r, fcTrunc(Sin(Angle) * LineSpacing), fcTrunc(Cos(Angle) * LineSpacing));
           break;
        end;
      end; // End For i
    end; //End For k
  end
  else begin
    //9/19/2001 - Was not incrementing the rect when multiple line label.
    tempr := Rect(r.left,r.top,r.right{-10},r.bottom);
    for i := 0 to fcCountTokens(Text, #13#10) - 1 do
    begin
      s := fcGetToken(Text, #13#10, i);
      tempr := Rect(tempr.left,tempr.top,tempr.right,tempr.bottom);
      DrawTextEx(Canvas.Handle, PChar(s), Length(s),tempr, Flags, nil);
      CurLineHeight := fcLineHeight(Canvas, Flags, fcRectWidth(r), s) + LineSpacing;
      OffsetRect(tempr,
        fcTrunc(Sin(Angle) * CurLineHeight),
        fcTrunc(Cos(Angle) * CurLineHeight)
      );
    end;
    SetBkMode(Canvas.Handle, OldBkMode);
  end;
{   len := SendMessage( editcontrol_handle, EM_LINELENGTH, lineindex, 0 );
   If len > 0 Then Begin
     pBuf := StrAlloc( len + 1 );
     If Assigned( pBuf ) Then
     try
       SendMessage( editcontrol_handle, EM_GETLINE, lineindex,
                    longint(pBuf));
       ... do something with the text, e.g. StrPas it to a Pascal string
     finally
       StrDispose( pBuf );
     end;
   End; }
end;

// Initializes the Canvas's font using the rotation passed in.  Also
// set's the Canvas' font color to the passed in Font.Color.  The result
// is essentially the rectangle that should be used for any subsequent
// call to DrawTextEx as the position and size are calculated here.
//
// Always remember to "DeleteObject" the Canvas.Font.Handle when done.
//
// - ksw (9/28/98)

procedure TfcText.PrepareCanvas;
begin
  // Must Free This!
  Canvas.Font.Handle := CreateFontIndirect(GetLogFont);

  Canvas.Font.Color := Font.Color;

  FRect := CalcRect(False);
end;

function TfcText.CalcDrawRect(IgnoreRect: Boolean): TRect;
begin
  Canvas.Font.Handle := CreateFontIndirect(GetLogFont);
  try
    result := CalcRect(IgnoreRect);
  finally
    DeleteObject(Canvas.Font.Handle);
  end;
end;

procedure TfcText.CallInvalidate;
begin
  if Assigned(Callbacks.Invalidate) then Callbacks.Invalidate;
end;

procedure TfcText.UpdateFont(Value:TFont);
begin
   Font.Style := Value.Style;
   Font.Name := Value.Name;
   Font.Size := Value.Size;
   Font.Color := Value.Color;
   Font.Height := Value.Height;
   Font.Pitch := Value.Pitch;
   Font.Charset := value.Charset;
end;

procedure TfcText.Draw;
 procedure DoubleBufferedDraw;
 var aUpdateRect:TRect;
 begin
  aUpdateRect := Canvas.ClipRect;
  FPaintBitmap := TBitmap.Create;
  FPaintCanvas := FPaintBitmap.Canvas;
  try
    // 9/26/2001 - Paintbitmap not large enough so not working on statusbar right aligned.
    FPaintBitmap.width := aUpdateRect.Right{-aUpdateRect.Left};//CalcDrawRect(True).Right;
    FPaintBitmap.Height := aUpdateRect.Bottom{-aUpdateRect.Top};//CalcDrawRect(True).Bottom;
//    FPaintCanvas.CopyRect(CalcDrawRect(True),FCanvas,CalcDrawRect(True));
    with FPaintBitmap, aUpdateRect do
       BitBlt(FPaintBitmap.Canvas.Handle, Left, Top, Right - Left, Bottom - Top, self.Canvas.Handle, Left, Top, SRCCOPY);
    InDraw:=True;
    if Rotation mod 360 = 0 then with TextRect do
    begin
      if Alignment = taCenter then Flags := Flags or DT_CENTER else Flags := Flags and not DT_CENTER;
      if Alignment = taRightJustify then Flags := Flags or DT_RIGHT else Flags := Flags and not DT_RIGHT;
      case Alignment of
        taLeftJustify: TextRect := Rect(Left, Top, Left + fcRectWidth(CalcDrawRect(False)), Bottom);
        taRightJustify: TextRect := Rect(Right - fcRectWidth(CalcDrawRect(False)), Top, Right, Bottom);
      end;
      case VAlignment of
        vaTop: TextRect := Rect(Left, Top, Right, fcRectHeight(CalcDrawRect(False)));
        vaBottom: TextRect := Rect(Left, Bottom - fcRectHeight(CalcDrawRect(False)), Right, Bottom);
      end;
    end else Flags := Flags and not DT_CENTER and not DT_RIGHT;  // Added to correct bug where text was not painted in the proper position when rotated.  -ksw (5/20/99)

    case Style of
      fclsDefault: DrawStandardText;
      fclsLowered: DrawEmbossedText(False);
      fclsRaised: DrawEmbossedText(True);
      fclsOutline: DrawOutlineText;
    end;
    InDraw:=False;
    with FPaintBitmap, aUpdateRect do
       BitBlt(Self.Canvas.Handle, Left, Top, Right - Left, Bottom - Top, Canvas.Handle, Left, Top, SRCCOPY);

  finally
    InDraw:=False;
    FPaintBitmap.Free;
    FPaintBitmap := nil;
    FPaintCanvas := nil;
  end;
 end;

begin
  if (DoubleBuffered) then
  begin
     DoubleBufferedDraw;
     exit;
  end;

  if Rotation mod 360 = 0 then with TextRect do
  begin
    if Alignment = taCenter then Flags := Flags or DT_CENTER else Flags := Flags and not DT_CENTER;
    if Alignment = taRightJustify then Flags := Flags or DT_RIGHT else Flags := Flags and not DT_RIGHT;
    case Alignment of
      taLeftJustify: TextRect := Rect(Left, Top, Left + fcRectWidth(CalcDrawRect(False)), Bottom);
      taRightJustify: TextRect := Rect(Right - fcRectWidth(CalcDrawRect(False)), Top, Right, Bottom);
    end;
    case VAlignment of
      vaTop: TextRect := Rect(Left, Top, Right, fcRectHeight(CalcDrawRect(False)));
      vaBottom: TextRect := Rect(Left, Bottom - fcRectHeight(CalcDrawRect(False)), Right, Bottom);
    end;
  end else Flags := Flags and not DT_CENTER and not DT_RIGHT;  // Added to correct bug where text was not painted in the proper position when rotated.  -ksw (5/20/99)

  case Style of
    fclsDefault: DrawStandardText;
    fclsLowered: DrawEmbossedText(False);
    fclsRaised: DrawEmbossedText(True);
    fclsOutline: DrawOutlineText;
  end;

end;

procedure TfcText.DrawStandardText;
begin
  // If disabled, draw the standard embossed (disabled) text.
  if not Callbacks.GetTextEnabled then
  begin
    DrawEmbossedText(False);
    Exit;
  end;

  PrepareCanvas;

  try
    DrawExtrusion;
    DrawShadow(FRect);
    Canvas.Font.Color := Font.Color;
    DrawText(FRect);
  finally
    DeleteObject(Canvas.Font.Handle);
  end;
end;

procedure TfcText.DrawOutlineText;
begin
  PrepareCanvas;
  try
    DrawExtrusion;
    DrawShadow(FRect);
    DrawOutline;
  finally
    DeleteObject(Canvas.Font.Handle);
  end;
end;

procedure TfcText.DrawEmbossedText(Raised: Boolean);
begin
  PrepareCanvas;
  try
    Canvas.Lock;
    DrawExtrusion;
    DrawShadow(FRect);
    DrawEmbossed(Raised);
  finally
    Canvas.UnLock;
    DeleteObject(Canvas.Font.Handle);
  end;
end;

procedure TfcText.DrawExtrusion;
var ExtrudeColor, ShadeColor: TRGBQuad;
    i: Integer;
begin
  with ExtrudeEffects do
  begin
    if not Enabled then Exit;

    with ExtrudeColor do
      fcColorToByteValues(ExtrudeEffects.NearColor, rgbReserved, rgbBlue, rgbGreen, rgbRed);
    with ShadeColor do
      fcColorToByteValues(ExtrudeEffects.FarColor, rgbReserved, rgbBlue, rgbGreen, rgbRed);

    with ExtrudeEffects.EffectiveDepth(True) do
    begin
      OffsetRect(FRect, cx div 2, cy div 2);
      with OFFSETCOORD[ExtrudeEffects.Orientation] do
        OffsetRect(FRect, -x * (cx div 2), -y * (cy div 2));
    end;

    // Draw Gradiated Extrusion
    for i := 1 to Depth do
    begin
      with OFFSETCOORD[Orientation] do
        OffsetRect(FRect, x, y);

      if not Striated then Canvas.Font.Color := RGB(
        fcTrunc(ShadeColor.rgbRed + ((ExtrudeColor.rgbRed - ShadeColor.rgbRed) / (Depth / i))),
        fcTrunc(ShadeColor.rgbGreen + ((ExtrudeColor.rgbGreen - ShadeColor.rgbGreen) / (Depth / i))),
        fcTrunc(ShadeColor.rgbBlue + ((ExtrudeColor.rgbBlue - ShadeColor.rgbBlue) / (Depth / i)))
      )
      else Canvas.Font.Color := RGB(
        i * (ShadeColor.rgbRed + ((ExtrudeColor.rgbRed - ShadeColor.rgbRed) div Depth)) div (ord(i mod 2 = 0) * 3 + 1),
        i * (ShadeColor.rgbGreen + ((ExtrudeColor.rgbGreen - ShadeColor.rgbGreen) div Depth)) div (ord(i mod 2 = 0) * 3 + 1),
        i * (ShadeColor.rgbBlue + ((ExtrudeColor.rgbBlue - ShadeColor.rgbBlue) div Depth)) div (ord(i mod 2 = 0) * 3 + 1)
      );

      DrawText(FRect);
    end;
  end;
end;

function TfcText.GetCanvas: TCanvas;
begin
  if InDraw then
     result:= FPaintCanvas
  else
     result:= FCanvas;
end;

end.