Delphi定制图纸-发光玻璃

Question

我已经对一些玻璃图像进行了很多实验，例如下面的图像，我开始思考必须有一种方法可以将其放入代码中，这样我就可以将其着色为任何我想要的颜色。它不需要看起来 100% 精确地像下图一样，但我想编写一些代码来绘制椭圆形和玻璃效果(带有一些非常奇特的计算的渐变)。我必须清楚地指出，我对数学很糟糕，而且我知道这需要一些棘手的公式。

我正在做的事情的示例:

椭圆形的边框是最简单的部分，椭圆形内部从上到下的渐变也相当简单 - 但是当涉及到使边缘褪色以使顶部和侧面呈现玻璃般的外观时 - 我不知道如何去做这件事。

原始左边缘图像:

是否有人能为我指出一个很好的教程，或者如果有人想演示它，我都会非常感激。

这是我迄今为止用来绘制的过程:

//B = Bitmap to draw to
//Col = Color to draw glass image
procedure TForm1.DrawOval(const Col: TColor; var B: TBitmap);
var
  C: TCanvas;       //Main canvas for drawing easily
  R: TRect;         //Base rect
  R2: TRect;        //Working rect
  X: Integer;       //Main top/bottom gradient loop
  CR, CG, CB: Byte; //Base RGB color values
  TR, TG, TB: Byte; //Working RGB color values
begin
  if assigned(B) then begin
    if B <> nil then begin
      C:= B.Canvas;
      R:= C.ClipRect;  
      C.Pen.Style:= psClear;
      C.Brush.Style:= bsSolid;
      C.Brush.Color:= B.TransparentColor;
      C.FillRect(R);
      C.Pen.Style:= psSolid;
      C.Pen.Color:= clBlack;
      C.Pen.Width:= 5;
      C.Brush.Color:= clBlack;
      R2:= R;
      for X:= 1 to 6 do begin
        R2.Bottom:= R2.Bottom - 1;
        C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
          Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
      end;
      R2.Left:= R2.Left + 1;
      R2.Right:= R2.Right - 1;
      C.Brush.Color:= Col;
      C.Pen.Width:= 3;
      C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
        Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
      C.Brush.Style:= bsSolid;
      C.Pen.Style:= psClear;
      R2:= R;
      R2.Left:= R2.Left + 13;
      R2.Right:= R2.Right - 13;
      R2.Top:= 3;
      R2.Bottom:= (R2.Bottom div 2) - 18;
      CR:= GetRValue(Col);
      CG:= GetGValue(Col);
      CB:= GetBValue(Col);
      for X:= 1 to 16 do begin
        TR:= EnsureRange(CR + (X * 4)+25, 0, 255);
        TG:= EnsureRange(CG + (X * 4)+25, 0, 255);
        TB:= EnsureRange(CB + (X * 4)+25, 0, 255);
        C.Brush.Color:= RGB(TR, TG, TB);
        C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
          Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
        R2.Left:= R2.Left + 2;
        R2.Right:= R2.Right - 2;
        R2.Bottom:= R2.Bottom - 1;
      end;
    end;
  end;
end;

Answer 1

所需 Material :

• AlphaBlend对于玻璃效果，
• GradientFill对于顶部渐变椭圆，
• MaskBlt绘制时排除已绘制的非矩形部分，
• 确实有一些数学知识，不过很简单。

确实有必要将绘图任务分成小步骤并按正确的顺序放置。那么这并不像乍看起来那么不可能。

在下面的代码中，我使用三个临时位图来达到最终目标:

• 在其上绘制所有内容以减少闪烁的内存位图，
• 临时位图，需要帮助，
• 用于存储剪切形状的 mask 位图。

我不喜欢代码中的注释，但我希望它能说明一切:

unit GlassLabel;

interface

uses
  Classes, Controls, Windows, Graphics, Math;

const
  DefTransparency = 30;

type
  TPercentage = 0..100;

  TGlassLabel = class(TGraphicControl)
  private
    FTransparency: TPercentage;
    procedure SetTransparency(Value: TPercentage);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    property Caption;
    property Color;
    property Font;
    property Transparency: TPercentage read FTransparency
      write SetTransparency default DefTransparency;
  end;

implementation

type
  PTriVertex = ^TTriVertex;
  TTriVertex = record
    X: DWORD;
    Y: DWORD;
    Red: WORD;
    Green: WORD;
    Blue: WORD;
    Alpha: WORD;
  end;

  TRGB = record
    R: Byte;
    G: Byte;
    B: Byte;
  end;

function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG;
  Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; overload;
  external msimg32 name 'GradientFill';

function GradientFill(DC: HDC; const ARect: TRect; StartColor,
  EndColor: TColor; Vertical: Boolean): Boolean; overload;
const
  Modes: array[Boolean] of ULONG = (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V);
var
  Vertices: array[0..1] of TTriVertex;
  GRect: TGradientRect;
begin
  Vertices[0].X := ARect.Left;
  Vertices[0].Y := ARect.Top;
  Vertices[0].Red := GetRValue(ColorToRGB(StartColor)) shl 8;
  Vertices[0].Green := GetGValue(ColorToRGB(StartColor)) shl 8;
  Vertices[0].Blue := GetBValue(ColorToRGB(StartColor)) shl 8;
  Vertices[0].Alpha := 0;
  Vertices[1].X := ARect.Right;
  Vertices[1].Y := ARect.Bottom;
  Vertices[1].Red := GetRValue(ColorToRGB(EndColor)) shl 8;
  Vertices[1].Green := GetGValue(ColorToRGB(EndColor)) shl 8;
  Vertices[1].Blue := GetBValue(ColorToRGB(EndColor)) shl 8;
  Vertices[1].Alpha := 0;
  GRect.UpperLeft := 0;
  GRect.LowerRight := 1;
  Result := GradientFill(DC, @Vertices, 2, @GRect, 1, Modes[Vertical]);
end;

function GetRGB(AColor: TColor): TRGB;
begin
  AColor := ColorToRGB(AColor);
  Result.R := GetRValue(AColor);
  Result.G := GetGValue(AColor);
  Result.B := GetBValue(AColor);
end;

function MixColor(Base, MixWith: TColor; Factor: Single): TColor;
var
  FBase: TRGB;
  FMixWith: TRGB;
begin
  if Factor <= 0 then
    Result := Base
  else if Factor >= 1 then
    Result := MixWith
  else
  begin
    FBase := GetRGB(Base);
    FMixWith := GetRGB(MixWith);
    with FBase do
    begin
      R := R + Round((FMixWith.R - R) * Factor);
      G := G + Round((FMixWith.G - G) * Factor);
      B := B + Round((FMixWith.B - B) * Factor);
      Result := RGB(R, G, B);
    end;
  end;
end;

function ColorWhiteness(C: TColor): Single;
begin
  Result := (GetRValue(C) + GetGValue(C) + GetBValue(C)) / 255 / 3;
end;

function ColorBlackness(C: TColor): Single;
begin
  Result := 1 - ColorWhiteness(C);
end;

{ TGlassLabel }

constructor TGlassLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
  FTransparency := DefTransparency;
end;

procedure TGlassLabel.Paint;
const
  DSTCOPY = $00AA0029;
  DrawTextFlags = DT_CENTER or DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER;
var
  W: Integer;
  H: Integer;
  BorderTop: Integer;
  BorderBottom: Integer;
  BorderSide: Integer;
  Shadow: Integer;
  R0: TRect; //Bounds of control
  R1: TRect; //Inside border
  R2: TRect; //Top gradient
  R3: TRect; //Text
  R4: TRect; //Perforation
  ParentDC: HDC;
  Tmp: TBitmap;
  Mem: TBitmap;
  Msk: TBitmap;
  ShadowFactor: Single;
  X: Integer;
  BlendFunc: TBlendFunction;

  procedure PrepareBitmaps;
  begin
    Tmp.Width := W;
    Tmp.Height := H;
    Mem.Canvas.Brush.Color := Color;
    Mem.Width := W;
    Mem.Height := H;
    Mem.Canvas.Brush.Style := bsClear;
    Msk.Width := W;
    Msk.Height := H;
    Msk.Monochrome := True;
  end;

  procedure PrepareMask(R: TRect);
  var
    Radius: Integer;
  begin
    Radius := (R.Bottom - R.Top) div 2;
    Msk.Canvas.Brush.Color := clBlack;
    Msk.Canvas.FillRect(R0);
    Msk.Canvas.Brush.Color := clWhite;
    Msk.Canvas.Ellipse(R.Left, R.Top, R.Left + 2 * Radius, R.Bottom);
    Msk.Canvas.Ellipse(R.Right - 2 * Radius, R.Top, R.Right, R.Bottom);
    Msk.Canvas.FillRect(Rect(R.Left + Radius, R.Top, R.Right - Radius,
      R.Bottom));
  end;

  procedure DrawTopGradientEllipse;
  begin
    GradientFill(Tmp.Canvas.Handle, R2, MixColor(Color, clWhite, 1.0),
      MixColor(Color, clWhite, 0.2), True);
    PrepareMask(R2);
    MaskBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0,
      Msk.Handle, 0, 0, MakeROP4(SRCCOPY, DSTCOPY));
  end;

  procedure DrawPerforation;
  begin
    while R4.Right < (W - H div 2) do
    begin
      Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.9);
      Mem.Canvas.RoundRect(R4.Left, R4.Top, R4.Right, R4.Bottom, H div 7,
        H div 7);
      Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.5);
      Mem.Canvas.RoundRect(R4.Left + 1, R4.Top + 1, R4.Right - 1,
        R4.Bottom - 1, H div 7 - 1, H div 7 - 1);
      Mem.Canvas.Pen.Color := MixColor(Color, clWhite, 0.33);
      Mem.Canvas.MoveTo(R4.Left + H div 14, R4.Top + 1);
      Mem.Canvas.LineTo(R4.Right - H div 14, R4.Top + 1);
      OffsetRect(R4, R4.Right - R4.Left + H div 12, 0);
    end;
  end;

  procedure DrawCaption;
  begin
    Mem.Canvas.Font := Font;
    ShadowFactor := 0.6 + 0.4 * (Min(1.0, ColorBlackness(Font.Color) + 0.3));
    Mem.Canvas.Font.Color := MixColor(Font.Color, clBlack, ShadowFactor);
    DrawText(Mem.Canvas.Handle, PChar(Caption), -1, R3, DrawTextFlags);
    OffsetRect(R3, -Shadow, Shadow);
    Mem.Canvas.Font.Color := Font.Color;
    DrawText(Mem.Canvas.Handle, PChar(Caption), -1, R3, DrawTextFlags);
  end;

  procedure DrawBorderAlias;
  begin
    Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.65);
    X := R1.Left + (R1.Bottom - R1.Top) div 2 + 2;
    Mem.Canvas.Arc(R1.Left + 1, R1.Top, R1.Left + R1.Bottom - R1.Top + 1,
      R1.Bottom, X, 0, X, H);
    X := R1.Right - (R1.Bottom - R1.Top) div 2 - 2;
    Mem.Canvas.Arc(R1.Right - 1, R1.Top, R1.Right - R1.Bottom + R1.Top - 1,
      R1.Bottom, X, H, X, 0);
  end;

  procedure DrawBorder;
  begin
    PrepareMask(R1);
    Tmp.Canvas.Brush.Color := clWhite;
    Tmp.Canvas.Draw(0, 0, Msk);
    BitBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0, SRCAND);
  end;

  procedure DrawCombineParent;
  begin
    BitBlt(Tmp.Canvas.Handle, 0, 0, W, H, ParentDC, Left, Top, SRCCOPY);
    BlendFunc.BlendOp := AC_SRC_OVER;
    BlendFunc.BlendFlags := 0;
    BlendFunc.SourceConstantAlpha := Round(FTransparency * High(Byte) / 100);
    BlendFunc.AlphaFormat := 0;
    AlphaBlend(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0, W, H,
      BlendFunc);
    PrepareMask(R0);
    MaskBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0,
      Msk.Handle, 0, 0, MakeROP4(DSTCOPY, SRCCOPY));
  end;

begin
  if HasParent and (Height > 1) then
  begin
    W := Width;
    H := Height;
    BorderTop := Max(1, H div 30);
    BorderBottom := Max(2, H div 10);
    BorderSide := (BorderTop + BorderBottom) div 2;
    Shadow := Font.Size div 8;
    R0 := ClientRect;
    R1 := Rect(BorderSide, BorderTop, W - BorderSide, H - BorderBottom);
    R2 := Rect(R1.Left + BorderSide + 1, R1.Top, R1.Right - BorderSide - 1,
      R1.Top + H div 4);
    R3 := Rect(H div 2 + 1 + Shadow, R1.Top + 1, W - H div 2 - 1,
      R1.Bottom - Shadow);
    R4 := Bounds(H div 2, R1.Bottom - H div 4 + 1, H div 5, H div 4 - 2);
    ParentDC := GetDC(Parent.Handle);
    Tmp := TBitmap.Create;
    Mem := TBitmap.Create;
    Msk := TBitmap.Create;
    try
      PrepareBitmaps;
      DrawTopGradientEllipse;
      DrawPerforation;
      DrawCaption;
      DrawBorderAlias;
      DrawBorder;
      DrawCombineParent;  
      BitBlt(Canvas.Handle, 0, 0, W, H, Mem.Canvas.Handle, 0, 0, SRCCOPY);
    finally
      Msk.Free;
      Mem.Free;
      Tmp.Free;
      ReleaseDC(Parent.Handle, ParentDC);
    end;
  end;
end;

procedure TGlassLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if AWidth < AHeight then
    AWidth := AHeight;
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TGlassLabel.SetTransparency(Value: TPercentage);
begin
  if FTransparency <> Value then
  begin
    FTransparency := Value;
    Invalidate;
  end;
end;

end.

生成上述内容的示例代码(在后台放置一个 TImage 控件):

procedure TForm1.FormCreate(Sender: TObject);
begin
  Font.Size := 16;
  Font.Color := $00A5781B;
  Font.Name := 'Calibri';
  Font.Style := [fsBold];
  with TGlassLabel.Create(Self) do
  begin
    SetBounds(40, 40, 550, 60);
    Color := $00271907;
    Caption := '395 Days, 22 Hours, 0 Minutes, 54 Seconds';
    Parent := Self;
  end;
  with TGlassLabel.Create(Self) do
  begin
    SetBounds(40, 40 + 119, 550, 60);
    Color := $00000097;
    Caption := '0 Days, 1 Hours, 59 Minutes, 31 Seconds';
    Parent := Self;
  end;
end;

随心所欲地调整。