COMPOSANT TDBPPROCESSEUR : DES INFOS SUR LE PROC ET SON UTILISATION !!

{
################################################################################
# DBPPROCESSEUR                                                                #
################################################################################
#                                                                              #
# VERSION       : 1.8                                                          #
# FICHIERS      : dbpVersionInfo.pas,.dcu,.dcr,.bmp,ReadMe.htm                 #
# AUTEUR        : Julio P. (Diabloporc)                                        #
# CREATION      : 19 jul 2004                                                  #
# MODIFIEE      : 27 jul 2004                                                  #
# SITE WEB      : http://diabloporc.free.fr                                    #
# MAIL          : diabloporc@laposte.net                                       #
# LEGAL         : Free sous Licence GNU/GPL                                    #
# INFOS         : Retrouvez moi sur www.delphifr.com : "JulioDelphi"           #
#                                                                              #
################################################################################
}
unit dbpProcesseur;

interface

uses
   ExtCtrls, forms, ComCtrls, Gauges, mgProgress, windows, sysutils, classes, Registry;

type
  TSYSTEM_PROCESSOR_PERFORMANCE_INFORMATION=Record
    Case Integer Of
    1:( IdleTime   : Int64;
        KernelTime : Int64;
        UserTime   : Int64;
        Reserved1  : Array[0..2]Of Int64;
        Reserved2  : Cardinal;);
    2:( Res        : Array[1..$138]Of Byte);
  End;

type
   TdbpInterval   = 100..3600000;
   TdbpTimerEvent = procedure(Sender: TObject) of object;
   TdbpProcesseur = class(TComponent)
  private
    FAbout, FTempsOccupe, FTempsInoccupe: String;
    FEnabled, FChauffe, FTBFull:         Boolean;
    FUtilisation:         Integer;
    FInterval: TdbpInterval;
    FTimer: TTimer;
    FProgressBar: TProgressBar;
    FGauge: TGauge;
    FTrackBar: TTrackBar;
    FmgProgress: TmgProgress;
    FTimerEvent: TdbpTimerEvent;

    procedure SetEnabled(const Value: Boolean);
    procedure SetInterval(Value: TdbpInterval);
    procedure SetProgressBar(Value: TProgressBar);
    procedure SetmgProgress(Value: TmgProgress);
    procedure SetGauge(Value: TGauge);
    procedure SetTrackBar(Value: TTrackBar);
    procedure SetChauffe(const Value: Boolean);
    procedure SetTBFull(const Value: Boolean);

    function GetMhz: integer;
    function GetIdentifier: String;
    function GetProcName: String;
    function GetVendor: String;
    function GetAbout: string;
  protected
    procedure ActTimer(Sender: TObject);
  public
    constructor Create(AOwner: TComponent);                   override;
    destructor  Destroy;                                      override;
    property Chauffe          : Boolean   read FChauffe       write SetChauffe;
    property CPUID_Identifier : String    read GetIdentifier;
    property CPUID_Mhz        : Integer   read GetMhz;
    property CPUID_ProcName   : String    read GetProcName;
    property CPUID_Vendor     : String    read GetVendor;
    property TempsOccupe      : String    read FTempsOccupe;
    property TempsTotal       : String    read FTempsInoccupe;
    property Utilisation      : Integer   read FUtilisation;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  published
    procedure ChauffeMarcel;
    procedure ArreteDeChauffer;
    property About            : String    read GetAbout       write FAbout;
    property Enabled          : Boolean   read FEnabled       write SetEnabled;
    property Interval         : TdbpInterval   read FInterval      write SetInterval;
    property TGauge           : TGauge    read FGauge         write SetGauge;
    property TmgProgress      : TmgProgress    read FmgProgress    write SetmgProgress;
    property TProgressBar     : TProgressBar   read FProgressBar   write SetProgressBar;
    property TTrackBar        : TTrackBar      read FTrackbar      write SetTrackBar;
    property TTrackBar_full   : boolean   read FTBFull        write SetTBFull;
    property OnTimer:         TdbpTimerEvent   read FTimerEvent    write FTimerEvent;
  end;

procedure Register;

implementation

{$R dbpProcesseur.dcr}

Function NtQuerySystemInformation(SystemInfoClass:Integer;Info:Pointer;InfoLength:Cardinal;
            Var ReturnLength:Cardinal):Integer;StdCall;
            External 'NTDLL.DLL' Name 'NtQuerySystemInformation';

Const
  SystemProcessorPerformanceInformation=$2;
  CentNanoSecondesParJour = 24.0*60.0*60.0*10000000.0;
  MilliSecondesParJour    = 24.0*60.0*60.0*1000.0;

Var
  MemTickTotal : Integer = 0;
  MemTickIdle  : Integer = 0;

procedure TdbpProcesseur.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if (aComponent = FProgressBar) and (Operation = opRemove) then
  begin
    FProgressBar := nil;
  end;
  if (aComponent = FmgProgress) and (Operation = opRemove) then
  begin
    FmgProgress := nil;
  end;
  if (aComponent = FGauge) and (Operation = opRemove) then
  begin
    FGauge := nil;
  end;
  if (aComponent = FTrackBar) and (Operation = opRemove) then
  begin
    FTrackBar := nil;
  end;
end;

function ReadStringReg(Base: HKEY; KeyName, ValueName: string): string;
begin
  result := '';
  with TRegistry.Create do
  begin
    RootKey:=Base;
    OpenKeyReadOnly(KeyName);
    try
      if ValueExists(ValueName) then
        Result := ReadString(ValueName)
      else
        Result := '';
    except
      Result := '';
    end;
    Free;
  end;
end;

function ReadIntegerReg(Base: HKEY; KeyName, ValueName: string): Integer;
begin
  with TRegistry.Create do
  begin
    RootKey:=Base;
    if KeyExists(KeyName) then OpenKey(KeyName, False);
    try
      if ValueExists(ValueName) then
        Result:=ReadInteger(ValueName)
      else
        Result:=0;
    except
      Result:=0;
    end;
    Free;
  end;
end;

function TdbpProcesseur.GetAbout: string;
begin
  Result:='V1.8 : Julio P. (Diabloporc)';
end;

function TdbpProcesseur.GetMhz: Integer;
begin
 result := ReadIntegerReg(HKEY_LOCAL_MACHINE,'HARDWARE\DESCRIPTION\System\CentralProcessor\0','~MHz');
end;

function TdbpProcesseur.GetIdentifier: String;
begin
 result := ReadStringReg(HKEY_LOCAL_MACHINE,'HARDWARE\DESCRIPTION\System\CentralProcessor\0','Identifier');
end;

var FFinChauffe: Boolean;
procedure TdbpProcesseur.SetChauffe(const Value: Boolean);
begin
  FChauffe := Value;
  if not (csDesigning in ComponentState) then
   begin
    FFinChauffe := not FChauffe;
    if FChauffe then
     while not FFinChauffe do Application.ProcessMessages;
   end;
end;

procedure TdbpProcesseur.SetEnabled(const Value: Boolean);
begin
  FEnabled       := Value;
  FTimer.Enabled := Value;
end;

procedure TdbpProcesseur.SetTBFull(const Value: Boolean);
begin
  FTBFull       := Value;
  if (not FTBFull) and (FTrackBar<>nil) then
   begin
    FTrackBar.SelStart := 0;
    FTrackBar.SelEnd   := 0;
   end;
end;

function TdbpProcesseur.GetProcName: String;
begin
 result := ReadStringReg(HKEY_LOCAL_MACHINE,'HARDWARE\DESCRIPTION\System\CentralProcessor\0','ProcessorNameString');
end;

procedure TdbpProcesseur.SetInterval(Value: TdbpInterval);
begin
  FInterval       := Value;
  FTimer.Interval := Value;
end;

procedure TdbpProcesseur.SetProgressBar(Value: TProgressBar);
begin
 if (FProgressBar <> Value) and (Value<>nil) then
  begin
   FProgressBar     := value;
   FProgressBar.Min := 0;
   FProgressBar.Max := 100;
  end
 else
  if Value=nil then FProgressBar := nil;
end;

procedure TdbpProcesseur.SetmgProgress(Value: TmgProgress);
begin
 if (FmgProgress <> Value) and (Value<>nil) then
  begin
   FmgProgress          := value;
   FmgProgress.MinValue := 0;
   FmgProgress.MaxValue := 100;
  end
 else
  if Value=nil then FmgProgress := nil;
end;

procedure TdbpProcesseur.SetGauge(Value: TGauge);
begin
 if (FGauge <> Value) and (Value<>nil) then
  begin
   FGauge          := value;
   FGauge.MinValue := 0;
   FGauge.MaxValue := 100;
  end
 else
  if Value=nil then FGauge := nil;
end;

procedure TdbpProcesseur.SetTrackBar(Value: TTrackBar);
begin
 if (FTrackBar <> Value) and (Value<>nil) then
  begin
   FTrackBar           := value;
   FTrackbar.Min       := 0;
   FTrackBar.Max       := 100;
   FTrackBar.SelStart  := 0;
   FTrackBar.SelEnd    := 0;
  end
 else
  if Value=nil then FTrackBar := nil;
end;

function TdbpProcesseur.GetVendor: String;
begin
 result := ReadStringReg(HKEY_LOCAL_MACHINE,'HARDWARE\DESCRIPTION\System\CentralProcessor\0','VendorIdentifier');
end;

procedure TdbpProcesseur.ActTimer(Sender: TObject);
Var Info      : TSYSTEM_PROCESSOR_PERFORMANCE_INFORMATION;
    Long      : Cardinal;
    TickTotal : Integer;
    TickIdle  : Integer;
    DiffTotal : Integer;
    DiffIdle  : Integer;
    Occupe    : Double;
begin
  NtQuerySystemInformation(SystemProcessorPerformanceInformation,@Info,SizeOf(Info),Long);

  TickIdle  := Info.IdleTime Div 10000;
  TickTotal := GetTickCount;

  DiffIdle  := TickIdle  - MemTickIdle;
  DiffTotal := TickTotal - MemTickTotal;
  Occupe    := 100-DiffIdle/DiffTotal*100;
  If Occupe<0 Then Occupe:=0;

  FTempsOccupe   := FormatDateTime('HH:NN:SS:zzz',Info.IdleTime   /CentNanoSecondesParJour);
  FTempsInoccupe := FormatDateTime('HH:NN:SS:zzz',TickTotal       /MilliSecondesParJour   );
  FUtilisation   := Round(Occupe);

  if not (csDesigning in ComponentState) then
   begin
    if FProgressBar<>nil then FProgressBar.Position := FUtilisation;
    if FmgProgress<>nil  then FmgProgress.Progress  := FUtilisation;
    if FGauge<>nil       then FGauge.Progress       := FUtilisation;
    if FTrackBar<>nil    then FTrackBar.Position    := FUtilisation;
    if (FTBFull) and (FTrackBar<>nil)  then FTrackBar.SelEnd      := FUtilisation;
   end;

  MemTickIdle  := TickIdle;
  MemTickTotal := TickTotal;
  if Assigned(FTimerEvent) then FTimerEvent(Self);
end;

procedure TdbpProcesseur.ChauffeMarcel;
begin
 SetChauffe(true);
end;

procedure TdbpProcesseur.ArreteDeChauffer;
begin
 SetChauffe(False);
end;

constructor TdbpProcesseur.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FChauffe        := False;
 FFinChauffe     := True;
 FTBFull         := False;
 FInterval       := 500;
 FTimer          := TTimer.Create(self);
 FTimer.Enabled  := False;
 FTimer.Interval := FInterval;
 FTimer.OnTimer  := ActTimer;
end;

destructor TdbpProcesseur.destroy;
begin
  SetChauffe(false);
  inherited Destroy;
  FTimer := nil;
end;

procedure Register;
begin
  RegisterComponents('Diabloporc', [TdbpProcesseur]);
end;

end.

Télécharger le zip