PC Pro 1999 March/DPPCPRO0399.ISO/Editor/Code.txt

Text File | 1998-12-18 | 11.6 KB | 394 lines

unit PCProgress;

interface

uses
    Wintypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    CommCtrl;

type
    TPCProgressOrientation = ( pbHorizontal, pbVertical );

    TPCProgressBar = class(TCustomControl)
    private
        { Private declarations }
    fLowRange: Integer;
    fHighRange: Integer;
    fPosition: Integer;
    fStep: Integer;
    fBarColor: TColor;
        fWholeBars: Boolean;
        fOrientation: TPCProgressOrientation;
        fSmooth: Boolean;
        fSpectrum: TBitmap;
        function GetSpectrumBar: Boolean;
        procedure SetSpectrumBar (Value: Boolean);
        procedure SetRangePos (Index, Value: Integer);
        procedure SetSmooth (Value: Boolean);
        procedure SetBarColor (Value: TColor);
        procedure SetWholeBars (Value: Boolean);
        procedure InitBitmap;
        procedure SetOrientation (Value: TPCProgressOrientation);
    protected
        { Protected declarations }
        procedure CreateParams (var Params: TCreateParams); override;
        procedure Loaded; override;
        procedure Paint; override;
    public
        { Public declarations }
        constructor Create (AOwner: TComponent); override;
        destructor Destroy; override;
    procedure StepIt;
        procedure StepBy (Delta: Integer);
    published
        { Published declarations }
        property OnDragDrop;
        property OnDragOver;
        property OnEndDrag;
        property OnMouseDown;
        property OnMouseMove;
        property OnMouseUp;
        {$IFDEF Ver120}
        property BorderWidth;
        {$ENDIF}
        property Color;
        property Align;
        property Enabled;
        property SpectrumBar: Boolean read GetSpectrumBar write SetSpectrumBar default False;
        property Min: Integer index 0 read fLowRange write SetRangePos default 0;
        property Max: Integer index 1 read fHighRange write SetRangePos default 100;
        property Position: Integer index 2 read fPosition write SetRangePos default 0;
        property Orientation: TPCProgressOrientation read fOrientation write SetOrientation default pbHorizontal;
        property Smooth: Boolean read fSmooth write SetSmooth default False;
        property Step: Integer read fStep write fStep default 10;
        property BarColor: TColor read fBarColor write SetBarColor default clHighlight;
        property WholeBars: Boolean read fWholeBars write SetWholeBars default True;
    end;

procedure Register;

implementation

uses Math;

function NanoMetresToRGB (NanoMetres: Integer; Brightness: Double): ColorRef;
var
    Red, Green, Blue, Factor: Double;

   function Adjust (Color, Factor: Double): Integer;
   const
       Gamma = 0.80;
   begin
       if Color = 0.0 then Result := 0 else
       Result := Round (255 * Power (Color * Factor * Brightness, Gamma));
    end;

begin
    Red := 0.0; Green := 0.0; Blue := 0.0;
    if Brightness > 1.0 then Brightness := 1.0;
    if Brightness < 0.0 then Brightness := 0.0;

    // Calculate relative RGB values
    case Trunc (NanoMetres) of
        380..439:   begin    // Ultra-violet to blue
                Red   := -(NanoMetres - 440) / (440 - 380);
                    Blue  := 1.0;
            end;

    440..489:   begin      // Blue to cyan
            Green := (NanoMetres - 440) / (490 - 440);
            Blue  := 1.0;
            end;

    490..509:   begin    // Cyan to green
            Green := 1.0;
            Blue  := -(NanoMetres - 510) / (510 - 490);
            end;

    510..579:   begin      // Green to yellow-orange
                Red   := (NanoMetres - 510) / (580 - 510);
            Green := 1.0;
            end;

    580..644:   begin      // Yellow-orange to full red
                Red   := 1.0;
                Green := -(NanoMetres - 645) / (645 - 580);
            end;

    645..780:   begin     // Full red from hereon....
                Red   := 1.0;
            Green := 0.0;
            end;
    end;

    // Condition RGB according to limits of vision
    case Trunc (NanoMetres) of
        380..419:  Factor := 0.3 + 0.7 * (NanoMetres - 380) / (420 - 380);
        420..700:  Factor := 1.0;
        701..780:  Factor := 0.3 + 0.7 * (780 - NanoMetres) / (780 - 700);
        else       Factor := 0.0;
    end;

    Result := RGB (Adjust (Red, Factor), Adjust (Green, Factor), Adjust (Blue, Factor));
end;

procedure BlitRect (dc: hDC; const R: TRect; Color: LongInt);                    { $BFEB5B72 }
begin
    Color := SetBkColor (dc, Color);
    ExtTextOut (dc, 0, 0, eto_Opaque, @R, Nil, 0, Nil);
    SetBkColor (dc, Color);
end;

{ TPCProgressBar }

constructor TPCProgressBar.Create (AOwner: TComponent);
begin
    Inherited Create (AOwner);
    fLowRange := 0; fHighRange := 100; fStep := 10;
    fWholeBars := True; fBarColor := clHighlight; fOrientation := pbHorizontal;
    Width := 150; Height := GetSystemMetrics (sm_cyVScroll);
end;

destructor TPCProgressBar.Destroy;
begin
    fSpectrum.Free;
    Inherited Destroy;
end;

procedure TPCProgressBar.CreateParams (var Params: TCreateParams);
begin
    Inherited CreateParams (Params);
    Params.ExStyle := (Params.ExStyle and (not ws_ex_ClientEdge)) or ws_ex_StaticEdge;
end;

procedure TPCProgressBar.Loaded;
var
    x: Integer;
begin
    Inherited Loaded;
    if fOrientation = pbVertical then begin
        x := Width;
        Width := Height;
        Height := x;
        InitBitmap;
    end;
end;

procedure TPCProgressBar.SetWholeBars (Value: Boolean);
begin
    if Value <> fWholeBars then begin
        fWholeBars := Value;
        Invalidate;
    end;
end;

procedure TPCProgressBar.SetSmooth (Value: Boolean);
begin
    if Value <> fSmooth then begin
        fSmooth := Value;
        Invalidate;
    end;
end;

procedure TPCProgressBar.SetBarColor (Value: TColor);
begin
    if Value <> fBarColor then begin
        fBarColor := Value;
        Invalidate;
    end;
end;

procedure TPCProgressBar.SetRangePos (Index, Value: Integer);

    procedure OutOfRange;
    begin
        raise EInvalidOperation.CreateFmt ('%s property out of range', [Self.Classname]);
    end;

begin
    case Index of
        0:     begin
                   if Value > fHighRange then OutOfRange;
                   fLowRange := Value;
                   Position := fPosition;  { Force repin of position }
               end;

        1:     begin
                   if Value < fLowRange then OutOfRange;
                   fHighRange := Value;
                   Position := fPosition;  { Force repin of position }
               end;

        2:     begin
                   if Value < fLowRange then Value := fLowRange;
                   if Value > fHighRange then Value := fHighRange;
                   fPosition := Value;
               end;
    end;

    if Index = 2 then Invalidate; { No point invalidating twice }
end;

procedure TPCProgressBar.SetOrientation (Value: TPCProgressOrientation);
var
    x: Integer;
begin
    if Value <> fOrientation then begin
        fOrientation := Value;
        x := Width;
        Width := Height;
        Height := x;
        Invalidate;
    end;
end;

procedure TPCProgressBar.Paint;
var
    SrcDC: hDC;
    hbm: HBitmap;
    cRect, boxRect: TRect;
    BlockLen, Count, physWidth, physRange, physPos, InterBlockGap: Integer;

    function CalcBoxSize (var r: TRect): Boolean;
    begin
        if fOrientation = pbVertical then begin
            r.Top := r.Bottom - BlockLen;
        Result := r.Bottom <= cRect.Top;
        if r.Top <= cRect.Top then r.Top := cRect.Top + 1;
            if (not fWholeBars) and (cRect.Bottom - r.Top > physPos) then r.Top := cRect.Bottom - physPos;
        end else begin
            r.Right := r.Left + BlockLen;
        Result := r.Left >= cRect.Right;
        if r.Right >= cRect.Right then r.Right := cRect.Right - 1;
            if (not fWholeBars) and (r.Right - cRect.Left > physPos) then r.Right := cRect.Left + physPos;
        end;
    end;

begin
    { Reinitialise the bitmap if necessary }
    if (fSpectrum <> Nil) and
        ((fSpectrum.Width <> Width) or (fSpectrum.Height <> Height))
            then InitBitmap;

    cRect := ClientRect;
    InflateRect (cRect, -1, -1);
    boxRect := cRect;

    if fOrientation = pbVertical then begin
        physWidth := cRect.Right - cRect.Left;
    physRange := cRect.Bottom - cRect.Top;
    end else begin
    physWidth := cRect.Bottom - cRect.Top;
    physRange := cRect.Right - cRect.Left;
    end;

    BlockLen := (physWidth * 2) div 3;
    if BlockLen = 0 then BlockLen := 1;
    physPos := MulDiv (physRange, fPosition - fLowRange, fHighRange - fLowRange);

    InterBlockGap := 2;
    if fSmooth then begin
    InterBlockGap := 0;
    BlockLen := 1;
    end;

    for Count := 0 to ((physPos + BlockLen + InterBlockGap - 1) div (BlockLen + InterBlockGap)) - 1 do begin
    if CalcBoxSize (boxRect) then break;

        if fSpectrum <> Nil then begin
            SrcDC := CreateCompatibleDC (0);
            hbm := SelectObject (SrcDC, fSpectrum.Handle);
            BitBlt (Canvas.Handle, boxRect.Left, boxRect.Top,
                    boxRect.Right - boxRect.Left,
                    boxRect.Bottom - boxRect.Top,
                    SrcDC, boxRect.Left, boxRect.Top, SrcCopy);
            SelectObject (SrcDC, hbm);
            DeleteDC (SrcDC);
        end else BlitRect (Canvas.Handle, boxRect, ColorToRGB (fBarColor));

    if fOrientation = pbVertical then
            boxRect.Bottom := boxRect.Top - InterBlockGap else boxRect.Left := boxRect.Right + InterBlockGap;
    end;
end;

procedure TPCProgressBar.StepIt;
begin
    Perform (pbm_StepIt, 0, 0);
end;

procedure TPCProgressBar.StepBy (Delta: Integer);
begin
    Perform (pbm_DeltaPos, Delta, 0);
end;

procedure TPCProgressBar.InitBitmap;
const
    fWaveMin = 380;
    fWaveMax = 780;
type
    pRGBArray = ^TRGBArray;
    TRGBArray = array [0..32767] of TRGBTriple;
var
    Row: pRGBArray;
    CurColor: TColor;
    Wavelength: Double;
    x, y: Integer;
begin
    if fSpectrum = Nil then fSpectrum := TBitmap.Create;
    fSpectrum.PixelFormat := pf24bit;
    fSpectrum.Width := Width;
    fSpectrum.Height := Height;

    if fOrientation = pbHorizontal then
        for x := 0 to Width - 1 do begin
            Wavelength := fWaveMin + (fWaveMax - fWaveMin) * x / Width;
            CurColor := NanoMetresToRGB (Trunc (Wavelength), 1.0);
            for y := 0 To Height - 1 do begin
                row := fSpectrum.Scanline [y];
                with row [x] do begin
                    rgbtRed   := GetRValue (CurColor);
                    rgbtGreen := GetGValue (CurColor);
                    rgbtBlue  := GetBValue (CurColor);
                end;
            end;
        end
    else
        for y := 0 to Height - 1 do begin
            WaveLength := fWaveMin + (fWaveMax - fWaveMin) * y / Height;
            CurColor := NanoMetresToRGB (Trunc (Wavelength), 1.0);
            row := fSpectrum.Scanline [y];
            for x := 0 to Width - 1 do
                with row [x] do begin
                    rgbtRed   := GetRValue (CurColor);
                    rgbtGreen := GetGValue (CurColor);
                    rgbtBlue  := GetBValue (CurColor);
                end;
        end;
end;

function TPCProgressBar.GetSpectrumBar: Boolean;
begin
    Result := fSpectrum <> Nil;
end;

procedure TPCProgressBar.SetSpectrumBar (Value: Boolean);
begin
    if Value <> GetSpectrumBar then begin
        if Value then InitBitmap else begin
            fSpectrum.Free;
            fSpectrum := Nil;
        end;
        Invalidate;
    end;
end;

procedure Register;
begin
    RegisterComponents ('PC Pro', [TPCProgressBar]);
end;

end.