PC Pro 1995 December/PCPRO_1295.ISO/code/prog/listing.txt

Text File | 1995-10-09 | 6.4 KB | 255 lines

unit Progress;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls;

type
  TBevelWidth = 1..MaxInt;
  TBorderWidth = 0..MaxInt;
  TPanelBevel = (bvNone, bvLowered, bvRaised);

  TProgress = class(TCustomControl)
  private
    { Private declarations }
    FMin, FMax, FPosition: Integer;
    FProgressColor: TColor;
    FBevelInner: TPanelBevel;
    FBevelOuter: TPanelBevel;
    FBevelWidth: TBevelWidth;
    FBorderStyle: TBorderStyle;
    FBorderWidth: TBorderWidth;
    procedure SetBevelInner(Value: TPanelBevel);
    procedure SetBevelOuter(Value: TPanelBevel);
    procedure SetBevelWidth(Value: TBevelWidth);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetBorderWidth(Value: TBorderWidth);
    procedure SetProgressColor (Value: TColor);
    procedure SetMin (Value: Integer);
    procedure SetMax (Value: Integer);
    procedure SetPosition (Value: Integer);

  protected
    { Protected declarations }
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;

  published
    { Published declarations }
    property BevelInner: TPanelBevel read FBevelInner
    write SetBevelInner default bvNone;
    property BevelOuter: TPanelBevel read FBevelOuter
    write SetBevelOuter default bvLowered;
    property BevelWidth: TBevelWidth read FBevelWidth
    write SetBevelWidth default 2;
    property BorderStyle: TBorderStyle read FBorderStyle
    write SetBorderStyle default bsNone;
    property BorderWidth: TBorderWidth read FBorderWidth
    write SetBorderWidth default 0;
    property Min: Integer read FMin
    write SetMin default 0;
    property Max: Integer read FMax
    write SetMax default 100;
    property Position: Integer read FPosition
    write SetPosition default 50;
    property ProgressColor: TColor read FProgressColor
    write SetProgressColor default clNavy;

    property Color default clBtnFace;
    property ParentColor default True;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property Visible;

  public
    { Public declarations }
    constructor Create (AOwner: TComponent); override;
    procedure SetParams (APosition, AMin, AMax: Integer);

  end;

procedure Register;

implementation

constructor TProgress.Create (AOwner: TComponent);
begin
    inherited Create (AOwner);

    Height := (GetSystemMetrics (sm_CYHScroll) * 4) div 3;
    if Height < 4 then Height := 4;
    Width := Height * 6;

    BevelOuter := bvLowered;
    BevelWidth := 2;
    FBorderStyle := bsNone;
    FProgressColor := clNavy;
    FBorderWidth := 0;
    ParentColor := True;
    Color := clBtnFace;
    TabStop := True;
    FMin := 0;
    FMax := 100;
    FPosition := 50;
 end;

procedure TProgress.SetBevelInner(Value: TPanelBevel);
begin
  FBevelInner := Value;
  Invalidate;
end;

procedure TProgress.SetBevelOuter(Value: TPanelBevel);
begin
  FBevelOuter := Value;
  Invalidate;
end;

procedure TProgress.SetBevelWidth(Value: TBevelWidth);
begin
  FBevelWidth := Value;
  Invalidate;
end;

procedure TProgress.SetProgressColor (Value: TColor);
begin
  if FProgressColor <> Value then
  begin
      FProgressColor := Value;
      Invalidate;
  end;
end;

procedure TProgress.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TProgress.SetBorderWidth(Value: TBorderWidth);
begin
  FBorderWidth := Value;
  Invalidate;
end;

procedure TProgress.CreateParams(var Params: TCreateParams);
const
    BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);

begin
    inherited CreateParams(Params);

    with Params do
    begin
        WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW;
        Style := Style or BorderStyles [FBorderStyle];
    end;
end;

procedure TProgress.Paint;
var
  BoxCount, BoxWidth: Integer;
  BoxRect, Rect: TRect;
  TopColor, BottomColor: TColor;

  procedure AdjustColors (Bevel: TPanelBevel);
  begin
     TopColor := clBtnHighlight;
     if Bevel = bvLowered then TopColor := clBtnShadow;
     BottomColor := clBtnShadow;
     if Bevel = bvLowered then BottomColor := clBtnHighlight;
  end;

begin
    Rect := GetClientRect;

    if BevelOuter <> bvNone then
    begin
        AdjustColors (BevelOuter);
        Frame3D (Canvas, Rect, TopColor, BottomColor, BevelWidth);
    end;

    Frame3D (Canvas, Rect, Color, Color, BorderWidth);

    if BevelInner <> bvNone then
    begin
        AdjustColors (BevelInner);
        Frame3D (Canvas, Rect, TopColor, BottomColor, BevelWidth);
    end;

    with Canvas do
    begin
        Brush.Color := Color;
        FillRect (Rect);
        InflateRect (Rect, -2, -2);
        BoxRect := Rect;
        boxWidth := ((Rect.bottom - Rect.top) * 2) div 3;
        if boxWidth <= 0 then boxWidth := 1;
        BoxCount := (MulDiv (Rect.right - Rect.left,
        Position - Min, Max - Min) + boxWidth + 1) div (boxWidth + 2);
        SetBkColor (Canvas.Handle, FProgressColor);

        while BoxCount > 0 do
        begin
            BoxRect.right := BoxRect.left + boxWidth;
            if BoxRect.right < Rect.right then
            begin
                ExtTextOut (Canvas.Handle, 0, 0, eto_Opaque, @BoxRect, Nil, 0, Nil);
            end;

            BoxRect.left := BoxRect.right + 2;
            Dec (BoxCount);
        end;
    end;
end;

procedure TProgress.SetPosition (Value: Integer);
begin
    SetParams (Value, FMin, FMax);
end;

procedure TProgress.SetMin (Value: Integer);
begin
    SetParams (FPosition, Value, FMax);
end;

procedure TProgress.SetMax (Value: Integer);
begin
    SetParams (FPosition, FMin, Value);
end;

procedure TProgress.SetParams (APosition, AMin, AMax: Integer);
begin
    if AMax < AMin then raise EInvalidOperation.Create('Max less than Min.');

    if APosition < AMin then APosition := AMin;
    if APosition > AMax then APosition := AMax;

    if (FMin <> AMin) or (FMax <> AMax) then
    begin
        FMin := AMin;
        FMax := AMax;
        Invalidate;
    end;

    if FPosition <> APosition then
    begin
        FPosition := APosition;
        Invalidate;
    end;
end;

procedure Register;
begin
  RegisterComponents('Pilgrim''s Progress', [TProgress]);
end;

end.