Утилита диагностики компьютера (стр. 5 из 6)

Case DriveType Of

0: Result := '?';

1: Result := 'Path does not exists';

Drive_Removable: Result := 'Removable';

Drive_Fixed : Result := 'Fixed';

Drive_Remote : Result := 'Remote';

Drive_CDROM : Result := 'CD-ROM';

Drive_RamDisk : Result := 'RAMDisk'

else

Result := 'Unknown';

end;

function GettingHWProfileName: String;

var

pInfo: TagHW_PROFILE_INFOA;

begin

GetCurrentHwProfile(pInfo);

Result := pInfo.szHwProfileName;

end;

procedure TDiadnostic.FormCreate(Sender: TObject);

var OsVerInfo:Tosversioninfo;

winver,build:string;

Disks:byte;

buffer:array[0..255]of char;

wd:string;

sp:array[0..max_path-1]of char;

s:string;

memorystatus:tmemorystatus;

dwLength:DWORD; // sizeof(MEMORYSTATUS)

dwMemoryLoad:DWORD; // percent of memory in use

dwTotalPhys:DWORD ; // bytes of physical memory

dwAvailPhys:DWORD ; // free physical memory bytes

dwTotalPageFile:DWORD ; // bytes of paging file

dwAvailPageFile:DWORD ;// free bytes of paging file

dwTotalVirtual:DWORD ;// user bytes of address space

dwAvailVirtual:DWORD ; // free user bytes

ktype:integer;

R:Tregistry;

R2:Tregistry;

disk1:integer;

msgtext:string;

const monitorregdir:string='\system\currentcontrolset\ENUM\Display\Default_Monitor';

videordir:string='\System\currentcontrolset\services\class\display\0000';

processordir:string='Hardware\Description\System\Centralprocessor\0';

begin

button2.click;

Label50.Caption:=GettingHWProfileName;

listbox1.items:=screen.fonts;

numofbuttons.caption:=inttostr(getsystemmetrics(sm_cmousebuttons));

if getsystemmetrics(sm_mousepresent)<>0then ismouse.caption:='Есть'else

ismouse.caption:='Нет';

for disk1:=0 to diskname.items.count-1 do

begin

disk.lines.add(diskname.items[disk1]+' '+CheckDriveType(diskname.items[disk1][1]));

end;

{monitor&video}

///////

R:=tregistry.create;

R.RootKey:=HKEY_LOCAL_MACHINE;

R.OpenKey(monitorregdir,false);

monitortype.caption:=R.ReadString('DeviceDesc');

monitormanufacturer.caption:=R.ReadString('Mfg');

monitorid.caption:=r.readstring('HardwareID');

R.OpenKey(videordir,false);

//drvdesc.caption:=r.ReadString('DriverDesc');

driverdate.caption:=r.readstring('DriverDate');

drvprovider.caption:=r.readstring('ProviderName');

driverver.caption:=r.readstring('ver');

r.closekey;

getinfovideo;

//////

{Version BIOS}

GetRegInfoWinNT;

{advanced processor info}

R2:=Tregistry.create;

R2.RootKey:=HKEY_LOCAL_MACHINE;

r2.OpenKey(processordir,false);

processorname.caption:=r2.readstring('Identifier');

vident.caption:=r2.readstring('VendorIdentifier');

if not (r2.readstring('MMXIdentifier')='')then

mmx1.caption:=r2.readstring('MMXIdentifier')

else

mmx1.caption:='нет';

Label48.Caption:=inttostr(Trunc(GetCPUSpeed))+' MHz';

{}

{memory}

memorystatus.dwlength:=sizeof(memorystatus);

globalmemorystatus(memorystatus);

physmemory.caption:=floattostr(memorystatus.dwtotalphys div 1024 div 1024)+' Мега '+'('+

floattostr(memorystatus.dwtotalphys / 1024 / 1024)+')';

avail.caption:=floattostr(memorystatus.dwavailphys / 1024 / 1024)+' Мег';

maxpf.caption:=floattostr(memorystatus.dwtotalpagefile / 1024 / 1024);

pffree.caption:=floattostr(memorystatus.dwavailpagefile / 1024 / 1024);

{}

{Windows info}

winid.caption:=getwinid;

winkey.caption:=getwinkey;

ver1.Caption:=getwinname;

username.caption:=getusernme;

//plusver.caption:=getplusvernum;

company.caption:=getorgname;

resolution.caption:=getscreenresolution;

{printer}

try

getprofilestring('windows','device',',,,',buffer,256);

s:=strpas(buffer);

defprn.Lines.add(' Принтер: '+copy(s,1,pos(',',s)-1));

delete(s,1,pos(',',s)-1);

defprn.lines.add(' Порт: '+copy(s,1,pos(',',s)-1));

delete(s,1,pos(',',s)-1);

defprn.lines.add(' Драйвер и порт:'+ s);

except

showmessage('Printer not found');

end;

{keyboard}

ktype:=GetKeyboardType(0);

case ktype of

1:keytype.caption:='IBM PC/XT или совместимая (83-клавииши)';

2:keytype.caption:='Olivetti "ICO" (102-клавиши)';

3:keytype.caption:='IBM PC/AT (84-клавиши) и другие';

4:keytype.caption:='IBM-расширенная (101/102-клавиши)';

5:keytype.caption:='Nokia 1050 and similar keyboards';

6:keytype.caption:='Nokia 9140 and similar keyboards';

7:keytype.caption:='Japanese keyboard';

end;

numoffunckey.Caption:=inttostr(getkeyboardtype(2));

{

typ.hide;

label14.hide;

{windir}

getwindowsdirectory(sp,max_path);

wd:=strpas(sp);

{windir.caption:=wd;

progrfiles.caption:=getprogramfilesdir;

label13.hide;

label12.hide;

{Windows version}

OSVerInfo.dwOsversioninfosize:=sizeof(osverinfo);

getversionex(osverinfo);

case osverinfo.dwplatformid of

ver_platform_win32s:os.caption:='Windows 3.x';

ver_platform_win32_windows:os.Caption:='Windows 95 (98)';

ver_platform_win32_nt:os.caption:='Windows NT';

end;

with osverinfo do

begin

winver:=format('%d.%d',[dwmajorversion, dwminorversion]);

build:=format('%d', [LoWord(dwbuildnumber)]);

osver.caption:=winver;

osver.caption:=osver.caption+' (сборка: '+build+')';

end;

{boot}

{oottype.caption:=getboottype;

{printer}

{Prntrs.items:=Printer.Printers;}

prn.items:=Printer.Printers;

try

fnt.items:=printer.fonts;

except

end;

prn.ItemIndex:=0;

edit2.text:=inttostr(printer.pageheight);

edit1.text:=inttostr(printer.pagewidth);

GetPrName(Processor1);

GetPrName(pt);

resolution.Caption :=inttostr(Screen.Width)+'на'+inttostr(Screen.Height);

timer1.Enabled:=true;

end;

function OpenCD(Drive : Char) : Boolean;

Var

Res : MciError;

OpenParm: TMCI_Open_Parms;

Flags : DWord;

S : String;

DeviceID : Word;

begin

Result := False;

S := Drive + ':';

Flags := mci_Open_Type or mci_Open_Element;

With OpenParm do begin

dwCallback := 0;

lpstrDeviceType := 'CDAudio';

lpstrElementName := PChar(S);

end;

{Эта строчка необходима для правильной работы функции IntellectCD}

Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));

IF Res <> 0 Then Exit;

DeviceID := OpenParm.wDeviceID;

try

Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);

IF Res = 0 Then Exit;

Result := True;

finally

mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));

end;

function CloseCD(Drive : Char) : Boolean;

Var

Res : MciError;

OpenParm: TMCI_Open_Parms;

Flags : DWord;

S : String;

DeviceID : Word;

begin

Result := False;

S := Drive + ':';

Flags := mci_Open_Type or mci_Open_Element;

With OpenParm do begin

dwCallback := 0;

lpstrDeviceType := 'CDAudio';

lpstrElementName := PChar(S);

end;

Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));

IF Res <> 0 Then Exit;

DeviceID := OpenParm.wDeviceID;

try

Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

IF Res = 0 Then

Result := True;

finally

mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));

end;

procedure Delay(msecs : Longint);

var

FirstTick : Longint;

begin

FirstTick := GetTickCount;

repeat

Application.ProcessMessages;

until GetTickCount - FirstTick >= msecs;

end;

procedure TDiadnostic.Button1Click(Sender: TObject);

var disk1:integer;

begin

for disk1:=0 to diskname.items.count-1 do

begin

if CheckDriveType(diskname.items[disk1][1])='CD-ROM'

then

begin

opencd(diskname.items[disk1][1]);

delay(5000);

closecd(diskname.items[disk1][1]);

end;

procedure TDiadnostic.SpeedButton1Click(Sender: TObject);

begin

form1.show;

end;

procedure TDiadnostic.SpeedButton2Click(Sender: TObject);

begin

//ShellExecute(handle,nil,'mem.exe',nil,nil,sw_restore);

MessageDlg('Тестирующая программа загружена в оперативную память',mtInformation,[mbok],0);

end;

end.

//модуль тестирования процессора

unit ProcessorClockCounter;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TClockPriority=(cpIdle, cpNormal, cpHigh, cpRealTime, cpProcessDefined);

TPrecizeProc = procedure(Sender: TObject) of Object;

TProcessorClockCounter = class(TComponent)

private

FCache:array[0..(1 shl 19) - 1] of byte; // 512 Kb NOP instructions is enough to clear cache

FStarted:DWORD;

FClockPriority:TClockPriority;

FProcessHandle:HWND;

FCurrentProcessPriority: Integer;

FDesiredProcessPriority: Integer;

FThreadHandle:HWND;

FCurrentThreadPriority: Integer;

FDesiredThreadPriority: Integer;

FCalibration:int64; //used to

FPrecizeCalibration:int64;

FStartValue:int64;

FStopValue:int64;

FDeltaValue:int64;

FPrecizeProc:TPrecizeProc;

FCounterSupported:boolean;

procedure PrecizeStart;

procedure PrecizeStartInCache;

procedure GetProcInf;

procedure SetClockPriority(Value: TClockPriority);

procedure ProcedureWithoutInstruction; //description is in code

function GetClock:Int64; register;

function GetStarted:Boolean;

protected

procedure AdjustPriority; virtual; // internal used in constructor to setup parameters when class is created in RunTime

function CheckCounterSupported:boolean;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Calibrate;

procedure Start;

procedure Stop;

procedure EraseCache;

procedure TestPrecizeProc; virtual;

procedure TestPrecizeProcInCache; virtual;

property Counter:int64 read FDeltaValue; // contain the measured test clock pulses (StopValue - StartValue - Calibration)

property StartValue:int64 read FStartValue; // Value on the begining

property StopValue:int64 read FStopValue; // Value on test finished

property Started:Boolean read GetStarted;

property CurrentClock:int64 read GetClock; // for longer tests this could be use to get current counter

published

property ClockPriority:TClockPriority read FClockPriority write SetClockPriority default cpNormal;

property Calibration:int64 read FCalibration; // this is used to nullify self code execution timing

property OnPrecizeProc:TPrecizeProc read FPrecizeProc write FPrecizeProc; // user can define it for testing part of code inside it

property CounterSupported:boolean read FCounterSupported;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('ASM Utils', [TProcessorClockCounter]);

end;

constructor TProcessorClockCounter.Create(AOwner: TComponent);

var n:integer;

begin

inherited create(AOwner);

FCounterSupported:=CheckCounterSupported;

for n:=0 to High(FCache)-1 do FCache[n]:=$90; // fill with NOP instructions

FCache[High(FCache)]:=$C3; // the last is the RET instruction

FClockPriority:=cpNormal;

FStarted:=0;

FDesiredProcessPriority:=NORMAL_PRIORITY_CLASS;

FDesiredThreadPriority :=THREAD_PRIORITY_NORMAL;

AdjustPriority;

Calibrate;

FStartValue:=0;

FStopValue:=0;

FDeltaValue:=0;

end;

destructor TProcessorClockCounter.Destroy;

begin

inherited destroy;

end;

procedure TProcessorClockCounter.GetProcInf;

begin

FProcessHandle:=GetCurrentProcess;

FCurrentProcessPriority:=GetPriorityClass(FProcessHandle);

FThreadHandle:=GetCurrentThread;

FCurrentThreadPriority:=GetThreadPriority(FThreadHandle);

end;

procedure TProcessorClockCounter.AdjustPriority;

begin

GetProcInf;

case FDesiredProcessPriority of

IDLE_PRIORITY_CLASS: FClockPriority:=cpIdle;

NORMAL_PRIORITY_CLASS: FClockPriority:=cpNormal;

HIGH_PRIORITY_CLASS: FClockPriority:=cpHigh;

REALTIME_PRIORITY_CLASS: FClockPriority:=cpRealTime;

end;

procedure TProcessorClockCounter.SetClockPriority(Value: TClockPriority);

begin

if Value<>FClockPriority then

begin

FClockPriority:=Value;

case FClockPriority of

cpIdle: begin

FDesiredProcessPriority:=IDLE_PRIORITY_CLASS;

FDesiredThreadPriority :=THREAD_PRIORITY_IDLE;

end;

cpNormal: begin

FDesiredProcessPriority:=NORMAL_PRIORITY_CLASS;

FDesiredThreadPriority :=THREAD_PRIORITY_NORMAL;

end;

cpHigh: begin

FDesiredProcessPriority:=HIGH_PRIORITY_CLASS;

FDesiredThreadPriority :=THREAD_PRIORITY_HIGHEST;

end;

cpRealTime:begin

FDesiredProcessPriority:=REALTIME_PRIORITY_CLASS;

FDesiredThreadPriority :=THREAD_PRIORITY_TIME_CRITICAL;

end;

cpProcessDefined:

begin

FDesiredProcessPriority:=FCurrentProcessPriority;

FDesiredThreadPriority :=FCurrentThreadPriority;

end;

Calibrate;

end;

procedure TProcessorClockCounter.TestPrecizeProc;

// This procedure is intended for testing small block of

// code when it must be put in the processor cache

begin

FDeltaValue:=0;

if FCounterSupported and assigned(FPrecizeProc) then

begin

PrecizeStart; // start test

end;

procedure TProcessorClockCounter.TestPrecizeProcInCache;

// This procedure is intended for testing small block of

// code when it is already in the processor cache

begin

FDeltaValue:=0;

if FCounterSupported and assigned(FPrecizeProc) then

begin

EraseCache;

PrecizeStartInCache; // first test will fill processor cache

PrecizeStartInCache; // second test

// generate calibration value for

// code already put in the cache

end;

procedure TProcessorClockCounter.ProcedureWithoutInstruction;

// this is used for calibration! DO NOT CHANGE

asm

ret

end;

procedure TProcessorClockCounter.EraseCache; register;

asm

push ebx

lea ebx,[eax + FCache]

call ebx // force call to code in array :)

pop ebx // this will fill level2 cache with NOPs (For motherboards with 1 Mb level 2 cache,

ret // size of array should be increased to 1 Mb)

// next instructions are never executed but need for proper align of 16 byte.

// Some processors has different execution times when code is not 16 byte aligned

// Actually, (on some processors), internal mechanism of level 1 cache (cache built

// in processor) filling is designed to catch memory block faster, when

// it is 16 byte aligned !!!

nop

end;

function TProcessorClockCounter.GetClock: Int64; register;

asm

push edx

push ebx

push eax

mov ebx,eax

xor eax,eax // EAX & EDX are initialized to zero for

mov edx,eax // testing counter support

DW $310f // This instruction will make exception

sub eax,dword ptr [ebx+FStartValue] // or do nothing on processors wthout

sbb edx,dword ptr [ebx+FStartValue+4] // counter support

sub eax,dword ptr [ebx+FCalibration]

sbb edx,dword ptr [ebx+FCalibration+4]

mov dword ptr [esp + $10],eax

mov dword ptr [esp + $14],edx

pop eax

pop ebx

pop edx

ret

end;

procedure TProcessorClockCounter.PrecizeStartInCache; register;