sgraphutils.pas

AlphaControls是一个Delphi标准控件的集合

        end;
      end;
      sConst.bsLowered: begin
        if Width > 1 then begin
          NewColor := ColorLine;
          for i := 0 to Width - 1 do begin
            DrawLine(dc, pP1, pP2, NewColor);
            ChangeCoord;
          end;
        end
        else begin
          NewColor := ColorLine;
          DrawLine(dc, pP1, pP2, NewColor);
        end;
      end;
    end;
  finally
    RestoreDC(DC, SavedDC);
  end;
end;

procedure BeveledLine(DC: HDC; ColorLine, Color: TColor; P1, P2: TPoint; Width : integer; Bevel: TsBorderStyle; Side: TsSide);
var
  i{, w }: integer;
  pP1, pP2: TPoint;
  NewColor, AvColor : TColor;
  SavedDC : hWnd;
  procedure ChangeCoord; begin
    case Side of
      sdLeft:   begin inc(pP1.x); dec(pP1.y); inc(pP2.x); inc(pP2.y); end;
      sdTop:    begin inc(pP1.x); inc(pP1.y); dec(pP2.x); inc(pP2.y); end;
      sdRight:  begin dec(pP1.x); inc(pP1.y); dec(pP2.x); dec(pP2.y); end;
      sdBottom: begin dec(pP1.x); dec(pP1.y); inc(pP2.x); dec(pP2.y); end;
    end;
  end;
begin
  SavedDC := SaveDC(DC);
  if SavedDC = 0 then Exit;

  try
    NewColor := ColorLine;
    pP1 := P1;
    pP2 := P2;

    Case Bevel of
      bsFlat1, bsFlat2 : begin
          for i := 0 to Width - 1 do begin // Raised
  //          w := 1;
            DrawLine(dc, pP1, pP2, NewColor);
            ChangeCoord;
          end;
      end;
      sConst.bsRaised: begin
        if Width > 1 then begin
          NewColor := clWhite;
          DrawLine(dc, pP1, pP2, NewColor);
          for i := 1 to Width - 1 do begin
            NewColor := ChangeColor(ColorLine, Color, i / (Width{ - 1}));
            ChangeCoord;
            DrawLine(dc, pP1, pP2, NewColor);
          end;
        end
        else begin
          NewColor := ColorLine;
          DrawLine(dc, pP1, pP2, NewColor);
        end;
      end;
      sConst.bsLowered: begin
        if Width > 1 then begin
          AvColor := ChangeColor(ColorLine, clBlack, BevSoftness);
          NewColor := clBlack;
          DrawLine(dc, pP1, pP2, NewColor);
          for i := 1 to Width - 1 do begin
            NewColor := ChangeColor(AvColor, Color, i / (Width{ - 1}));
            ChangeCoord;
            DrawLine(dc, pP1, pP2, NewColor);
          end;
        end
        else begin
          NewColor := ColorLine;
          DrawLine(dc, pP1, pP2, NewColor);
        end;
      end;
    end;
  finally
    RestoreDC(DC, SavedDC);
  end;
end;

procedure ExBevLine(DC: HDC; ColorLine, Color: TColor; P1, P2: TPoint; Width : integer; Bevel: TsBorderStyle; Side: TsSide);
var
  i{, w} : integer;
//  R: TRect;
  pP1, pP2: TPoint;
  NewColor, AvColor : TColor;
  procedure ChangeCoord; begin
    case Side of
      sdLeft: begin
        inc(pP1.x);
//        dec(pP1.y);
        inc(pP2.x);
//        inc(pP2.y);
      end;
      sdTop: begin
//        inc(pP1.x);
        inc(pP1.y);
//        dec(pP2.x);
        inc(pP2.y);
      end;
      sdRight: begin
        dec(pP1.x);
//        inc(pP1.y);
        dec(pP2.x);
//        dec(pP2.y);
      end;
      sdBottom: begin
//        dec(pP1.x);
        dec(pP1.y);
//        inc(pP2.x);
        dec(pP2.y);
      end;
    end;
  end;
begin

  NewColor := ColorLine;
  pP1 := P1;
  pP2 := P2;

  Case Bevel of
    bsFlat1, bsFlat2 : begin
        for i := 0 to Width - 1 do begin // Raised
//          w := 1;
          DrawLine(dc, pP1, pP2, NewColor);
          ChangeCoord;
        end;
    end;
    sConst.bsRaised: begin
      if Width > 1 then begin
        NewColor := clWhite;
        DrawLine(dc, pP1, pP2, NewColor);
        for i := 1 to Width - 1 do begin
          NewColor := ChangeColor(ColorLine, Color, i / (Width{ - 1}));
          ChangeCoord;
          DrawLine(dc, pP1, pP2, NewColor);
        end;
      end
      else begin
        NewColor := ColorLine;
        DrawLine(dc, pP1, pP2, NewColor);
      end;
    end;
    sConst.bsLowered: begin
      if Width > 1 then begin
        AvColor := ChangeColor(ColorLine, clBlack, BevSoftness);
        NewColor := clBlack;
        DrawLine(dc, pP1, pP2, NewColor);
        for i := 1 to Width - 1 do begin
          NewColor := ChangeColor(AvColor, Color, i / (Width{ - 1}));
          ChangeCoord;
          DrawLine(dc, pP1, pP2, NewColor);
        end;
      end
      else begin
        NewColor := ColorLine;
        DrawLine(dc, pP1, pP2, NewColor);
      end;
    end;
  end;
end;

procedure PaintCheck(Canvas: TCanvas; r: TRect; Enabled: boolean; Color: TColor);
var
  h, w: integer;
  aRect: TRect;
  procedure Paint(r: TRect); begin
    aRect := r;
    InflateRect(aRect, - WidthOf(r) div 8, - WidthOf(r) div 8);
    inc(aRect.Left, 1);
    inc(aRect.Top, 1);
    h := HeightOf(aRect);
    w := h div 4;
    Canvas.Polygon([
                    Point(aRect.Left,            aRect.Bottom - h div 3 - 2),
                    Point(aRect.Left + h div 3,  aRect.Bottom - 2),
                    Point(aRect.Right - 2,       aRect.Top + h div 3),
                    Point(aRect.Right - 2,       aRect.Top + h div 3 - w),
                    Point(aRect.Left + h div 3,  aRect.Bottom - 2 - w),
                    Point(aRect.Left + w,        aRect.Bottom - h div 3 - 2)
                                    ])
  end;
begin
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psSolid;
  if Enabled then begin
    Canvas.pen.color := Color;
    Canvas.brush.color := Color;
  end
  else begin
    Canvas.brush.color := cl3DLight;
    Canvas.pen.color := cl3DLight;

    OffsetRect(r, 1, 1);
    Paint(r);
    OffsetRect(r, -1, -1);

    Canvas.brush.color := clBtnShadow;
    Canvas.pen.color := clBtnShadow;
  end;
  Paint(r);
end;

function CutText(Canvas: TCanvas; Text: string; MaxLength : integer): string;
begin
  Result := Text;
  if (Canvas.TextWidth(Result) > MaxLength) and (Result <> '') then begin
    while Canvas.TextWidth(Result + '...') > MaxLength do begin
      Delete(Result, Length(Result), 1);
    end;
    Result := Result + '...';
  end;
end;

procedure WriteText(Canvas: TCanvas; Text: PChar; Enabled: boolean; var aRect : TsRect; Flags: Longint);
var
  R, Rd: TRect;
  x, y : integer;
  ts: TSize;
begin
  R := aRect;

  if Flags or DT_WORDBREAK <> Flags then begin // If no multiline

    GetTextExtentPoint32(Canvas.Handle, Text, Length(Text), ts);
    R.Right := R.Left + ts.cx;
    R.Bottom := R.Top + ts.cy;

    if Flags or DT_CENTER = Flags then begin
      y := (HeightOf(R) - HeightOf(aRect)) div 2;
      x := (WidthOf(R) - WidthOf(aRect)) div 2;
      InflateRect(aRect, x, y);
    end
    else if Flags or DT_RIGHT = Flags then begin
      y := (HeightOf(R) - HeightOf(aRect)) div 2;
      dec(aRect.Top, y);
      inc(aRect.Bottom, y);
      inc(aRect.Left, WidthOf(aRect) - WidthOf(R));
    end
    else if Flags or DT_LEFT = Flags then begin
      y := (HeightOf(R) - HeightOf(aRect)) div 2;
      dec(aRect.Top, y);
      inc(aRect.Bottom, y);
      inc(aRect.Right, WidthOf(R) - WidthOf(aRect));
    end;


    R := aRect;// := R;
    InflateRect(aRect, 1, 1);
  end;

  Canvas.Brush.Style := bsClear;
  if Text <> ''then
  if Enabled then begin
    DrawText(Canvas.Handle, Text, Length(Text), R, Flags);
  end
  else begin
    Rd := Rect(R.Left + 1, R.Top + 1, R.Right + 1, R.Bottom + 1);
    Canvas.Font.Color := ColorToRGB(clBtnHighlight);
    DrawText(Canvas.Handle, Text, Length(Text), Rd, Flags);

    Canvas.Font.Color := ColorToRGB(clBtnShadow);
    DrawText(Canvas.Handle, Text, Length(Text), R, Flags);
  end;
end;

procedure WriteTextEx(Canvas: TCanvas; Text: PChar; Enabled: boolean; var aRect : TsRect; Flags: Longint; SkinIndex : integer; Hot : boolean);
var
  R, Rd: TRect;
  x, y : integer;
  ts: TSize;
begin
  R := aRect;

  if Flags or DT_WORDBREAK <> Flags then begin // If no multiline

    GetTextExtentPoint32(Canvas.Handle, Text, Length(Text), ts);
    R.Right := R.Left + ts.cx;
    R.Bottom := R.Top + ts.cy;

    if Flags or DT_CENTER = Flags then begin
      y := (HeightOf(R) - HeightOf(aRect)) div 2;
      x := (WidthOf(R) - WidthOf(aRect)) div 2;
      InflateRect(aRect, x, y);
    end
    else if Flags or DT_RIGHT = Flags then begin
      y := (HeightOf(R) - HeightOf(aRect)) div 2;
      dec(aRect.Top, y);
      inc(aRect.Bottom, y);
      inc(aRect.Left, WidthOf(aRect) - WidthOf(R));
    end
    else if Flags or DT_LEFT = Flags then begin
      y := (HeightOf(R) - HeightOf(aRect)) div 2;
      dec(aRect.Top, y);
      inc(aRect.Bottom, y);
      inc(aRect.Right, WidthOf(R) - WidthOf(aRect));
    end;


    R := aRect;// := R;
    InflateRect(aRect, 1, 1);
  end;

  Canvas.Brush.Style := bsClear;
  if Text <> '' then
    if Enabled then begin
      if IsValidSkinIndex(SkinIndex) then begin
        // Left contur
        if Hot then Canvas.Font.Color := gd[SkinIndex].HotFontColor[2] else Canvas.Font.Color := gd[SkinIndex].FontColor[2];
        if Canvas.Font.Color <> -1 then begin
          Rd := Rect(R.Left - 1, R.Top, R.Right - 1, R.Bottom);
          DrawText(Canvas.Handle, Text, Length(Text), Rd, Flags);
        end;
        // Top
        if Hot then Canvas.Font.Color := gd[SkinIndex].HotFontColor[3] else Canvas.Font.Color := gd[SkinIndex].FontColor[3];
        if Canvas.Font.Color <> -1 then begin
          Rd := Rect(R.Left, R.Top - 1, R.Right, R.Bottom - 1);
          DrawText(Canvas.Handle, Text, Length(Text), Rd, Flags);
        end;
        // Right
        if Hot then Canvas.Font.Color := gd[SkinIndex].HotFontColor[4] else Canvas.Font.Color := gd[SkinIndex].FontColor[4];
        if Canvas.Font.Color <> -1 then begin
          Rd := Rect(R.Left + 1, R.Top, R.Right + 1, R.Bottom);
          DrawText(Canvas.Handle, Text, Length(Text), Rd, Flags);
        end;
        // Bottom
        if Hot then Canvas.Font.Color := gd[SkinIndex].HotFontColor[5] else Canvas.Font.Color := gd[SkinIndex].FontColor[5];
        if Canvas.Font.Color <> -1 then begin
          Rd := Rect(R.Left, R.Top + 1, R.Right, R.Bottom + 1);
          DrawText(Canvas.Handle, Text, Length(Text), Rd, Flags);
        end;
        // Center
        if Hot then Canvas.Font.Color := gd[SkinIndex].HotFontColor[1] else Canvas.Font.Color := gd[SkinIndex].FontColor[1];
        DrawText(Canvas.Handle, Text, Length(Text), R, Flags);
      end
      else DrawText(Canvas.Handle, Text, Length(Text), R, Flags);
    end
    else begin
      Rd := Rect(R.Left + 1, R.Top + 1, R.Right + 1, R.Bottom + 1);
      Canvas.Font.Color := ColorToRGB(clBtnHighlight);
      DrawText(Canvas.Handle, Text, Length(Text), Rd, Flags);

      Canvas.Font.Color := ColorToRGB(clBtnShadow);
      DrawText(Canvas.Handle, Text, Length(Text), R, Flags);
    end;
end;

procedure FadeRect(CanvasSrc: TCanvas; RSrc: TRect; CanvasDst: HDC; PDst: TPoint; Transparency: integer; Color: TColor; Blur : integer; Shape: TsShadowingShape); overload;
begin
  FadeRect(CanvasSrc, RSrc, CanvasDst, PDst, Transparency, Color, Blur, Shape, 0);
end;

procedure FadeRect(CanvasSrc: TCanvas; RSrc: TRect; CanvasDst: HDC; PDst: TPoint; Transparency: integer; Color: TColor; Blur : integer; Shape: TsShadowingShape; Radius : integer); overload;
var
  Bmp, TempBmp : TBitmap;
  delta: real;
  RValue,
  i{, j} : integer;
  c : TsColor;
  SavedBmp, SavedSrc, SavedDst: longint;
begin
  SavedSrc := SaveDC(CanvasSrc.Handle);
  SavedDst := SaveDC(CanvasDst);
  Color := ColorToRGB(Color);
  try

  case Transparency of
    100: begin
      BitBlt(CanvasDst,
             PDst.x, PDst.y, WidthOf(RSrc), HeightOf(RSrc), CanvasSrc.Handle,
             RSrc.Left, RSrc.Top, SRCCOPY);
    end;