vrsysutils.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrSysUtils;

{$I VRLIB.INC}

interface

uses
  Windows, Classes, SysUtils, Graphics, Controls, Messages,
  VrTypes, Forms;

type
  TVrGradDirection = (gdUpDown, gdLeftRight, gdChord1, gdChord2);


function SolveForX(Y, Z: Longint): Longint;

function SolveForY(X, Z: Longint): Longint;

procedure FreeObject(AObject: TObject);

function MinIntVal(X, Y: Integer): Integer;

function MaxIntVal(X, Y: Integer): Integer;

function InRange(Value, X, Y: Integer): boolean;

procedure AdjustRange(var Value: Integer; X, Y: Integer);

function Percent(a, b: Integer): Integer;

function WidthOf(const R: TRect): Integer;

function HeightOf(const R: TRect): Integer;

procedure AllocateBitmaps(var Items: array of TBitmap);

procedure DeallocateBitmaps(var Items: array of TBitmap);

function Color2RGB(Color: TColor): Longint;

function AdjustColor(Color: TColor; Value:Integer): TColor;

procedure ClearBitmapCanvas(R: TRect; Bitmap: TBitmap; Color: TColor);

procedure DrawShape(Canvas: TCanvas; Shape: TVrShapeType; X, Y, W, H: Integer);

procedure CalcTextBounds(Canvas: TCanvas; const Client: TRect;
  var TextBounds: TRect; const Caption: string);

procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; Enabled: Boolean);

function CreateDitherPattern(Light, Face: TColor): TBitmap;

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);

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

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

procedure GetRGB(Color: TColor; var R, G, B: Byte);

procedure DrawGradient(Canvas: TCanvas; const Rect: TRect; StartColor,
  TargetColor: TColor; Orientation: TVrOrientation; LineWidth: Integer);

procedure DrawGradientExt(Canvas: TCanvas; const Rect: TRect; StartColor,
  EndColor: TColor; Direction: TVrGradDirection; ColorWidth: Integer);

procedure CopyParentImage(Control: TControl; Dest: TCanvas);

function GetOwnerControl(Component: TComponent): TComponent;

procedure SetCanvasTextAngle(Canvas: TCanvas; Angle: Word);

procedure CanvasTextOutAngle(Canvas: TCanvas; X, Y: Integer;
  Angle: Word; const Text: string);

function GetTextSize(Canvas: TCanvas; const Text: string): TPoint;

procedure Draw3DText(Canvas: TCanvas; X, Y: Integer; const Text: String;
  HighEdge, LowEdge: TColor);

procedure DrawShadowTextExt(Canvas: TCanvas; X, Y : Integer;
  const Text: string; ShadowColor: TColor; SX, SY: Integer);

procedure StretchPaintOnText(Dest: TCanvas; DestRect: TRect; X, Y: Integer;
  const Text: string; Bitmap: TBitmap; Angle: Word);

procedure DrawOutlinedText(Canvas: TCanvas; X, Y : Integer;
  const Text: string; Color: TColor; Depth: Integer);

procedure DrawRasterPattern(Canvas: TCanvas; Rect: TRect;
  ForeColor, BackColor: TColor; PixelSize, Spacing: Integer);

procedure StretchPaintOnRasterPattern(Dest: TCanvas; Rect: TRect; Image: TBitmap;
  ForeColor, BackColor: TColor; PixelSize, Spacing: Integer);

procedure BitmapToLCD(Dest: TBitmap; Source: TBitmap;
  ForeColor, BackColor: TColor; PixelSize, Spacing: Integer);

procedure DrawTiledBitmap(Canvas: TCanvas; const Rect: TRect; Glyph: TBitmap);

function BitmapRect(Bitmap: TBitmap): TRect;

procedure ChangeBitmapColor(Bitmap: TBitmap; FromColor, ToColor: TColor);

procedure DrawBitmap(Canvas: TCanvas; DestRect: TRect;
  Bitmap: TBitmap; SourceRect: TRect; Transparent: Boolean; TransColor: TColor);


implementation

{ This function solves for x in the equation "x is y% of z". }
function SolveForX(Y, Z: Longint): Longint;
begin
  Result := Trunc( Z * (Y * 0.01) );
end;

{ This function solves for y in the equation "x is y% of z". }
function SolveForY(X, Z: Longint): Longint;
begin
  if Z = 0 then Result := 0
  else Result := Trunc( (X * 100.0) / Z );
end;

{$HINTS OFF}
procedure FreeObject(AObject: TObject);
begin
  if AObject <> nil then
  begin
    AObject.Free;
    AObject := nil;
  end;
end;
{$HINTS ON}

function MinIntVal(X, Y: Integer): Integer;
begin
  Result := X;
  if X > Y then Result := Y;
end;

function MaxIntVal(X, Y: Integer): Integer;
begin
  Result := Y;
  if X > Y then Result := X;
end;

function InRange(Value, X, Y: Integer): boolean;
begin
  Result := (Value >= X) and (Value <= Y);
end;

procedure AdjustRange(var Value: Integer; X, Y: Integer);
begin
  if Value < X then Value := X
  else if Value > Y then Value := Y;
end;

function Percent(a, b: Integer): Integer;
begin
  Result := Trunc((a / b)*100);
end;

function WidthOf(const R: TRect): Integer;
begin
  Result := R.Right - R.Left;
end;

function HeightOf(const R: TRect): Integer;
begin
  Result := R.Bottom - R.Top;
end;

procedure AllocateBitmaps(var Items: array of TBitmap);
var
  I: Integer;
begin
  for I := Low(Items) to High(Items) do
    Items[I] := TBitmap.Create;
end;

procedure DeallocateBitmaps(var Items: array of TBitmap);
var
  I: Integer;
begin
  for I := Low(Items) to High(Items) do
    if Items[I] <> nil then
    begin
      Items[I].Free;
      Items[I] := nil;
    end;
end;

type
  TRGBMap = packed record
    case boolean of
      TRUE:  (RGBVal: DWORD);
      FALSE: (Red, Green, Blue, Unused: byte);
  end;

  TParentControl = class(TWinControl);


{ CorrectColor }
function CorrectColor(C: Real) : Integer;
begin
  Result := Round(C);
  if Result > 255 then Result := 255
  else if Result < 0 then Result := 0;
end;

{ ERGB }
function ERGB(R, G, B: Real): TColor;
begin
  Result := RGB(CorrectColor(R), CorrectColor(G), CorrectColor(B));
end;

{ Color2RGB }
function Color2RGB(Color: TColor): Longint;
begin
  if Color < 0 then
    Result := GetSysColor(Color and $000000FF)
  else Result := Color;
end;

{ AdjustColor }
function AdjustColor(Color: TColor; Value:Integer): TColor;
var
  R, G, B: integer;
begin
  R := GetRValue(ColorToRGB(Color));
  G := GetGValue(ColorToRGB(Color));
  B := GetBValue(ColorToRGB(Color));
  if Value > 0 then
  begin
    if R + Value > 255 then R := 254 else Inc(R, Value);
    if G + Value > 255 then G := 254 else Inc(G, Value);
    if B + Value > 255 then B := 254 else Inc(B, Value);
  end else
  begin
    if R + Value < 0 then R := 1 else Inc(R, Value);
    if G + Value < 0 then G := 1 else Inc(G, Value);
    if B + Value < 0 then B := 1 else Inc(B, Value);
  end;
  Result := RGB(R, G, B);
end;

{ DrawGradientHorizontal }
procedure DrawGradientHorizontal(Canvas: TCanvas; const Rect: TRect;
  R1, G1, B1, R2, G2, B2: Integer; LineWidth: Integer);
var
  R, G, B: Real;
  Width, Height, I: Integer;
  ColorRect: TRect;
begin
  Width := WidthOf(Rect);
  Height := HeightOf(Rect);
  ColorRect := Bounds(Rect.Left, Rect.Top, LineWidth, Height);
  R := R1; G := G1; B := B1;
  I := 0;
  while I <= Width do
  begin
    Canvas.Brush.Color := ERGB(R, G, B);
    Canvas.FillRect(ColorRect);
    OffsetRect(ColorRect, LineWidth, 0);
    Inc(I, LineWidth);
    R := R + R2 / Width * LineWidth;
    G := G + G2 / Width * LineWidth;
    B := B + B2 / Width * LineWidth;
  end;
end;

{ DrawGradientVertical }
procedure DrawGradientVertical(Canvas: TCanvas; const Rect: TRect;
  R1, G1, B1, R2, G2, B2: Integer; LineWidth: Integer);
var
  R, G, B: Real;
  Width, Height, I: Integer;
  ColorRect: TRect;
begin
  Width := WidthOf(Rect);
  Height := HeightOf(Rect);
  ColorRect := Bounds(Rect.Left, Rect.Top, Width, LineWidth);
  R := R1; G := G1; B := B1;
  I := 0;
  while I <= Height do
  begin
    Canvas.Brush.Color := ERGB(R, G, B);
    Canvas.FillRect(ColorRect);
    OffsetRect(ColorRect, 0, LineWidth);
    Inc(I, LineWidth);
    R := R + R2 / Height * LineWidth;
    G := G + G2 / Height * LineWidth;
    B := B + B2 / Height * LineWidth;
  end;
end;

{ DrawGradient }
procedure DrawGradient(Canvas: TCanvas; const Rect: TRect; StartColor,
  TargetColor: TColor; Orientation: TVrOrientation; LineWidth: Integer);
var
  R1,G1,B1: Integer;
  R2,G2,B2: Integer;
begin
  //Implement Top Color
  StartColor := Color2RGB(StartColor);
  R1 := GetRValue(StartColor);
  G1 := GetGValue(StartColor);
  B1 := GetBValue(StartColor);

  //Implement Bottom Color
  TargetColor := Color2RGB(TargetColor);
  R2 := GetRValue(TargetColor) - R1;
  G2 := GetGValue(TargetColor) - G1;
  B2 := GetBValue(TargetColor) - B1;

  case Orientation of
    voVertical:
     DrawGradientVertical(Canvas, Rect, R1, G1, B1, R2, G2, B2, LineWidth);
    voHorizontal:
     DrawGradientHorizontal(Canvas, Rect, R1, G1, B1, R2, G2, B2, LineWidth);
  end;
end;

procedure GetRGB(Color: TColor; var R, G, B: Byte);
begin
  Color := Color2RGB(Color);
  R := GetRValue(Color);
  G := GetGValue(Color);
  B := GetBValue(Color);
end;

procedure DrawGradientExt(Canvas: TCanvas; const Rect: TRect; StartColor,
  EndColor: TColor; Direction: TVrGradDirection; ColorWidth: Integer);
var
  I, LoopEnd: Integer;
  ColorRect: TRect;
  R, G, B: Byte;
  R1, G1, B1, R2, G2, B2: Byte;
  P: TPoint;
  DC: HDC;
begin
  P.X := WidthOf(Rect);
  P.Y := HeightOf(Rect);
  GetRGB(StartColor, R1, G1, B1);
  GetRGB(EndColor, R2, G2, B2);

  case Direction of
  gdLeftRight:
    begin
      ColorRect := Bounds(Rect.Left, Rect.Top, ColorWidth, P.Y);
      I := 0;
      while I <= P.X do
      begin
        R := R1 + I * (R2 - R1) div P.X;
        G := G1 + I * (G2 - G1) div P.X;
        B := B1 + I * (B2 - B1) div P.X;
        Canvas.Brush.Color := RGB(R, G, B);
        FillRect(Canvas.Handle, ColorRect, Canvas.Brush.Handle);
        OffsetRect(ColorRect, ColorWidth, 0);
        Inc(I, ColorWidth);
      end;
    end;
  gdUpDown:
    begin
      ColorRect := Bounds(Rect.Left, Rect.Top, P.X, ColorWidth);
      I := 0;
      while I <= P.Y do
      begin
        R := R1 + I * (R2 - R1) div P.Y;
        G := G1 + I * (G2 - G1) div P.Y;
        B := B1 + I * (B2 - B1) div P.Y;
        Canvas.Brush.Color := RGB(R, G, B);