Composant tdbpprocesseur : des infos sur le proc et son utilisation !!

Télécharger le projet
Commenter

Description

hello,

petit compo tres utile pour connaitre l'utilisation de son proc, le temps d'utilisation, et des infos (MHz, fabriquant, etc)

bye

Source / Exemple : 


{
################################################################################
# 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.

Conclusion :


bug ou autre : msg ou mail merci
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (JulioDelphi)