Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/reswtch2/reswatch.pas

Pascal/Delphi Source File | 1995-12-22 | 19.4 KB | 594 lines

{ ----------------------------------------------------------------------------}
{ ResWatch Resource Watcher Version 2.0.                              }
{ Copyright 1995, Curtis White.  All Rights Reserved.                         }
{ This program can be freely used and distributed in commercial and private }
{ environments, provied this notice is not modified in any way.               }
{ ----------------------------------------------------------------------------}
{ Feel free to contact me if you have any questions, comments or suggestions  }
{ at [e-mail]                                                      }
{ ----------------------------------------------------------------------------}
{ Date last modified:  08/03/95                                               }
{ ----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ ResWatch v2.00                                                         }
{ ----------------------------------------------------------------------------}
{ Description:                                                                }
{   A graphical resource monitor                                   }
{ Features:                                                                   }
{   Monitor system resources.                               }
{   Monitor other system information.                    }
{ ----------------------------------------------------------------------------}
{ ----------------------------------------------------------------------------}
{ Revision History:                                                           }
{ 1.00:  Initial release                                                    }
{ 2.00:  Re-write to add more functionality as well        }
{           as a nicer look.                                                  }
{ ----------------------------------------------------------------------------}

{ Note:  This program uses a component that I wrote to        }
{            obtain a bunch of system information.  I will be       }
{            releasing this component as soon as I finish the     }
{            documentation for it.  Keep watching.                       }

{ Note2:  This program may need modifications to run         }
{              properly under Windows 95, since some of the    }
{              resource calls may have been changed.               }


unit Reswatch;

{
  TForm3D Class
  Copyright ⌐ 1995  Alan Ciemian  All Rights Reserved

  The TForm3D class is a descendant of TForm that provides
    3D borders for non-dialog forms and allows form sizing to be
    enabled/disabled by modifying a run-time property.

  NOTES:
      - Requires that form have bsSizeable border style.
      - Sizing can be enabled/disabled with AllowResize property.
      - Handles all Title bar icon combinations.
      - Handles forms with or without menus(including multiline).
      - Handles all combinations of scroll bars.

  05/01/95 - Initial Release
}


interface

uses
  Messages, WinTypes,
  Classes, Controls, Forms, Dialogs, Sysinfo, ExtCtrls, Gauges, StdCtrls,
  Buttons, SysUtils, RWAbout;


const
  CaptionH_STD = 20;
  MenuH_STD    = 18;


type
  TForm3D_NCPaintMode =
    (
    NCPaint_All,
    NCPaint_Activate,
    NCPaint_Deactivate
    );

type
  TRWMain = class(TForm)
    RWMainPanel: TPanel;
    FreeMemLabel: TLabel;
    FreeMemSize: TLabel;
    ContigFreeLabel: TLabel;
    ContigFreeSize: TLabel;
    Panel4: TPanel;
    Panel5: TPanel;
    SystemPanel: TPanel;
    SystemGauge: TGauge;
    GDIPanel: TPanel;
    GDIGauge: TGauge;
    UserPanel: TPanel;
    UserGauge: TGauge;
    Panel6: TPanel;
    CPULabel: TLabel;
    WinVerLabel: TLabel;
    DosVerLabel: TLabel;
    TasksLabel: TLabel;
    ResourceTimer: TTimer;
    SystemInfo1: TSystemInfo;
    AboutButton: TBitBtn;
    procedure ResourceTimerTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure AboutButtonClick(Sender: TObject);
  private
    FAllowResize : Boolean;
    FSysMenuW    : Integer;  { Width of system menu,     0 if no sysmenu }
    FMinMaxW     : Integer;  { Width of min/max buttons, 0 if no min/max btns }
    { Private procedures }
    procedure NCPaint3D(const Mode: TForm3D_NCPaintMode);
    procedure ComputeNonClientDimensions;
    function ScrollBarVisible
      (
      const Code    : Word;  { SB_VERT or SB_HORZ }
      const WndRect : TRect
      ): Boolean;
    { Message Handlers }
    procedure WMNCHitTest (var Msg: TWMNCHitTest);  message WM_NCHitTest;
    procedure WMNCPaint   (var Msg: TWMNCPaint);    message WM_NCPaint;
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCActivate;
  protected
    procedure CreateWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    { Properties }
    property AllowResize: Boolean
             read FAllowResize
             write FAllowResize
             default False;
  end;

var
  RWMain: TRWMain;

implementation

{$R *.DFM}

uses
  WinProcs,
  Graphics,
  SysMet;


function TRWMain.ScrollBarVisible
  (
  const Code    : Word;  { SB_VERT or SB_HORZ }
  const WndRect : TRect
  ): Boolean;
var
  PtInScroll : TPoint;
  HVis       : Boolean;
begin
  Result := False;

  with  WndRect, SysMetrics  do
    begin
    { Determine if Horz scroll bar is visible. Need this for both horz and }
    {   vert scroll bars. }
    { Two checks need to be satisfied, Style identifies scroll bar and }
    {   windows recognizes HitTest in scroll bar. }
    { Hit Test check is required because there are cases when the window }
    {   gets very small that windows decides not to draw the scroll bars }
    {   even though they exist. }
    PtInScroll := Point(Left + Frame.cx + 1, Bottom - Frame.cy - 1);
    HVis := ( ((GetWindowLong(Handle, GWL_STYLE) and WS_HSCROLL) <> 0) and
              (Perform(WM_NCHITTEST, 0, LongInt(PtInScroll)) = HTHSCROLL) );

    if ( Code = SB_HORZ ) then
      begin  { Done, return result computed above }
      Result := HVis;
      end
    else
      begin  { Perform same procedure as above for vertical }
      PtInScroll := Point(Right - Frame.cx - 1, Bottom - Frame.cy - 1);
      if ( HVis ) then Dec(PtInScroll.y, HScrollBtn.cy);
      Result := ( ((GetWindowLong(Handle, GWL_STYLE) and WS_VSCROLL) <> 0) and
                  (Perform(WM_NCHITTEST, 0, LongInt(PtInScroll)) = HTVSCROLL) );
      end;
    end;
end;



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

  { Set property defaults }
  FAllowResize := False;
end;


{
  CreateWnd is overriden so we can force certain properties before
    the window is created, and compute some parameters needed to
    do the 3D non-client drawing.
}
procedure TRWMain.CreateWnd;
var
  AdjustHeight : Integer;
begin
  { Border Style must be bsSizeable }
  BorderStyle := bsSizeable;

  { Compute height adjustments for font caption and menu.      }
  { In large fonts video modes the client area would otherwise }
  {   be reduced. }
  AdjustHeight := 0;
  with  SysMetrics  do
    begin
    Inc(AdjustHeight, CaptionH - CaptionH_STD);
    { Note: Only adjusts for a single line menu bar }
    if ( Menu <> nil ) then Inc(AdjustHeight, MenuH - MenuH_STD);
    end;

  { Let Form create }
  inherited CreateWnd;

  { Enforce the height adjustment }
  Height := Height + AdjustHeight;

  { Precompute dimensions of key non-client areas for later use }
  {   in drawing the 3D effects. }
  ComputeNonClientDimensions;
end;


{
ComputeNonClientDimensions precomputes some dimensions of non-client items
  to avoid doing it repeatedly during painting.
}
procedure TRWMain.ComputeNonClientDimensions;

  { We'd like to use the SM_CXSIZE system metrics value for the size of icons }
  {  in the title bar but it is NOT correct for some video drivers/modes }
  function BitmapWidth(const BM_ID: Integer): Integer;
  var
    BM     : THandle;
    BMInfo : WinTypes.TBitmap;
  begin
    BM := LoadBitmap(0, MakeIntResource(BM_ID));
    try
      GetObject(BM, SizeOf(BMInfo), @BMInfo);
      Result := BMInfo.bmWidth;
    finally
      DeleteObject(BM);
    end;
  end;

begin
  FSysMenuW := 0;
  if ( biSystemMenu in BorderIcons ) then
    begin
    { Note: Close bitmap contains 2 bitmaps, app close and MDI child close }
    Inc(FSysMenuW, BitmapWidth(OBM_CLOSE) div 2);
    end;

  FMinMaxW := 0;
  if ( biMinimize in BorderIcons ) then
    begin
    Inc(FMinMaxW, BitmapWidth(OBM_REDUCE));
    end;
  if ( biMaximize in BorderIcons ) then
    begin
    Inc(FMinMaxW, BitmapWidth(OBM_ZOOM));
    end;
end;


{
NCPaint3D handles the 3D specific painting for the form.
}
procedure TRWMain.NCPaint3D
  (
  const Mode: TForm3D_NCPaintMode
  );
var
  WndRect     : TRect;
  ClientRect  : TRect;
  ClientH     : Integer;
  ScrollH     : Integer;
  DC          : HDC;
  NCCanvas    : TCanvas;
  Extra       : Integer;
  CaptionRect : TRect;
  TM          : TTextMetric;
begin
  { Get window rect }
  WinProcs.GetWindowRect(Handle, WndRect);
  { Need to know if horz scroll bar present }
  ScrollH := 0;
  if ( ScrollBarVisible(SB_HORZ, WndRect) ) then
    begin
    ScrollH := SysMetrics.HScrollBtn.cy - 1;
    end;
  { Convert window rect to (0, 0) origin }
  with  WndRect  do
    begin
    Right  := Right - Left;
    Left   := 0;
    Bottom := Bottom - Top;
    Top    := 0;
    end;
  WinProcs.GetClientRect(Handle, ClientRect);
  ClientH := ClientRect.Bottom - ClientRect.Top;
  if ( 0 < ClientH ) then Inc(ClientH);

  { Get a Window DC and wrap it in a Delphi Canvas }
  DC       := GetWindowDC(Self.Handle);
  NCCanvas := TCanvas.Create;
  NCCanvas.Handle := DC;
  try
    with NCCanvas, WndRect, SysMetrics do
      begin
      if ( Mode = NCPaint_All ) then
        begin
        { Draw Left and Top edges of window frame, outer }
        Pen.Color := clBtnShadow;
        PolyLine([ Point(Left,  Bottom - 1),
                   Point(Left,  Top),
                   Point(Right, Top) ]);
        { Draw Bottom and Right edges of window frame, outer }
        Pen.Color := clWindowFrame;
        PolyLine([ Point(Left,  Bottom - 1),
                   Point(Right - 1, Bottom - 1),
                   Point(Right - 1, Top - 1) ]);
        { Draw Left and Top edges of window frame, 1-pixel in }
        Pen.Color := clBtnHighlight;
        PolyLine([ Point(Left  + 1, Bottom - 2),
                   Point(Left  + 1, Top    + 1),
                   Point(Right - 1, Top    + 1) ]);
        { Draw Right and Bottom edges of window frame, 1-pixel in }
        Pen.Color := clBtnShadow;
        PolyLine([ Point(Left  + 1, Bottom - 2),
                   Point(Right - 2, Bottom - 2),
                   Point(Right - 2, Top) ]);

        { Fill Remainder of Sizing border }
        Pen.Color := clBtnFace;
        for Extra := 2 to (Frame.cx - 1) do
          begin
          Brush.Color := clBtnFace;
          FrameRect(Rect(Left + Extra, Top + Extra,
                         Right - Extra, Bottom - Extra));
          end;

        { Draw Left and Top Edge of Caption Area }
        Pen.Color := clBtnShadow;
        PolyLine([ Point(Frame.cx - 1, Bottom - 1 - Frame.cy - ClientH - ScrollH),
                   Point(Frame.cx - 1, Frame.cy - 1),
                   Point(Right - Frame.cx, Frame.cy - 1) ]);
        { Draw Bottom and Right Edge of Caption Area }
        Pen.Color := clBtnHighlight;
        PolyLine([ Point(Frame.cx - 1,     Bottom - Frame.cy - ClientH - ScrollH),
                   Point(Right - Frame.cx, Bottom - Frame.cy - ClientH - ScrollH),
                   Point(Right - Frame.cx, Frame.cy - 1) ]);
        end;

      { Draw Caption }
      CaptionRect := Rect(Frame.cx + FSysMenuW + 1, Frame.cy,
                          Right - Frame.cx - FMinMaxW,
                          Frame.cy - 1 + CaptionH - 1);
      if ( (Mode = NCPaint_Activate) or
           ((Mode = NCPaint_All) and (GetActiveWindow = Self.Handle)) ) then
        begin  { Need 'Active' Caption }
        Brush.Color := clActiveCaption;
        Font.Color  := clCaptionText;
        end
      else
        begin  { Need 'InActive' Caption }
        Brush.Color := clInactiveCaption;
        Font.Color  := clInactiveCaptionText;
        end;
      FillRect(CaptionRect);
      SetTextAlign(DC, TA_CENTER or TA_TOP);
      GetTextMetrics(DC, TM);
      TextRect(CaptionRect,
               (CaptionRect.Left + CaptionRect.Right) div 2,
               CaptionRect.Top + ((CaptionH - 1) - TM.tmHeight) div 2,
               Caption);
      end;
  finally
    NCCanvas.Free;
    ReleaseDC(Handle, DC);
  end; { try-finally }
end;


{
WMNCHitTest handles the WM_NCHITTEST message.
Modifies sizing hit codes to support fixed size windows.
}
procedure TRWMain.WMNCHitTest
  (
  var Msg: TWMNCHitTest
  );
var
  HitCode : LongInt;
begin
  inherited;
  HitCode := Msg.Result;

  { Lets resurrect the size corner }
  if ( HitCode = HTSIZE ) then HitCode := HTBOTTOMRIGHT;

  if ( not AllowResize ) then
    begin
    if ( (HitCode = HTLEFT)     or (HitCode = HTRIGHT)      or
         (HitCode = HTTOP)      or (HitCode = HTBOTTOM)     or
         (HitCode = HTTOPLEFT)  or (HitCode = HTBOTTOMLEFT) or
         (HitCode = HTTOPRIGHT) or (HitCode = HTBOTTOMRIGHT) ) then
      begin
      HitCode := HTNOWHERE;
      end;
    end;

  Msg.Result := HitCode;
end;


{
WMNCPaint handles WM_NCPAINT message.
Calls default handler to paint non-client areas that have standard appearance.
Calls NCPaint3D to paint modified non-client areas
NOTE: Uses undocumented aspect of WM_NCPAINT message which allows a clipping
      region handle to be passed in the wParam of the message.
      This is used to avoid seeing the standard non-client areas flash before
      they are repainted by the 3D code.
      Ref. Undocumented Windows pg. 527, Thanks Andrew.
}
procedure TRWMain.WMNCPaint
  (
  var Msg: TWMNCPaint
  );
var
  WndRect    : TRect;
  ClientRect : TRect;
  ClientH    : Integer;
  ScrollH    : Integer;
  ClipRect   : TRect;
  ClipRgn    : THandle;
  HScrollVis : Boolean;
  VScrollVis : Boolean;
begin
  { Let Windows draw the non-client areas that will not change }
  { Form props for window pos and size incorrect during resize here. }
  { Get Position directly from windows }
  WinProcs.GetWindowRect(Handle, WndRect);
  WinProcs.GetClientRect(Handle, ClientRect);
  ClientH := ClientRect.Bottom - ClientRect.Top;
  if ( 0 < ClientH ) then Inc(ClientH);

  HScrollVis := ScrollBarVisible(SB_HORZ, WndRect);
  VScrollVis := ScrollBarVisible(SB_VERT, WndRect);

  ScrollH := 0;
  if ( HScrollVis ) then ScrollH := SysMetrics.HScrollBtn.cy - 1;

  with  WndRect, SysMetrics  do
    begin
    { System Menu }
    if ( biSystemMenu in BorderIcons ) then
      begin
      ClipRect := Rect(Left + Frame.cx, Top + Frame.cy,
                       Left + Frame.cx + TitleBitmap.cx + 1,
                       Top  + Frame.cy + TitleBitmap.cy);
      ClipRgn := CreateRectRgnIndirect(ClipRect);
      TMessage(Msg).wParam := ClipRgn;
      (self as TWinControl).DefaultHandler(Msg);
      DeleteObject(ClipRgn);
      end;
    { Min/Max buttons }
    if ( 0 < FMinMaxW ) then
      begin
      ClipRect := Rect(Right - Frame.cx - FMinMaxW, Top  + Frame.cy,
                       Right - Frame.cx, Top + Frame.cy + TitleBitmap.cy);
      ClipRgn := CreateRectRgnIndirect(ClipRect);
      TMessage(Msg).wParam := ClipRgn;
      (self as TWinControl).DefaultHandler(Msg);
      DeleteObject(ClipRgn);
      end;
    { Menubar }
    if ( Menu <> nil ) then
      begin
      ClipRect := Rect(Left + Frame.cx, Top + Frame.cy + CaptionH - Border.cy - 1,
                       Right - Frame.cx, Bottom - Frame.cy - ClientH - ScrollH);
      ClipRgn := CreateRectRgnIndirect(ClipRect);
      TMessage(Msg).wParam := ClipRgn;
      (self as TWinControl).DefaultHandler(Msg);
      DeleteObject(ClipRgn);
      end;
    end;

  { Paint 3-D parts of nonclient area in 3-D style }
  NCPaint3D(NCPaint_All);

  { Now let windows paint scroll bars. Need to wait until here because scroll }
  {   bars take advantage of normal borders for their outer edges and they    }
  {   our trounced in NCPaint3D. }
  with  WndRect, SysMetrics  do
    begin
    if ( HScrollVis ) then
      begin { Let Windows draw horz scroll bar }
      ClipRect := Rect(Left  + (Frame.cx - 1), Bottom - (Frame.cy - 1) - HScrollBtn.cy,
                       Right - (Frame.cx - 1), Bottom - (Frame.cy - 1));
      if ( VScrollVis ) then Dec(ClipRect.Right, VScrollBtn.cx - 1);
      ClipRgn := CreateRectRgnIndirect(ClipRect);
      TMessage(Msg).wParam := ClipRgn;
      (self as TWinControl).DefaultHandler(Msg);
      DeleteObject(ClipRgn);
      end;
    if ( VScrollVis ) then
      begin { Let Windows draw vert scroll bar }
      ClipRect := Rect(Right - (Frame.cx - 1) - VScrollBtn.cx, Bottom - Frame.cy - ClientH - ScrollH,
                       Right - (Frame.cx - 1),                 Bottom - (Frame.cy - 1));
      if ( HScrollVis ) then Dec(ClipRect.Bottom, HScrollBtn.cy - 1);
      ClipRgn := CreateRectRgnIndirect(ClipRect);
      TMessage(Msg).wParam := ClipRgn;
      (self as TWinControl).DefaultHandler(Msg);
      DeleteObject(ClipRgn);
      end;
    if ( HScrollVis and VScrollVis ) then
      begin { Let Windows draw little box in corner }
      ClipRect := Rect(Right - (Frame.cx - 1) - (VScrollBtn.cx - 1),
                       Bottom - (Frame.cy - 1) - (HScrollBtn.cy - 1),
                       Right - (Frame.cx - 1) - 1, Bottom - (Frame.cy - 1) - 1);
      ClipRgn := CreateRectRgnIndirect(ClipRect);
      TMessage(Msg).wParam := ClipRgn;
      (self as TWinControl).DefaultHandler(Msg);
      DeleteObject(ClipRgn);
      end;
    end;

  { Now let windows update scroll bars }
  Msg.Result := 0;
end;


{
WMNCActivate handles the WM_NCACTIVATE message.
Calls NCPaint3D to repaint the caption.
Can NOT let windows have this message or it will trash our 3D borders.
}
procedure TRWMain.WMNCActivate
  (
  var Msg: TWMNCActivate
  );
begin
  if ( Msg.Active ) then
    NCPaint3D(NCPaint_Activate)
  else
    NCPaint3D(NCPaint_Deactivate);

  Msg.Result := 1;
end;

procedure TRWMain.ResourceTimerTimer(Sender: TObject);
begin
  UserGauge.Progress := SystemInfo1.PcntFreeUserRes;
  GDIGauge.Progress := SystemInfo1.PcntFreeGDIRes;
  SystemGauge.Progress := SystemInfo1.PcntFreeSystemRes;
  FreeMemSize.Caption := IntToStr(SystemInfo1.FreeHeap)+'  bytes';
  ContigFreeSize.Caption := IntToStr(SystemInfo1.ContigFreeHeap)+'  bytes';
  CPULabel.Caption := 'CPU:        '+ SystemInfo1.CPUString;
  WinVerLabel.Caption := 'Win Ver:  '+ SystemInfo1.WindowsVersion;
  DosVerLabel.Caption := 'Dos Ver:  '+ SystemInfo1.DOSVersion;
  TasksLabel.Caption := 'Tasks:      '+ IntToStr(SystemInfo1.TasksRunning);
end;

procedure TRWMain.FormCreate(Sender: TObject);
var
  hMenu: THandle;
begin
  Application.HintColor := clAqua;
  Application.HintPause := 0;
  hMenu := GetSystemMenu(Handle, False);
  DeleteMenu(hMenu, 4, MF_BYPOSITION);
  DeleteMenu(hMenu, 2, MF_BYPOSITION);
  DeleteMenu(hMenu, 0, MF_BYPOSITION);
  AboutButton.Caption := '';
end;

procedure TRWMain.AboutButtonClick(Sender: TObject);
begin
  RWAboutBox.Show;
end;

end.