vrsysutils.pas

作工控的好控件

        FillRect(Canvas.Handle, ColorRect, Canvas.Brush.Handle);
        OffsetRect(ColorRect, 0, ColorWidth);
        Inc(I, ColorWidth);
      end;
    end;
  gdChord1:
    begin
      LoopEnd := P.X + P.Y;
      I := 0;
      Canvas.Pen.Width := ColorWidth;
      while I <= LoopEnd do
      begin
        R := R1 + I * (R2 - R1) div LoopEnd;
        G := G1 + I * (G2 - G1) div LoopEnd;
        B := B1 + I * (B2 - B1) div LoopEnd;
        Canvas.Pen.Color := RGB(R, G, B);
        DC := Canvas.Handle;
        MoveToEx(DC, I, 0, nil);
        LineTo(DC, -1, I);
        Inc(I, ColorWidth);
      end;
    end;
  gdChord2:
    begin
      LoopEnd := P.X + P.Y;
      I := 0;
      Canvas.Pen.Width := ColorWidth;
      while I <= LoopEnd do
      begin
        R := R1 + I *(R2 - R1) div LoopEnd;
        G := G1 + I *(G2 - G1) div LoopEnd;
        B := B1 + I *(B2 - B1) div LoopEnd;
        Canvas.Pen.Color := RGB(R, G, B);
        DC := Canvas.Handle;
        MoveToEx(DC, 0, P.Y - I, nil);
        LineTo(DC, I, P.Y);
        Inc(I, ColorWidth);
      end;
    end;
  end; //case
end;

{ DrawShape }
procedure DrawShape(Canvas: TCanvas; Shape: TVrShapeType; X, Y, W, H: Integer);
var
  S: Integer;
begin
  with Canvas do
  begin
    if Pen.Width = 0 then
    begin
      Dec(W);
      Dec(H);
    end;
    if W < H then S := W else S := H;
    if Shape in [stSquare, stRoundSquare, stCircle] then
    begin
      Inc(X, (W - S) div 2);
      Inc(Y, (H - S) div 2);
      W := S;
      H := S;
    end;
    case Shape of
      stRectangle, stSquare:
        Rectangle(X, Y, X + W, Y + H);
      stRoundRect, stRoundSquare:
        RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
      stCircle, stEllipse:
        Ellipse(X, Y, X + W, Y + H);
    end;
  end;
end;

{ CalcTextBounds }
procedure CalcTextBounds(Canvas: TCanvas; const Client: TRect;
  var TextBounds: TRect; const Caption: string);
var
  X, Y: Integer;
  TextSize: TPoint;
begin
  TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
  DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT);
  TextSize := Point(TextBounds.Right - TextBounds.Left,
    TextBounds.Bottom - TextBounds.Top);

  X := (WidthOf(Client) - TextSize.X + 1) div 2;
  Y := (HeightOf(Client) - TextSize.Y + 1) div 2;
  OffsetRect(TextBounds, Client.Left + X, Client.Top + Y);
end;

{ DrawButtonText }
procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; Enabled: Boolean);
begin
  with Canvas do
  begin
    Brush.Style := bsClear;
    if not Enabled then
    begin
      OffsetRect(TextBounds, 1, 1);
      Font.Color := clBtnHighlight;
      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
      OffsetRect(TextBounds, -1, -1);
      Font.Color := clBtnShadow;
      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
    end else
      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
        DT_CENTER or DT_VCENTER or DT_SINGLELINE);
  end;
end;

{ ClearBitmapCanvas }
procedure ClearBitmapCanvas(R: TRect; Bitmap: TBitmap; Color: TColor);
begin
  Bitmap.Width := WidthOf(R);
  Bitmap.Height := HeightOf(R);
  with Bitmap.Canvas do
  begin
    Brush.Color := Color;
    Brush.Style := bsSolid;
    FillRect(R);
  end;
end;

{ CreateDitherPattern }
function CreateDitherPattern(Light, Face: TColor): TBitmap;
var
  X, Y: Integer;
begin
  Result := TBitmap.Create;
  Result.Width := 8;
  Result.Height := 8;
  with Result.Canvas do
  begin
    Brush.Color := Face;
    Brush.Style := bsSolid;
    FillRect(Rect(0, 0, Result.Width, Result.Height));
    for Y := 0 to 7 do
      for X := 0 to 7 do
        if (Y mod 2) = (X mod 2) then Pixels[X, Y] := Light;
  end;
end;

{ CalcImageTextLayout }
procedure CalcImageTextLayout(Canvas: TCanvas; const Client: TRect;
  const Offset: TPoint; const Caption: string; Layout: TVrImageTextLayout;
  Margin, Spacing: Integer; ImageSize: TPoint; var ImagePos: TPoint;
  var TextBounds: TRect);
var
  TextPos: TPoint;
  ClientSize, TextSize: TPoint;
  TotalSize: TPoint;
begin
  ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
    Client.Top);

  if Length(Caption) > 0 then
  begin
    TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
    DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT);
    TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
      TextBounds.Top);
  end
  else
  begin
    TextBounds := Rect(0, 0, 0, 0);
    TextSize := Point(0,0);
  end;

  if Layout in [ImageLeft, ImageRight] then
  begin
    ImagePos.Y := (ClientSize.Y - ImageSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else
  begin
    ImagePos.X := (ClientSize.X - ImageSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  end;

  if (TextSize.X = 0) or (ImageSize.X = 0) then
    Spacing := 0;

  if Margin = -1 then
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(ImageSize.X + TextSize.X, ImageSize.Y + TextSize.Y);
      if Layout in [ImageLeft, ImageRight] then
        Margin := (ClientSize.X - TotalSize.X) div 3
      else
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      Spacing := Margin;
    end
    else
    begin
      TotalSize := Point(ImageSize.X + Spacing + TextSize.X, ImageSize.Y +
        Spacing + TextSize.Y);
      if Layout in [ImageLeft, ImageRight] then
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      else
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
    end;
  end
  else
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(ClientSize.X - (Margin + ImageSize.X), ClientSize.Y -
        (Margin + ImageSize.Y));
      if Layout in [ImageLeft, ImageRight] then
        Spacing := (TotalSize.X - TextSize.X) div 2
      else
        Spacing := (TotalSize.Y - TextSize.Y) div 2;
    end;
  end;

  case Layout of
    ImageLeft:
      begin
        ImagePos.X := Margin;
        TextPos.X := ImagePos.X + ImageSize.X + Spacing;
      end;
    ImageRight:
      begin
        ImagePos.X := ClientSize.X - Margin - ImageSize.X;
        TextPos.X := ImagePos.X - Spacing - TextSize.X;
      end;
    ImageTop:
      begin
        ImagePos.Y := Margin;
        TextPos.Y := ImagePos.Y + ImageSize.Y + Spacing;
      end;
    ImageBottom:
      begin
        ImagePos.Y := ClientSize.Y - Margin - ImageSize.Y;
        TextPos.Y := ImagePos.Y - Spacing - TextSize.Y;
      end;
  end;

  with ImagePos do
  begin
    Inc(X, Client.Left + Offset.X);
    Inc(Y, Client.Top + Offset.Y);
  end;
  OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X,
    TextPos.Y + Client.Top + Offset.X);
end;

{ Draw3DOutline - BottomLeft.X correction disabled }
procedure DrawOutline3D(Canvas: TCanvas; var Rect: TRect;
  TopColor, BottomColor: TColor; Width: Integer);

  procedure DoRect;
  var
    TopRight, BottomLeft: TPoint;
  begin
    with Canvas, Rect do
    begin
      TopRight.X := Right;
      TopRight.Y := Top;
      BottomLeft.X := Left;
      BottomLeft.Y := Bottom;
      Pen.Color := TopColor;
      PolyLine([BottomLeft, TopLeft, TopRight]);
      Pen.Color := BottomColor;
      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom); Dec(Rect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(Rect, -1, -1);
  end;
  Inc(Rect.Bottom); Inc(Rect.Right);
end;

{ DrawFrame3D }
procedure DrawFrame3D(Canvas: TCanvas; var Rect: TRect;
  TopColor, BottomColor: TColor; Width: Integer);

  procedure DoRect;
  var
    TopRight, BottomLeft: TPoint;
  begin
    with Canvas, Rect do
    begin
      TopRight.X := Right;
      TopRight.Y := Top;
      BottomLeft.X := Left;
      BottomLeft.Y := Bottom;
      Pen.Color := TopColor;
      PolyLine([BottomLeft, TopLeft, TopRight]);
      Pen.Color := BottomColor;
      Dec(BottomLeft.X);
      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom); Dec(Rect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(Rect, -1, -1);
  end;
  Inc(Rect.Bottom); Inc(Rect.Right);
end;

procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do
    begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      with TParentControl(Control.Parent) do
      begin
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    { Copy images of graphic controls }
    for I := 0 to Count - 1 do begin
      if Control.Parent.Controls[I] = Control then Break
      else if (Control.Parent.Controls[I] <> nil) and
        (Control.Parent.Controls[I] is TGraphicControl) then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do
        begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
          begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, WidthOf(R), HeightOf(R));
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end;
    end;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;

{ GetOwnerControl }
function GetOwnerControl(Component: TComponent): TComponent;
var
  AOwner: TComponent;
begin
  Result := nil;
  AOwner := Component.Owner;
  while (AOwner <> nil) and (AOwner is TWinControl) do
  begin
    Result := AOwner;
    AOwner := Result.Owner;
  end;