Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/D1/SYSINFO.ZIP/SYSINFO.PAS

Pascal/Delphi Source File | 1996-01-14 | 9KB | 334 lines

unit SysInfo;

{---------------------------------------------------------------------------------}
{                                                                                 }
{ TSystemInfo                                                                     }
{                                                                                 }
{ A label that shows something about the current system.  The "text" property     }
{ gives programs read-only access to the displayed value.                         }
{                                                                                 }
{ Freeware.  Use it at your own risk.                                             }
{                                                                                 }
{ S Armstrong     13/1/96                                                         }
{ [e-mail]                                                      }
{---------------------------------------------------------------------------------}


interface

uses
  Classes, StdCtrls, Controls, Graphics, Menus, WinTypes, WinProcs, SysUtils;

type
  TAttribute = (atCompanyName,
                atCoProcessor,
                atCPU,
                atDiskSize,
                atDosVersion,
                atFreeDisk,
                atFreeGDIResources,
                atFreeMemory,
                atFreeSystemResources,
                atFreeUserResources,
                atSystemDirectory,
                atTempDisk,
                atTempDiskSize,
                atTempFreeDisk,
                atUserName,
                atWindowsDirectory,
                atWindowsDisk,
                atWindowsDiskSize,
                atWindowsFreeDisk,
                atWindowsMode,
                atWindowsVersion);

  TInvalidDiskException = class(Exception);

  TChangeProcedure = procedure( Sender: TObject ) of Object;

  TSystemInfo = class(TCustomLabel)
  private
    { Private declarations }
    FAttribute: TAttribute;
    FDisk: char;

    FOnChange: TChangeProcedure;

    function  FormatBytes(b: LongInt): string;
    function  ReadText: string;
    procedure SetCaption;
    procedure SetAttribute(at: TAttribute);
    procedure SetDisk(d: char);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create( Owner: TComponent ); override;
    procedure Refresh;
    property Text: string read ReadText;
  published
    { Published declarations }
    property Align;
    property Alignment;
    property Attribute: TAttribute read FAttribute write SetAttribute;
    property AutoSize;
    property Color;
    property Disk: char read FDisk write SetDisk;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FocusControl;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowAccelChar;
    property ShowHint;
    property Transparent;
    property Visible;
    property WordWrap;

    property OnChange: TChangeProcedure read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

uses
  CpuTyp;

procedure Register;
begin
  RegisterComponents('Extra', [TSystemInfo]);
end;

constructor TSystemInfo.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  FDisk := 'C';
  SetCaption;
end;

function TSystemInfo.ReadText: string;
begin
   result := caption;
end;

procedure TSystemInfo.SetDisk(d: char);
begin
  d := UpCase(d);
  if not (d in ['A'..'Z']) then { disallow all but drive letters}
    { ignore that the specified disk may not exist on this machine }
    raise TInvalidDiskException.Create(d + ' is not a valid disk letter')
  else if FDisk <> d then begin
    FDisk := d;
    if (FAttribute = atDiskSize) or
       (FAttribute = atFreeDisk) then
       SetCaption;
  end;
end;

procedure TSystemInfo.SetAttribute(at: TAttribute);
begin
  if FAttribute <> at then begin
    FAttribute := at;
    SetCaption;
  end;
end;

function TSystemInfo.FormatBytes(b: LongInt): string;
var
   l,r: integer;
begin
   if b = -1 then
      result := ''
   else if b > 1048576 then begin
      l := b div 1048576;
      r := (b mod 1048576) div 1024;
      while (r > 0) and (r mod 10 = 0) do
         r := r div 10;
      result := format('%d.%d MB',[l,r]);
   end else  if b > 1000 then begin
      l := b div 1024;
      r := b mod 1024;
      while (r > 0) and (r mod 10 = 0) do
         r := r div 10;
      result := format('%d.%d KB',[l,r]);
   end else
      result := IntToStr(b) + ' B';
end;

procedure TSystemInfo.Refresh;
var
   old: string;
begin
   old := caption;
   SetCaption;
   if (Assigned(FOnChange)) and (caption <> old) then
      FOnChange(Self);
end;

procedure TSystemInfo.SetCaption;
var
   Version: Word;
   winFlags: LongInt;
   fileHandle: THandle;
   buffer: array [0..143] of Char;
   d: string[1];
begin
  case FAttribute of

  atCompanyName:
     begin
        fileHandle := LoadLibrary('USER');
        if fileHandle >= HINSTANCE_ERROR then begin
           If LoadString(fileHandle, 515, @Buffer, sizeof(buffer)) <> 0 Then
              Caption := buffer;
           FreeLibrary(fileHandle);
        end;
     end;

  atCoProcessor:
     begin
        winFlags := GetWinFlags;
        If winFlags And WF_80x87 > 0 Then
           Caption := 'Present'
        else
           Caption := 'Absent';
     end;

  atCPU:
     begin
{        winFlags := GetWinFlags;
        if winFlags And WF_CPU486 > 0 Then
           Caption := '486'
        else if winFlags And WF_CPU386 > 0 Then
           Caption := '386'
        else if winFlags And WF_CPU286 > 0 Then
           Caption := '286'; }
        Caption := CpuTypeString;
     end;

  atDiskSize:
     caption := FormatBytes(DiskSize(ord(FDisk) - ord('A') + 1));

  atDosVersion:
     begin
        Version := HiWord(GetVersion);
        if HI(version) >= 10 then begin
           if (HI(version) = 20) and (LO(version) = 30) then
              Caption := 'OS/2 Warp v3' { v2.30 }
           else
              Caption := 'OS/2 ' + IntToStr(HI(version) DIV 10) + IntToStr(LO(version));
        end else
           Caption := IntToStr(HI(Version)) + '.' + IntToStr(LO(Version));
     end;

  atFreeDisk:
     caption := FormatBytes(DiskFree(ord(FDisk) - ord('A') + 1));

  atFreeMemory:
    caption := FormatBytes(GetFreeSpace(0));

  atFreeGDIResources:
    Caption := IntToStr(GetFreeSystemResources(GFSR_GDIRESOURCES)) + '%';

  atFreeSystemResources:
    Caption := IntToStr(GetFreeSystemResources(GFSR_SYSTEMRESOURCES)) + '%';

  atFreeUserResources:
    Caption := IntToStr(GetFreeSystemResources(GFSR_USERRESOURCES)) + '%';

  atSystemDirectory:
    if GetSystemDirectory(buffer, sizeof(buffer)) > 0 then
       caption := StrPas(buffer)
    else
       caption := '';

  atTempDisk:
     begin
        buffer[0] := GetTempDrive(' ');
        buffer[1] := ':';
        buffer[2] := chr(0);
        caption := StrPas(buffer);
     end;

  atTempDiskSize:
     caption := FormatBytes(DiskSize(ord(GetTempDrive(' ')) - ord('A') + 1));

  atTempFreeDisk:
     caption := FormatBytes(DiskFree(ord(GetTempDrive(' ')) - ord('A') + 1));

  atUserName:
     begin
        fileHandle := LoadLibrary('USER');
        if fileHandle >= HINSTANCE_ERROR then begin
           If LoadString(fileHandle, 514, @buffer, sizeof(buffer)) <> 0 Then
              Caption := buffer;
           FreeLibrary(fileHandle);
        end;
     end;

  atWindowsDirectory:
    if GetWindowsDirectory(buffer, sizeof(buffer)) > 0 then
       caption := StrPas(buffer)
    else
       caption := '';

  atWindowsDisk:
     begin
        GetWindowsDirectory(buffer, sizeof(buffer));
        caption := Copy(UpperCase(StrPas(buffer)),1,2);
     end;

  atWindowsDiskSize:
     begin
        GetWindowsDirectory(buffer, sizeof(buffer));
        d := UpperCase(StrPas(buffer));
        caption := FormatBytes(DiskSize(ord(d[1]) - ord('A') + 1));
     end;

  atWindowsFreeDisk:
     begin
        GetWindowsDirectory(buffer, sizeof(buffer));
        d := UpperCase(StrPas(buffer));
        caption := FormatBytes(DiskFree(ord(d[1]) - ord('A') + 1));
     end;

  atWindowsMode:
     begin
        winFlags := GetWinFlags;
        if winFlags And WF_ENHANCED > 0 Then
           Caption := '386 Enhanced'
        else if winFlags And WF_STANDARD > 0 Then
           Caption := 'Standard'
        else if winFlags And WF_PMODE > 0 Then
           Caption := 'Protected'
        else
           Caption := 'Non-Protected';
     end;

  atWindowsVersion:
     begin
        Version := LoWord(GetVersion);
        Caption := IntToStr(LO(Version)) + '.' + IntToStr(HI(Version));
     end;

  else
      caption := '';
  end;
end;


end.