Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/panclock/panclock.pas

Pascal/Delphi Source File | 1995-12-22 | 14.6 KB | 451 lines

{$A+,B-,D+,F-,G+,I+,K+,L+,N+,P+,Q-,R-,S-,T-,V+,W-,X+,Y+}
{$M 16384,8192}
{*****************************************************************************}
{                                                                             }
{ TPanelClock - a VCL component that is provides time-of-date, NUM, CAPS, and }
{   Scroll Key Statuses. When you click on this component (at run-time), it   }
{   will switch to showing free GDI, System, and User Resources. Source code  }
{   documentation is rather limited, with the exception of the rather arcane  }
{   properties which as described below. This component (such as it is) is    }
{   hereby given to the public domain. Should you find it useful at some      }
{   point in your programming career, please feel obligated to donate one of  }
{   your own equally useful components to the public domain. If you have any  }
{   suggestions for improvements, or if you find any bugs, please notify the  }
{   author (but please be gentle - this is my first component). Thank-you.    }
{                                                                             }
{  Author: Cameron D. Peters                                                  }
{          Suite 311, 908 - 17th Avenue S.W.                                  }
{          Calgary, Alberta CANADA                                            }
{          CIS: 72561,3146                                                    }
{          Phone: [phone]                                                }
{          Fax: [phone]                                                  }
{                                                                             }
{  Revision History:                                                          }
{    1.00  CDP  950525  Created                                               }
{                                                                             }
{  Installation                                                               }
{    Use Tools|Install Components to add this to your VCL. TPanelClock will   }
{    be added to the additional page of your component palette.               }
{                                                                             }
{  Properties                                                                 }
{    I haven't created an on-line help file for this component, because I     }
{    don't really have the time, or possibly because I am just lazy. Perhaps  }
{    I'll create one if enough people download this file as it is! Anyways,   }
{    here are my notes on the properties which were not inherited (in no      }
{    particular order):                                                       }
{                                                                             }
{    PanelMode - can be pmClock or pmResources. When it's pmClock, the        }
{      component shows the time-of-day, and the status of NUM, CAPS, and      }
{      SCRL. When it's pmResources, it will show the percentage of free       }
{      GDI, USER and System Resources.                                        }
{    AllowClick - when this is true, the user can click on the component      }
{      to switch back and forth between the clock and the resource monitor.   }
{    AlertLevel - if any of the resources fall below this level, they will    }
{      be shown using the AlertFont.                                          }
{    AlertFont - font used to display resources which have fallen below the   }
{      AlertLevel.                                                            }
{    AlertMatchFont - when this is true, the AlertFont will be made to match  }
{      the Font, with the exception that the color of the AlertFont will be   }
{      set to clRed.                                                          }
{    Spaces - the number of pixels of space between sections of the panel.    }
{    ClockWidth - the width of the clock in pixels.                           }
{                                                                             }
{*****************************************************************************}

unit PanClock;

interface

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

const
  {Key statuses}
  ksNumberOfKeyStatuses = 3;
  ksNumLock = 1;
  ksCapsLock = 2;
  ksScrollLock = 4;

  {Resource Monitors}
  rmNumberOfMonitors = 3;
  rmGDIResources = 1;
  rmSystemResources = 2;
  rmUserResources = 3;

type
  TResourceMonitor = array[rmGDIResources..rmUserResources] of integer;
  TPanelMode = (pmClock,pmResources);
  TPanelClock = class(TCustomControl)
  private
    { Private declarations }
    FAlertFont: TFont;
    FAlertLevel: Integer;
    FAlertMatchFont: Boolean;
    FAllowClick: Boolean;
    FBevel: TPanelBevel;
    FBevelWidth: Integer;
    FClockWidth: Integer;
    FHint2: String;
    FKeyState: Integer;
    FLastPaint: String[20];
    FPanelMode: TPanelMode;
    FSpace: Integer;
    FResources: TResourceMonitor;
  protected
    { Protected declarations }
    procedure Click; override;
    procedure Paint; override;
    procedure SetAlertFont(Value: TFont);
    procedure SetAlertLevel(Value: Integer);
    procedure SetAlertMatchFont(Value: Boolean);
    procedure SetBevel(Value: TPanelBevel);
    procedure SetBevelWidth(Value: Integer);
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure SetClockWidth(Value: Integer);
    procedure SetPanelMode(Value: TPanelMode);
    procedure SetSpace(Value: Integer);
    procedure WMDestroy(var Msg: TMsg); message WM_Destroy;
    procedure WMCreate(var Msg: TMsg); message WM_Create;
    procedure WMTimer(var Msg: TMsg); message WM_Timer;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    property AlertFont: TFont read FAlertFont write SetAlertFont;
    property AlertLevel: Integer read FAlertLevel write SetAlertLevel default 20;
    property AlertMatchFont: Boolean read FAlertMatchFont write SetAlertMatchFont default TRUE;
    property Align;
    property AllowClick: Boolean read FAllowClick write FAllowClick default TRUE;
    property Bevel: TPanelBevel read FBevel write SetBevel default bvLowered;
    property BevelWidth: Integer read FBevelWidth write SetBevelWidth default 1;
    property ClockWidth: Integer read FClockWidth write SetClockWidth default 96;
    property Color;
    property Enabled;
    property Font;
    property Height default 16;
    property Hint;
    property Hint2: String read FHint2 write FHint2;
    property PanelMode: TPanelMode read FPanelMode write SetPanelMode default pmClock;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property Space: Integer read FSpace write SetSpace default 1;
    property Width default 219;
  end;

procedure Register;

implementation


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

begin
  if (X < Y)
    then Result := X
    else Result := Y;
end;


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

begin
  if (X > Y)
    then Result := X
    else Result := Y;
end;


procedure Register;
begin
  RegisterComponents('Additional', [TPanelClock]);
end;


constructor TPanelClock.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  SetBounds(0,0,219,16);
  Hint := 'Click to see system resources';
  Hint2 := 'Click to see clock';
  FAlertFont := TFont.Create;
  FAlertLevel := 20;
  FAlertMatchFont := TRUE;
  FAllowClick := TRUE;
  FBevel := bvLowered;
  FBevelWidth := 1;
  FClockWidth := 96;
  FSpace := 1;
end;


procedure TPanelClock.Click;

begin
  if (AllowClick)
    then begin
           if (PanelMode = pmClock)
             then PanelMode := pmResources
             else PanelMode := pmClock;
         end;
  inherited Click;
end;


procedure TPanelClock.Paint;

var
  ClientRect: TRect;
  StatusRect: TRect;
  TextMetric: TTextMetric;
  TopColor, BottomColor: TColorRef;
  OldColor, SaveFontColor: TColorRef;
  X: Integer;
  RWidth: Integer;

const
  KeyStates: array[1..ksNumberOfKeyStatuses] of String[4] = ('NUM','CAPS','SCRL');
  ResMonitors: array[1..rmNumberOfMonitors] of String[4] = ('GDI:','SYS:','USR:');

  procedure PaintRect(ARect: TRect; S: String);

  var
    X,Y: Integer;
    W,H: Integer;
    FRect: TRect;

  begin
    FRect := ARect;
    if (Bevel <> bvNone)
      then Frame3D(Canvas,ARect,TopColor,BottomColor,BevelWidth);
    W := Canvas.TextWidth(S);
    WinProcs.GetTextMetrics(Canvas.Handle,TextMetric);
    H := TextMetric.tmHeight;
    X := ARect.Left + IntFindMax((ARect.Right - ARect.Left - W) div 2,1);
    Y := ARect.Top + IntFindMax((ARect.Bottom - ARect.Top - H) div 2,1);
    Canvas.TextRect(ARect,X,Y,S);

    {Fill up the spacer}
    if (Space > 0) and (FRect.Right + Space <= ClientRect.Right)
      then begin
             FRect.Left := FRect.Right;
             FRect.Right := FRect.Left + Space;
             Canvas.Brush.Color := Self.Color;
             Canvas.FillRect(FRect);
           end;
  end;

begin
  inherited Paint;
  ClientRect := GetClientRect;
  if (Bevel = bvLowered)
    then begin
           TopColor := clBtnShadow;
           BottomColor := clBtnHighlight;
         end
    else begin
           TopColor := clBtnHighlight;
           BottomColor := clBtnShadow;
         end;

  Canvas.Font := Self.Font;
  FLastPaint := TimeToStr(Time);
  OldColor := SetBkColor(Canvas.Handle,ColorToRGB(Color));
  StatusRect := ClientRect;
  if (PanelMode = pmClock)
    then begin
           StatusRect.Right := IntFindMin(StatusRect.Right,ClockWidth);
           PaintRect(StatusRect,FLastPaint);
           Inc(StatusRect.Left,ClockWidth+Space);
           RWidth := (ClientRect.Right - StatusRect.Left - (Space * ksNumberOfKeyStatuses)) div ksNumberOfKeyStatuses;
           for x := 1 to ksNumberOfKeyStatuses do
             begin
               if (x = ksNumberOfKeyStatuses)
                 then RWidth := ClientRect.Right;
               StatusRect.Right := IntFindMin(StatusRect.Left + RWidth,ClientRect.Right-Space);
               if (StatusRect.Right - StatusRect.Left > (2*BevelWidth))
                 then begin
                        if (((1 shl Pred(x)) and FKeyState) <> 0)
                          then PaintRect(StatusRect,KeyStates[x])
                          else PaintRect(StatusRect,'');
                      end;
               StatusRect.Left := StatusRect.Right + Space;
             end;
         end
    else begin
           if (FAlertMatchFont)
             then begin
                    FAlertFont.Assign(Font);
                    FAlertFont.Color := clRed;
                  end;

           RWidth := (ClientRect.Right - ClientRect.Left - (Space * rmNumberOfMonitors)) div rmNumberOfMonitors;
           for x := 1 to rmNumberOfMonitors do
             begin
               if (x = rmNumberOfMonitors)
                 then RWidth := ClientRect.Right;
               StatusRect.Right := IntFindMin(StatusRect.Left + RWidth,ClientRect.Right-Space);
               if (FResources[x] < AlertLevel) and (AlertFont <> NIL)
                 then Canvas.Font := AlertFont
                 else Canvas.Font := Self.Font;
               PaintRect(StatusRect,ResMonitors[x]+IntToStr(FResources[x])+'%');
               StatusRect.Left := StatusRect.Right + Space;
             end;
         end;

  SetBkColor(Canvas.Handle,OldColor);
end;


procedure TPanelClock.SetAlertFont(Value: TFont);

begin
  FAlertFont.Assign(Value);
  FAlertMatchFont := FALSE;
  Invalidate;
end;


procedure TPanelClock.SetAlertLevel(Value: Integer);

begin
  if (FAlertLevel <> Value)
    then begin
           FAlertLevel := IntFindMax(IntFindMin(Value,100),0);
           Invalidate;
         end;
end;


procedure TPanelClock.SetAlertMatchFont(Value: Boolean);

begin
  FAlertMatchFont := Value;
  if (Value)
    then begin
           FAlertFont.Assign(Font);
           FAlertFont.Color := clRed;
           Invalidate;
         end;
end;


procedure TPanelClock.SetBevel(Value: TPanelBevel);

begin
  FBevel := Value;
  Invalidate;
end;


procedure TPanelClock.SetBevelWidth(Value: Integer);

begin
  FBevelWidth := Value;
  Invalidate;
end;


procedure TPanelClock.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);

begin
  inherited SetBounds(ALeft, ATop, IntFindMax(AWidth,ClockWidth), AHeight);
end;


procedure TPanelClock.SetClockWidth(Value: Integer);

begin
  FClockWidth := Value;
  Invalidate;
end;


procedure TPanelClock.SetPanelMode(Value: TPanelMode);

var
  Msg: TMsg;
  Temp: String;

begin
  FillChar(FResources,SizeOf(FResources),0);
  FLastPaint := '';
  if (FPanelMode <> Value)
    then begin
           FPanelMode := Value;
           WMTimer(Msg);
           Temp := Hint;
           Hint := Hint2;
           Hint2 := Temp;
         end;
end;


procedure TPanelClock.SetSpace(Value: Integer);

begin
  FSpace := Value;
  Invalidate;
end;


procedure TPanelClock.WMDestroy(var Msg: TMsg);

begin
  KillTimer(Handle,1);
  inherited
end;


procedure TPanelClock.WMCreate(var Msg: TMsg);

begin
  SetTimer(Handle,1,200,NIL);
  inherited;
end;


procedure TPanelClock.WMTimer(var Msg: TMsg);

var
  NewKeyState: Integer;
  NewResources: TResourceMonitor;
  X: Integer;

begin
  NewKeyState := 0;
  if (PanelMode = pmClock)
    then begin
           if (GetKeyState(VK_NUMLOCK) and $01) <> 0
             then Inc(NewKeyState,ksNumLock);
           if (GetKeyState(VK_CAPITAL) and $01) <> 0
             then Inc(NewKeyState,ksCapsLock);
           if (GetKeyState(VK_SCROLL) and $01) <> 0
             then Inc(NewKeyState,ksScrollLock);
           if (FLastPaint <> TimeToStr(Time)) or (FKeyState <> NewKeyState)
             then begin
                    FKeyState := NewKeyState;
                    Paint;
                  end;
         end
    else begin
           NewResources[rmGDIResources] := GetFreeSystemResources(GFSR_GDIResources);
           NewResources[rmSystemResources] := GetFreeSystemResources(GFSR_SystemResources);
           NewResources[rmUserResources] := GetFreeSystemResources(GFSR_UserResources);
           for x := 1 to rmNumberOfMonitors do
             if (NewResources[x] <> FResources[x])
               then begin
                      Move(NewResources,FResources,SizeOf(FResources));
                      Paint;
                      Break;
                    end;
         end;
  inherited;
end;

end.