home *** CD-ROM | disk | FTP | other *** search
/ PC World Plus! (NZ) 2001 June / HDC50.iso / Runimage / Delphi50 / Source / Samples / GAUGES.PAS < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  11KB  |  415 lines
  1. unit Gauges;
  2.  
  3. interface
  4.  
  5. uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls;
  6.  
  7. type
  8.  
  9.   TGaugeKind = (gkText, gkHorizontalBar, gkVerticalBar, gkPie, gkNeedle);
  10.  
  11.   TGauge = class(TGraphicControl)
  12.   private
  13.     FMinValue: Longint;
  14.     FMaxValue: Longint;
  15.     FCurValue: Longint;
  16.     FKind: TGaugeKind;
  17.     FShowText: Boolean;
  18.     FBorderStyle: TBorderStyle;
  19.     FForeColor: TColor;
  20.     FBackColor: TColor;
  21.     procedure PaintBackground(AnImage: TBitmap);
  22.     procedure PaintAsText(AnImage: TBitmap; PaintRect: TRect);
  23.     procedure PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
  24.     procedure PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
  25.     procedure PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
  26.     procedure PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
  27.     procedure SetGaugeKind(Value: TGaugeKind);
  28.     procedure SetShowText(Value: Boolean);
  29.     procedure SetBorderStyle(Value: TBorderStyle);
  30.     procedure SetForeColor(Value: TColor);
  31.     procedure SetBackColor(Value: TColor);
  32.     procedure SetMinValue(Value: Longint);
  33.     procedure SetMaxValue(Value: Longint);
  34.     procedure SetProgress(Value: Longint);
  35.     function GetPercentDone: Longint;
  36.   protected
  37.     procedure Paint; override;
  38.   public
  39.     constructor Create(AOwner: TComponent); override;
  40.     procedure AddProgress(Value: Longint);
  41.     property PercentDone: Longint read GetPercentDone;
  42.   published
  43.     property Align;
  44.     property Anchors;
  45.     property BackColor: TColor read FBackColor write SetBackColor default clWhite;
  46.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  47.     property Color;
  48.     property Constraints;
  49.     property Enabled;
  50.     property ForeColor: TColor read FForeColor write SetForeColor default clBlack;
  51.     property Font;
  52.     property Kind: TGaugeKind read FKind write SetGaugeKind default gkHorizontalBar;
  53.     property MinValue: Longint read FMinValue write SetMinValue default 0;
  54.     property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
  55.     property ParentColor;
  56.     property ParentFont;
  57.     property ParentShowHint;
  58.     property PopupMenu;
  59.     property Progress: Longint read FCurValue write SetProgress;
  60.     property ShowHint;
  61.     property ShowText: Boolean read FShowText write SetShowText default True;
  62.     property Visible;
  63.   end;
  64.  
  65. implementation
  66.  
  67. uses Consts;
  68.  
  69. type
  70.   TBltBitmap = class(TBitmap)
  71.     procedure MakeLike(ATemplate: TBitmap);
  72.   end;
  73.  
  74. { TBltBitmap }
  75.  
  76. procedure TBltBitmap.MakeLike(ATemplate: TBitmap);
  77. begin
  78.   Width := ATemplate.Width;
  79.   Height := ATemplate.Height;
  80.   Canvas.Brush.Color := clWindowFrame;
  81.   Canvas.Brush.Style := bsSolid;
  82.   Canvas.FillRect(Rect(0, 0, Width, Height));
  83. end;
  84.  
  85. { This function solves for x in the equation "x is y% of z". }
  86. function SolveForX(Y, Z: Longint): Longint;
  87. begin
  88.   Result := Longint(Trunc( Z * (Y * 0.01) ));
  89. end;
  90.  
  91. { This function solves for y in the equation "x is y% of z". }
  92. function SolveForY(X, Z: Longint): Longint;
  93. begin
  94.   if Z = 0 then Result := 0
  95.   else Result := Longint(Trunc( (X * 100.0) / Z ));
  96. end;
  97.  
  98. { TGauge }
  99.  
  100. constructor TGauge.Create(AOwner: TComponent);
  101. begin
  102.   inherited Create(AOwner);
  103.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  104.   { default values }
  105.   FMinValue := 0;
  106.   FMaxValue := 100;
  107.   FCurValue := 0;
  108.   FKind := gkHorizontalBar;
  109.   FShowText := True;
  110.   FBorderStyle := bsSingle;
  111.   FForeColor := clBlack;
  112.   FBackColor := clWhite;
  113.   Width := 100;
  114.   Height := 100;
  115. end;
  116.  
  117. function TGauge.GetPercentDone: Longint;
  118. begin
  119.   Result := SolveForY(FCurValue - FMinValue, FMaxValue - FMinValue);
  120. end;
  121.  
  122. procedure TGauge.Paint;
  123. var
  124.   TheImage: TBitmap;
  125.   OverlayImage: TBltBitmap;
  126.   PaintRect: TRect;
  127. begin
  128.   with Canvas do
  129.   begin
  130.     TheImage := TBitmap.Create;
  131.     try
  132.       TheImage.Height := Height;
  133.       TheImage.Width := Width;
  134.       PaintBackground(TheImage);
  135.       PaintRect := ClientRect;
  136.       if FBorderStyle = bsSingle then InflateRect(PaintRect, -1, -1);
  137.       OverlayImage := TBltBitmap.Create;
  138.       try
  139.         OverlayImage.MakeLike(TheImage);
  140.         PaintBackground(OverlayImage);
  141.         case FKind of
  142.           gkText: PaintAsNothing(OverlayImage, PaintRect);
  143.           gkHorizontalBar, gkVerticalBar: PaintAsBar(OverlayImage, PaintRect);
  144.           gkPie: PaintAsPie(OverlayImage, PaintRect);
  145.           gkNeedle: PaintAsNeedle(OverlayImage, PaintRect);
  146.         end;
  147.         TheImage.Canvas.CopyMode := cmSrcInvert;
  148.         TheImage.Canvas.Draw(0, 0, OverlayImage);
  149.         TheImage.Canvas.CopyMode := cmSrcCopy;
  150.         if ShowText then PaintAsText(TheImage, PaintRect);
  151.       finally
  152.         OverlayImage.Free;
  153.       end;
  154.       Canvas.CopyMode := cmSrcCopy;
  155.       Canvas.Draw(0, 0, TheImage);
  156.     finally
  157.       TheImage.Destroy;
  158.     end;
  159.   end;
  160. end;
  161.  
  162. procedure TGauge.PaintBackground(AnImage: TBitmap);
  163. var
  164.   ARect: TRect;
  165. begin
  166.   with AnImage.Canvas do
  167.   begin
  168.     CopyMode := cmBlackness;
  169.     ARect := Rect(0, 0, Width, Height);
  170.     CopyRect(ARect, Animage.Canvas, ARect);
  171.     CopyMode := cmSrcCopy;
  172.   end;
  173. end;
  174.  
  175. procedure TGauge.PaintAsText(AnImage: TBitmap; PaintRect: TRect);
  176. var
  177.   S: string;
  178.   X, Y: Integer;
  179.   OverRect: TBltBitmap;
  180. begin
  181.   OverRect := TBltBitmap.Create;
  182.   try
  183.     OverRect.MakeLike(AnImage);
  184.     PaintBackground(OverRect);
  185.     S := Format('%d%%', [PercentDone]);
  186.     with OverRect.Canvas do
  187.     begin
  188.       Brush.Style := bsClear;
  189.       Font := Self.Font;
  190.       Font.Color := clWhite;
  191.       with PaintRect do
  192.       begin
  193.         X := (Right - Left + 1 - TextWidth(S)) div 2;
  194.         Y := (Bottom - Top + 1 - TextHeight(S)) div 2;
  195.       end;
  196.       TextRect(PaintRect, X, Y, S);
  197.     end;
  198.     AnImage.Canvas.CopyMode := cmSrcInvert;
  199.     AnImage.Canvas.Draw(0, 0, OverRect);
  200.   finally
  201.     OverRect.Free;
  202.   end;
  203. end;
  204.  
  205. procedure TGauge.PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
  206. begin
  207.   with AnImage do
  208.   begin
  209.     Canvas.Brush.Color := BackColor;
  210.     Canvas.FillRect(PaintRect);
  211.   end;
  212. end;
  213.  
  214. procedure TGauge.PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
  215. var
  216.   FillSize: Longint;
  217.   W, H: Integer;
  218. begin
  219.   W := PaintRect.Right - PaintRect.Left + 1;
  220.   H := PaintRect.Bottom - PaintRect.Top + 1;
  221.   with AnImage.Canvas do
  222.   begin
  223.     Brush.Color := BackColor;
  224.     FillRect(PaintRect);
  225.     Pen.Color := ForeColor;
  226.     Pen.Width := 1;
  227.     Brush.Color := ForeColor;
  228.     case FKind of
  229.       gkHorizontalBar:
  230.         begin
  231.           FillSize := SolveForX(PercentDone, W);
  232.           if FillSize > W then FillSize := W;
  233.           if FillSize > 0 then FillRect(Rect(PaintRect.Left, PaintRect.Top,
  234.             FillSize, H));
  235.         end;
  236.       gkVerticalBar:
  237.         begin
  238.           FillSize := SolveForX(PercentDone, H);
  239.           if FillSize >= H then FillSize := H - 1;
  240.           FillRect(Rect(PaintRect.Left, H - FillSize, W, H));
  241.         end;
  242.     end;
  243.   end;
  244. end;
  245.  
  246. procedure TGauge.PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
  247. var
  248.   MiddleX, MiddleY: Integer;
  249.   Angle: Double;
  250.   W, H: Integer;
  251. begin
  252.   W := PaintRect.Right - PaintRect.Left;
  253.   H := PaintRect.Bottom - PaintRect.Top;
  254.   if FBorderStyle = bsSingle then
  255.   begin
  256.     Inc(W);
  257.     Inc(H);
  258.   end;
  259.   with AnImage.Canvas do
  260.   begin
  261.     Brush.Color := Color;
  262.     FillRect(PaintRect);
  263.     Brush.Color := BackColor;
  264.     Pen.Color := ForeColor;
  265.     Pen.Width := 1;
  266.     Ellipse(PaintRect.Left, PaintRect.Top, W, H);
  267.     if PercentDone > 0 then
  268.     begin
  269.       Brush.Color := ForeColor;
  270.       MiddleX := W div 2;
  271.       MiddleY := H div 2;
  272.       Angle := (Pi * ((PercentDone / 50) + 0.5));
  273.       Pie(PaintRect.Left, PaintRect.Top, W, H,
  274.         Integer(Round(MiddleX * (1 - Cos(Angle)))),
  275.         Integer(Round(MiddleY * (1 - Sin(Angle)))), MiddleX, 0);
  276.     end;
  277.   end;
  278. end;
  279.  
  280. procedure TGauge.PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
  281. var
  282.   MiddleX: Integer;
  283.   Angle: Double;
  284.   X, Y, W, H: Integer;
  285. begin
  286.   with PaintRect do
  287.   begin
  288.     X := Left;
  289.     Y := Top;
  290.     W := Right - Left;
  291.     H := Bottom - Top;
  292.     if FBorderStyle = bsSingle then
  293.     begin
  294.       Inc(W);
  295.       Inc(H);
  296.     end;
  297.   end;
  298.   with AnImage.Canvas do
  299.   begin
  300.     Brush.Color := Color;
  301.     FillRect(PaintRect);
  302.     Brush.Color := BackColor;
  303.     Pen.Color := ForeColor;
  304.     Pen.Width := 1;
  305.     Pie(X, Y, W, H * 2 - 1, X + W, PaintRect.Bottom - 1, X, PaintRect.Bottom - 1);
  306.     MoveTo(X, PaintRect.Bottom);
  307.     LineTo(X + W, PaintRect.Bottom);
  308.     if PercentDone > 0 then
  309.     begin
  310.       Pen.Color := ForeColor;
  311.       MiddleX := Width div 2;
  312.       MoveTo(MiddleX, PaintRect.Bottom - 1);
  313.       Angle := (Pi * ((PercentDone / 100)));
  314.       LineTo(Integer(Round(MiddleX * (1 - Cos(Angle)))),
  315.         Integer(Round((PaintRect.Bottom - 1) * (1 - Sin(Angle)))));
  316.     end;
  317.   end;
  318. end;
  319.  
  320. procedure TGauge.SetGaugeKind(Value: TGaugeKind);
  321. begin
  322.   if Value <> FKind then
  323.   begin
  324.     FKind := Value;
  325.     Refresh;
  326.   end;
  327. end;
  328.  
  329. procedure TGauge.SetShowText(Value: Boolean);
  330. begin
  331.   if Value <> FShowText then
  332.   begin
  333.     FShowText := Value;
  334.     Refresh;
  335.   end;
  336. end;
  337.  
  338. procedure TGauge.SetBorderStyle(Value: TBorderStyle);
  339. begin
  340.   if Value <> FBorderStyle then
  341.   begin
  342.     FBorderStyle := Value;
  343.     Refresh;
  344.   end;
  345. end;
  346.  
  347. procedure TGauge.SetForeColor(Value: TColor);
  348. begin
  349.   if Value <> FForeColor then
  350.   begin
  351.     FForeColor := Value;
  352.     Refresh;
  353.   end;
  354. end;
  355.  
  356. procedure TGauge.SetBackColor(Value: TColor);
  357. begin
  358.   if Value <> FBackColor then
  359.   begin
  360.     FBackColor := Value;
  361.     Refresh;
  362.   end;
  363. end;
  364.  
  365. procedure TGauge.SetMinValue(Value: Longint);
  366. begin
  367.   if Value <> FMinValue then
  368.   begin
  369.     if Value > FMaxValue then
  370.       if not (csLoading in ComponentState) then
  371.         raise EInvalidOperation.CreateFmt(SOutOfRange, [-MaxInt, FMaxValue - 1]);
  372.     FMinValue := Value;
  373.     if FCurValue < Value then FCurValue := Value;
  374.     Refresh;
  375.   end;
  376. end;
  377.  
  378. procedure TGauge.SetMaxValue(Value: Longint);
  379. begin
  380.   if Value <> FMaxValue then
  381.   begin
  382.     if Value < FMinValue then
  383.       if not (csLoading in ComponentState) then
  384.         raise EInvalidOperation.CreateFmt(SOutOfRange, [FMinValue + 1, MaxInt]);
  385.     FMaxValue := Value;
  386.     if FCurValue > Value then FCurValue := Value;
  387.     Refresh;
  388.   end;
  389. end;
  390.  
  391. procedure TGauge.SetProgress(Value: Longint);
  392. var
  393.   TempPercent: Longint;
  394. begin
  395.   TempPercent := GetPercentDone;  { remember where we were }
  396.   if Value < FMinValue then
  397.     Value := FMinValue
  398.   else if Value > FMaxValue then
  399.     Value := FMaxValue;
  400.   if FCurValue <> Value then
  401.   begin
  402.     FCurValue := Value;
  403.     if TempPercent <> GetPercentDone then { only refresh if percentage changed }
  404.       Refresh;
  405.   end;
  406. end;
  407.  
  408. procedure TGauge.AddProgress(Value: Longint);
  409. begin
  410.   Progress := FCurValue + Value;
  411.   Refresh;
  412. end;
  413.  
  414. end.
  415.