lbleffct.pas

功能强大和形态多样的TLabel控件

    Invalidate;
  end;
end;

{ Set shadow direction and repaint }
procedure TLabelEffect.SetDirectionShadow(edDirection: TEffectDirection);
begin
  if FDirectionShadow <> edDirection then
  begin
    FDirectionShadow := edDirection;
    if not bChangingStyle then  { Default to custom style when changed }
      SetEffectStyle(esCustom);
    Invalidate;
  end;
end;

{ Set highlight colour and repaint }
procedure TLabelEffect.SetColourHighlight(clrHighlight: TColor);
begin
  if FColourHighlight <> clrHighlight then
  begin
    FColourHighlight := clrHighlight;
    clrSchemes[csCustom, cpHighlight] := clrHighlight;
    if not bChangingScheme then  { Default to custom colour scheme when changed }
      SetColourScheme(csCustom);
    Invalidate;
  end;
end;

{ Set shadow colour and repaint }
procedure TLabelEffect.SetColourShadow(clrShadow: TColor);
begin
  if FColourShadow <> clrShadow then
  begin
    FColourShadow := clrShadow;
    clrSchemes[csCustom, cpShadow] := clrShadow;
    if not bChangingScheme then  { Default to custom colour scheme when changed }
      SetColourScheme(csCustom);
    Invalidate;
  end;
end;

{ Set highlight graduate colour and repaint }
procedure TLabelEffect.SetGraduateHighlight(clrHighlight: TColor);
begin
  if FGraduateHighlight <> clrHighlight then
  begin
    FGraduateHighlight := clrHighlight;
    if StyleHighlight = eoGraduated then  { Only has effect if highlight is graduated }
      Invalidate;
  end;
end;

{ Set shadow graduate colour and repaint }
procedure TLabelEffect.SetGraduateShadow(clrShadow: TColor);
begin
  if FGraduateShadow <> clrShadow then
  begin
    FGraduateShadow := clrShadow;
    if StyleShadow = eoGraduated then  { Only has effect if shadow is graduated }
      Invalidate;
  end;
end;

{ Set text face colour and repaint }
procedure TLabelEffect.SetColourFace(clrFace: TColor);
begin
  if Font.Color <> clrFace then
  begin
    { Graduate colours follow until different }
    if GraduateHighlight = Font.Color then
      GraduateHighlight := clrFace;
    if GraduateShadow = Font.Color then
      GraduateShadow := clrFace;
    Font.Color := clrFace;
    clrSchemes[csCustom, cpFace] := clrFace;
    if not bChangingScheme then  { Default to custom colour scheme when changed }
      SetColourScheme(csCustom);
    Invalidate;
  end;
end;

{ Set text graduate option and repaint }
procedure TLabelEffect.SetGraduateFace(goGrad: TGraduateOption);
begin
  if FGraduateFace <> goGrad then
  begin
    FGraduateFace := goGrad;
    Invalidate;
  end;
end;

{ Set text graduate colour and repaint }
procedure TLabelEffect.SetGraduateFrom(clrGrad: TColor);
begin
  if FGraduateFrom <> clrGrad then
  begin
    FGraduateFrom := clrGrad;
    if GraduateFace <> goNone then  { Only has effect if GraduateFace is not goNone }
      Invalidate;
  end;
end;

{ Set highlight style and repaint }
procedure TLabelEffect.SetStyleHighlight(eoStyle: TEffectOption);
begin
  if FStyleHighlight <> eoStyle then
  begin
    FStyleHighlight := eoStyle;
    if FStyleHighlight in [eoNormal, eoReal] then
      ResizeHighlight := rsNone;
    Invalidate;
  end;
end;

{ Set shadow style and repaint }
procedure TLabelEffect.SetStyleShadow(eoStyle: TEffectOption);
begin
  if FStyleShadow <> eoStyle then
  begin
    FStyleShadow := eoStyle;
    if FStyleShadow in [eoNormal, eoReal] then
      ResizeShadow := rsNone;
    Invalidate;
  end;
end;

{ Set highlight resize option and repaint }
procedure TLabelEffect.SetResizeHighlight(rsSize: TResizeOption);
begin
  if FResizeHighlight <> rsSize then
  begin
    FResizeHighlight := rsSize;
    if StyleHighlight <> eoGraduated then
      StyleHighlight := eoExtrude;
    Invalidate;
  end;
end;

{ Set shadow resize option and repaint }
procedure TLabelEffect.SetResizeShadow(rsSize: TResizeOption);
begin
  if FResizeShadow <> rsSize then
  begin
    FResizeShadow := rsSize;
    if StyleShadow <> eoGraduated then
      StyleShadow := eoExtrude;
    Invalidate;
  end;
end;

{ Set overall effect style - combination of highlight and shadow directions and depths }
procedure TLabelEffect.SetEffectStyle(esStyle: TEffectStyle);
begin
  if FEffectStyle <> esStyle then
  begin
    bChangingStyle := True;   { So it doesn't reset to custom }
    bChangingScheme := True;  {          "                    }
    FEffectStyle := esStyle;
    SetColourHighlight(clrSchemes[ColourScheme, cpHighlight]);
    case FEffectStyle of
    esRaised:
      begin
        SetDirectionHighlight(edUpLeft);
        SetDirectionShadow(edDownRight);
        SetDepthHighlight(1);
        SetDepthShadow(1);
      end;
    esSunken:
      begin
        SetDirectionHighlight(edDownRight);
        SetDirectionShadow(edUpLeft);
        SetDepthHighlight(1);
        SetDepthShadow(1);
      end;
    esShadow:
      begin
        SetDirectionHighlight(edNone);
        SetDirectionShadow(edDownRight);
        SetDepthHighlight(0);
        SetDepthShadow(2);
        SetAsButton(False);
      end;
    esFlying:
      begin
        SetDirectionHighlight(edDownRight);
        SetDirectionShadow(edDownRight);
        SetDepthHighlight(1);
        SetDepthShadow(5);
        SetColourHighlight(clrSchemes[ColourScheme, cpShadow]);  { Flying has two shadows }
        SetAsButton(False);
      end;
    esNone:
      begin
        SetDirectionHighlight(edNone);
        SetDirectionShadow(edNone);
        SetDepthHighlight(0);
        SetDepthShadow(0);
        SetAsButton(False);
      end;
    else
      SetAsButton(False);
    end;
    bChangingStyle := False;   { So further changes set style to custom }
    bChangingScheme := False;  { So further changes set colour scheme to custom }
  end;
end;

{ Set overall colour scheme }
procedure TLabelEffect.SetColourScheme(csScheme: TColourScheme);
begin
  if FColourScheme <> csScheme then
  begin
    bChangingScheme := True;  { So it doesn't reset to custom }
    FColourScheme := csScheme;
    SetColourHighlight(clrSchemes[FColourScheme, cpHighlight]);
    SetColourFace(clrSchemes[FColourScheme, cpFace]);
    SetColourShadow(clrSchemes[FColourScheme, cpShadow]);
    if FColourScheme <> csCustom then  { Save for future reference }
    begin
      clrSchemes[csCustom, cpHighlight] := clrSchemes[FColourScheme, cpHighlight];
      clrSchemes[csCustom, cpFace] := clrSchemes[FColourScheme, cpFace];
      clrSchemes[csCustom, cpShadow] := clrSchemes[FColourScheme, cpShadow];
    end;
    bChangingScheme := False;  { So further changes set colour scheme to custom }
  end;
end;

{ Set background bitmap to be masked and repaint }
procedure TLabelEffect.SetBitmap(bmp: TBitmap);
begin
  FBitmap.Assign(bmp);
end;

{ Change background bitmap }
procedure TLabelEffect.ChangeBitmap(Sender: TObject);
begin
  Invalidate;
end;

{ Set text to act like a button }
procedure TLabelEffect.SetAsButton(bBtn: Boolean);
begin
  if FAsButton <> bBtn then
  begin
    FAsButton := bBtn;
    if bBtn then    { If not already raised, raise it }
      SetEffectStyle(esRaised);
  end;
end;

{ Set angle of text and repaint }
procedure TLabelEffect.SetAngle(aAngle: TAngleRange);
begin
  if FAngle <> aAngle then
  begin
    FAngle := aAngle;
    dCosAngle := Cos(FAngle * dDegToRad);  { Calculate values for later use }
    dCosSquared := dCosAngle * dCosAngle;
    dSinAngle := Sin(FAngle * dDegToRad);
    dSinSquared := dSinAngle * dSinAngle;
    if FAngle <> 0 then
      Alignment := taLeftJustify;  { Cannot align when rotated }
    Invalidate;
  end;
end;

{ Set rotated text to stay vertical and repaint }
procedure TLabelEffect.SetKeepLettersVertical(bKeep: Boolean);
begin
  if FKeepLettersVertical <> bKeep then
  begin
    FKeepLettersVertical := bKeep;
    if Angle <> 0 then     { Only has effect if Angle is non-zero }
      Invalidate;
  end;
end;

{ Return text face colour }
function TLabelEffect.GetColourFace: TColor;
begin
  Result := Font.Color;
end;

{ Return minimum of values }
function Min(iValues: array of Integer): Integer;
var
  i: Integer;
begin
  Result := iValues[0];
  if High(iValues) > 0 then
    for i := 1 to High(iValues) do
      if iValues[i] < Result then
        Result := iValues[i];
end;

{ Return maximum of values }
function Max(iValues: array of Integer): Integer;
var
  i: Integer;
begin
  Result := iValues[0];
  if High(iValues) > 0 then
    for i := 1 to High(iValues) do
      if iValues[i] > Result then
        Result := iValues[i];
end;

{ Extract red, green and blue values from a colour }
procedure GetRGB(clr: TColor; var iR, iG, iB: Byte);
begin
  iR := GetRValue(clr);
  iG := GetGValue(clr);
  iB := GetBValue(clr);
end;

{ Generate a rotated font and apply it to the specified canvas }
procedure TLabelEffect.SetTextAngle(cnv: TCanvas; aAngle: TAngleRange; iHeight: Integer);
var
  fntLogRec: TLogFont;    { Storage area for font information }
begin
  { Get the current font information. We only want to modify the angle }
  GetObject(cnv.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 := aAngle * 10;
  { Change size of font.
    "If this value is greater than zero, it specifies the cell height of the font.
    If it is less than zero, it specifies the character height of the font." }
  fntLogRec.lfHeight := iHeight;
  { Request TrueType precision }
  fntLogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;

  { Delphi will handle the deallocation of the old font handle }
  cnv.Font.Handle := CreateFontIndirect(fntLogRec);
end;

{ And now apply all these parameters and draw the thing! }
procedure TLabelEffect.Paint;
const
  wAlignments: array [TAlignment] of word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  { Offsets for drawing in the nominated directions }
  iOffsets: array [TEffectDirection, TDirXY] of -1..1 =
    ((0, 0), (0, -1), (+1, -1), (+1, 0), (+1, +1),
    (0, +1), (-1, +1), (-1, 0), (-1, -1));
  { Offsets for changing text sizes }
  iResizes: array [TResizeOption] of -1..1 = (0, +1, -1);
  rExpand: array [TEffectDirection, TDirXY] of Real =
    ((-0.5, -1.0), (-0.5, -2.0), (0.0, -2.0), (0.0, -1.0), (0.0, 0.0),
    (-0.5, 0.0), (-1.0, 0.0), (-1.0, -1.0), (-1.0, -2.0));
  rReduce: array [TEffectDirection, TDirXY] of Real =
    ((0.5, 0.5), (0.5, -1.0), (2.0, -1.0), (2.0, 0.5), (2.0, 2.0),
    (0.5, 2.0), (-1.0, 2.0), (-1.0, 0.5), (-1.0, -1.0));
  { Offsets for indent graduation }
  iIndents: array [0..5] of Byte = (1, 2, 4, 7, 9, 10);
  edIndents: array [1..9, goRIndented..goLIndented] of TEffectDirection =
    ((edUpLeft, edUpRight), (edLeft, edRight), (edUp, edUp),
    (edDownLeft, edDownRight), (edNone, edNone), (edUpRight, edUpLeft),
    (edDown, edDown), (edRight, edLeft), (edDownRight, edDownLeft));
var
  iMinOffset, iMaxOffset: Integer;
  rctTemp, rctFirst, rctLast: TRect;
  sText: array [0..255] of char;
  i, iMid, iH, iW, iX, iY, iU, iV, iLimit, iL, iLen: Integer;
  i1, i2, i3, i4, iAdj, iAdjX, iAdjY: Integer;
  iTextHeight, iTextWidth: Integer;
  p1, p2, p3, p4, p5, p6, p7, p8: TPoint;
  iFromR, iFromG, iFromB, iToR, iToG, iToB: Byte;
  rAdjustR, rAdjustG, rAdjustB: Real;
  bmpTemp, bmpWork, bmpForeground, bmpBackground: TBitmap;
  cnvWork: TCanvas;

  { Set offsets based on resize parameters }
  procedure SetResizeOffsets(rsResize: TResizeOption; edDir: TEffectDirection;
    iDepth: Integer; var iAdjX, iAdjY: Integer);
  var
    iNewWidth: Integer;
  begin
    if (Angle <> 0) and not KeepLettersVertical then  { Need to generate an angled font }
      SetTextAngle(cnvWork, Angle, Self.Font.Height - iResizes[rsResize] * iDepth)
    else
      cnvWork.Font.Size := Self.Font.Size + iResizes[rsResize] * iDepth;
    iNewWidth := cnvWork.TextWidth(Caption);
    case rsResize of
      rsExpand:
        begin
          iAdjX := Round(rExpand[edDir, drX] * (iNewWidth - iTextWidth));
          iAdjY := Round(rExpand[edDir, drY] * iDepth);
        end;
      rsReduce:
        begin
          iAdjX := Round(rReduce[edDir, drX] * (iTextWidth - iNewWidth));
          iAdjY := Round(rReduce[edDir, drY] * iDepth);
        end;
    end;
  end;

  { Apply all the effects for highlight or shadow }
  procedure PaintEffect(clrMain, clrGrad: TColor; edDir: TEffectDirection;
    iDepth: TEffectDepth; eoStyle: TEffectOption; rsResize: TResizeOption;
    iToReal: Byte; bIsFace: Boolean; iExtraY: Byte);
  var
    i, iL, iU, iV: Integer;
    iFromR, iFromG, iFromB, iToR, iToG, iToB: Byte;
    rAdjustR, rAdjustG, rAdjustB: Real;
  begin
    { Prepare for extruding highlight/shadow, if requested }
    GetRGB(clrMain, iFromR, iFromG, iFromB);
    rAdjustR := 0; rAdjustG := 0; rAdjustB := 0;
    iLimit := iDepth;
    if (eoStyle = eoReal) or bIsFace then  { Keep black - replaced later }
      GetRGB(clBlack, iFromR, iFromG, iFromB)
    else if (eoStyle <> eoNormal) and (iDepth > 1) then
    begin
      iLimit := 1;
      if eoStyle = eoGraduated then  { Set changes in RGB colours }
      begin