{$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: 403-228-9991                                                }
{          Fax: 403-228-0202                                                  }
{                                                                             }
{  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:');

{This procedure is inside of the TPanelClock.Paint procedure.}
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 {TPanelClock.Paint}
  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.