德尔福定制绘图 – 发光玻璃

我一直在尝试一些玻璃图像,例如下面的图像,我开始认为必须有一种方法可以将它放入代码中,所以我可以将它染成任何我想要的颜色.它不需要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,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,255);
        TG:= EnsureRange(CG + (X * 4)+25,255);
        TB:= EnsureRange(CB + (X * 4)+25,255);
        C.Brush.Color:= RGB(TR,TB);
        C.RoundRect(R2.Left,Round(R2.Bottom / 1.5));
        R2.Left:= R2.Left + 2;
        R2.Right:= R2.Right - 2;
        R2.Bottom:= R2.Bottom - 1;
      end;
    end;
  end;
end;

解决方法

需要的成分：

> AlphaBlend为玻璃效果,
> GradientFill为顶部渐变椭圆,
> MaskBlt在绘图时排除非矩形已绘制的零件,
>确实有些数学,但很容易.

确实需要以小步骤分配绘图任务并按正确的顺序放置它们.那么这并不像最初看起来那么不可能.

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

>一个内存位图,在其上绘制所有内容以减少闪烁,
>临时位图,需要帮助,
>用于存储剪裁形状的掩码位图.

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

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.Right,R.Bottom);
    Msk.Canvas.FillRect(Rect(R.Left + Radius,R.Right - Radius,R.Bottom));
  end;

  procedure DrawTopGradientEllipse;
  begin
    GradientFill(Tmp.Canvas.Handle,R2,MixColor(Color,clWhite,1.0),0.2),True);
    PrepareMask(R2);
    MaskBlt(Mem.Canvas.Handle,W,H,Tmp.Canvas.Handle,Msk.Handle,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,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,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,ShadowFactor);
    DrawText(Mem.Canvas.Handle,PChar(Caption),-1,R3,DrawTextFlags);
    OffsetRect(R3,-Shadow,Shadow);
    Mem.Canvas.Font.Color := Font.Color;
    DrawText(Mem.Canvas.Handle,DrawTextFlags);
  end;

  procedure DrawBorderAlias;
  begin
    Mem.Canvas.Pen.Color := MixColor(Color,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,H);
    X := R1.Right - (R1.Bottom - R1.Top) div 2 - 2;
    Mem.Canvas.Arc(R1.Right - 1,R1.Right - R1.Bottom + R1.Top - 1,0);
  end;

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

  procedure DrawCombineParent;
  begin
    BitBlt(Tmp.Canvas.Handle,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,BlendFunc);
    PrepareMask(R0);
    MaskBlt(Mem.Canvas.Handle,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.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,Mem.Canvas.Handle,SRCCOPY);
    finally
      Msk.Free;
      Mem.Free;
      Tmp.Free;
      ReleaseDC(Parent.Handle,ParentDC);
    end;
  end;
end;

procedure TGlassLabel.SetBounds(ALeft,AHeight: Integer);
begin
  if AWidth < AHeight then
    AWidth := AHeight;
  inherited SetBounds(ALeft,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,60);
    Color := $00000097;
    Caption := '0 Days,1 Hours,59 Minutes,31 Seconds';
    Parent := Self;
  end;
end;

随你调整.

原文链接：https://www.f2er.com/delphi/102300.html

德尔福定制绘图 – 发光玻璃

解决方法

猜你在找的Delphi相关文章