Аппаратная характеристика ПК

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, Buttons, StdCtrls, unit1;

type

TForm2 = class(TForm)

Edit1: TEdit;

Edit2: TEdit;

SpeedButton1: TSpeedButton;

Memo1: TMemo;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

procedure SpeedButton1Click(Sender: TObject);

procedure FormActivate(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form2: TForm2;

implementation

{$R *.dfm}

function GetComputerNetName:string; //узнаем имя компьютера

var

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

size:DWORD;

begin

size:=256;

if GetComputerName(buffer,size) then

Result:=buffer

else Result:= '';

end;

function GetCurrentUserName:String; //узнаем имя текущего пользователя

const

cnMaxUserNameLen=254;

var

sUserName:String;

dwUserNameLen:DWORD;

begin

dwUserNameLen:=cnMaxUserNameLen-1;

SetLength(sUserName,cnMaxUserNameLen);

GetUserName(PChar(sUserName),dwUserNameLen);

SetLength(sUserName,dwUserNameLen);

Result:=sUserName;

end;

procedure TForm2.SpeedButton1Click(Sender: TObject); //информация о пользователе

const

TokenSize=800; // расчет (SizeOf(Pointer)=4 *200)

var

hToken:THandle;

pTokenInfo:PTOKENPRIVILEGES;

ReturnLen:Cardinal;

i:Integer;

PrivName:PChar;

DisplayName:PChar;

NameSize:Cardinal;

DisplSize:Cardinal;

LangId:Cardinal;

begin

Memo1.Lines.Clear;

Edit1.text:=GetComputerNetName; //вызываем функцию имени "имя компьютера"

Edit2.text:= GetCurrentUserName; //вызываем функцию "имя пользователя"

GetMem(pTokenInfo, TokenSize);

if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,hToken) then ShowMessage('OpenProcessToken error');

if not GetTokenInformation(hToken, TokenPrivileges, pTokenInfo, TokenSize, ReturnLen) then

ShowMessage('GetTokenInformation error');

GetMem(PrivName, 255);

GetMem(DisplayName, 255);

for i := 0 to pTokenInfo.PrivilegeCount - 1 do

begin

DisplSize := 255;

NameSize := 255;

LookupPrivilegeName(nil, pTokenInfo.Privileges[i].Luid, PrivName, Namesize);

LookupPrivilegeDisplayName(nil, PrivName, DisplayName, DisplSize, LangId);

memo1.lines.Add(PrivName +^I + DisplayName);

end;

FreeMem(PrivName);

FreeMem(DisplayName);

FreeMem(pTokenInfo);

end;

procedure TForm2.FormActivate(Sender: TObject); //плавно всплывающее окно для формы 2

const

n=127;

var

i:Byte;

begin

AlphaBlend:=True;

for i:=1 to n do

begin

AlphaBlendValue:=i*2;

Repaint;

end;

end;

procedure TForm2.FormCreate(Sender: TObject);

begin

Form2.Left:=(Screen.Width-Form2.Width) div 2; //по середине моннитора

Form2.Top:=(Screen.Height-Form2.Height) div 2;

end;

end.

ПРИЛОЖЕНИЕ В

unit Unit3;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, unit1, ComCtrls;

type

TForm3 = class(TForm)

TreeView1: TTreeView;

procedure FormCreate(Sender: TObject);

procedure TreeView1Expanding(Sender: TObject; Node: TTreeNode;

var AllowExpansion: Boolean);

procedure FormActivate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form3: TForm3;

implementation

{$R *.dfm}

procedure NextLevel(ParentNode: TTreeNode); //переключение и показ папок на лок дисках

function DirectoryName(name: string): boolean;

begin

result:=(name<>'.') and (name<>'..');

end;

var

sr, srChild: TSearchRec;

node: TTreeNode;

path: string;

begin

node:=ParentNode;

path:='';

repeat

path:=node.Text+'\'+path;

node:=node.Parent;

until node=nil;

if FindFirst(path+'*.*', faDirectory, sr)=0 then

begin

repeat

if (sr.Attr and faDirectory <> 0) and DirectoryName(sr.Name)

then

begin

node:=Form3.TreeView1.Items.AddChild(ParentNode, sr.Name);

node.ImageIndex:=0;

node.SelectedIndex:=1;

node.HasChildren:=false;

if FindFirst(path+sr.Name+'\*.*', faDirectory, srChild)=0

then

begin

repeat

if (srChild.Attr and faDirectory<>0) and DirectoryName(srChild.Name)

then node.HasChildren := true;

until (FindNext(srChild) <> 0) or node.HasChildren;

end;

FindClose(srChild);

end;

until FindNext(sr) <> 0;

end

else ParentNode.HasChildren:=false;

FindClose(sr);

end;

procedure TForm3.FormCreate(Sender: TObject); //показать локальные диски и находящиеся

//в них папки

const

IconNames:array [0..6] of String=('CLOSEDFOLDER','OPENFOLDER','FLOPPY','HARD','NETWORK','CDROM','RAM');

var

c:Char;

s:String;

Node:TTreeNode;

DriveType:Integer;

bm,mask:TBitmap;

i:Integer;

begin

Form3.Left:=(Screen.Width-Form3.Width) div 2; //по середине моннитора

Form3.Top:=(Screen.Height-Form3.Height) div 2;

TreeView1.Items.BeginUpdate;

TreeView1.Images:=TImageList.CreateSize(16, 16);

bm:=TBitmap.Create;

mask:=TBitmap.Create;

for i:=low(IconNames) to high(IconNames) do

begin

bm.Handle:=LoadBitmap(HInstance, PChar(IconNames[i]));

bm.Width:=16;

bm.Height:=16;

mask.Assign(bm);

mask.Mask(clBlue);

TreeView1.Images.Add(bm, mask);

end;

for c:='A' to 'Z' do

begin

s:=c+':';

DriveType:=GetDriveType(PChar(s));

if DriveType=1 then continue;

node:=Form3.TreeView1.Items.AddChild(nil, s);

case DriveType of

DRIVE_REMOVABLE: node.ImageIndex:=2;

DRIVE_FIXED: node.ImageIndex:=3;

DRIVE_REMOTE: node.ImageIndex:=4;

DRIVE_CDROM: node.ImageIndex:=5;

else node.ImageIndex:=6;

end;

node.SelectedIndex:=node.ImageIndex;

node.HasChildren:=true;

end;

TreeView1.Items.EndUpdate;

end;

procedure TForm3.TreeView1Expanding(Sender: TObject; Node: TTreeNode;

var AllowExpansion: Boolean);

begin

TreeView1.Items.BeginUpdate;

Node.DeleteChildren;

NextLevel(Node);

TreeView1.Items.EndUpdate;

end;

procedure TForm3.FormActivate(Sender: TObject); //плавно всплывающее окно для формы 3

const n=127;

var

i:Byte;

begin

AlphaBlend:=True;

for i:=1 to n do

begin

AlphaBlendValue:=i*2;

Repaint;

end;

end;

end.

ПРИЛОЖЕНИЕ Г

unit Unit4;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, Winsock, registry, ExtCtrls, StdCtrls, ImgList, Buttons, ShellAPI, ComCtrls;

type

TForm4 = class(TForm)

Image1: TImage;

Timer1: TTimer;

StatusBar1: TStatusBar;

ImageList1: TImageList;

Image2: TImage;

procedure FormShow(Sender: TObject);

procedure Timer1Timer(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormActivate(Sender: TObject);

procedure Image2Click(Sender: TObject);

private

{ Private declarations }

public

procedure info(s1, s2: string);

end;

var

Form4: TForm4;

gn_speed_y: Integer;

gn_text_y: Integer;

_eax, _ebx, _ecx, _edx: Longword;

i: Integer;

b: Byte;

b1: Word;

s,s1,s2,s3,s_all:string;

q:TImageIndex;

lpDisplayDevice: TDisplayDevice;

dwFlags: DWORD;

cc: DWORD;

const

gn_speed_x: Integer =8;

gn_text_x: Integer =15;

gl_start: Boolean =True;

implementation

{$R *.dfm}

procedure TForm4.FormShow(Sender: TObject);

var

_eax, _ebx, _ecx, _edx: Longword;

i: Integer;

b: Byte;

s, s1, s2, s3, s_all: string;

MS:TMemoryStatus;

wVerReq: WORD;

wsaData: TWSAData;

iw: pchar;

h: PHostEnt;

c: array[0..128] of char;

isa:integer;

ld:DWORD;

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

OSVersion:TOSVersionInfo;

begin

info('','');

//Set the startup colour of the image

Image1.Canvas.Brush.Color:=clBtnFace;

Image1.Canvas.FillRect(rect(0, 0, Image1.Width,Image1.Height));

begin

asm //get brand ID

mov eax,$80000002

db $0F

db $A2

mov _eax,eax

mov _ebx,ebx

mov _ecx,ecx

mov _edx,edx

end;

s := '';

s1 := '';

s2 := '';

s3 := '';

for i := 0 to 3 do

begin

b := lo(_eax);

s3:= s3 + chr(b);

b := lo(_ebx);

s := s + chr(b);

b := lo(_ecx);

s1 := s1 + chr(b);

b := lo(_edx);

s2 := s2 + chr(b);

_eax := _eax shr 8;

_ebx := _ebx shr 8;

_ecx := _ecx shr 8;

_edx := _edx shr 8;

end;

s_all := s3 + s + s1 + s2;

asm

mov eax,$80000003

db $0F

db $A2

mov _eax,eax

mov _ebx,ebx

mov _ecx,ecx

mov _edx,edx

end;

s := '';

s1 := '';

s2 := '';

s3 := '';

for i := 0 to 3 do

begin

b := lo(_eax);

s3 := s3 + chr(b);

b := lo(_ebx);

s := s + chr(b);

b := lo(_ecx);

s1 := s1 + chr(b);

b := lo(_edx);

s2 := s2 + chr(b);

_eax := _eax shr 8;

_ebx := _ebx shr 8;

_ecx := _ecx shr 8;

_edx := _edx shr 8;

end;

s_all := s_all + s3 + s + s1 + s2;

asm

mov eax,$80000004

db $0F

db $A2

mov _eax,eax

mov _ebx,ebx

mov _ecx,ecx

mov _edx,edx

end;

s := '';

s1 := '';

s2 := '';

s3 := '';

for i := 0 to 3 do

begin

b := lo(_eax);

s3 := s3 + chr(b);

b := lo(_ebx);

s := s + chr(b);

b := lo(_ecx);

s1 := s1 + chr(b);

b := lo(_edx);

s2 := s2 + chr(b);

_eax := _eax shr 8;

_ebx := _ebx shr 8;

_ecx := _ecx shr 8;

_edx := _edx shr 8;

end;

if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);

info('', 'Процессор - ' + s_all + s3 + s + s1 + s2);

end;

lpDisplayDevice.cb := sizeof(lpDisplayDevice);

while EnumDisplayDevices(nil, cc, lpDisplayDevice, dwFlags) do

begin

Inc(cc);

begin

info('', 'Видео карта - ' + lpDisplayDevice.DeviceString);

end

end;

begin

GlobalMemoryStatus(MS);

begin

info('', 'Оперативня память - '+FormatFloat('#,###" Мгб"', MS.dwTotalPhys / 1044484) );

end

end;

begin

OSVersion.dwOSVersionInfoSize := SizeOf(OSVersion);

if GetVersionEx(OSVersion) then

info('', 'Версия операционной системы - ' + Format('%d.%d (%d.%s)',[OSVersion.dwMajorVersion,OSVersion.dwMinorVersion,(OSVersion.dwBuildNumber and $FFFF),OSVersion.szCSDVersion]));

end;

begin

ld:=GetLogicalDrives;

for isa:=0 to 25 do

begin

if (ld and (1 shl isa))<>0 then

if GetDriveType(PChar(Char(Ord('A')+isa) + ':\'))=DRIVE_FIXED then

info('','HDD - ' +Char(Ord('A')+isa)+':\');

if GetDriveType(PChar(Char(Ord('A')+isa) + ':\'))=DRIVE_REMOVABLE then

info('','Floppy - '+Char(Ord('A')+isa)+':\');

if GetDriveType(PChar(Char(Ord('A')+isa)+':\'))=DRIVE_CDROM then

info('','CD-Rom - '+Char(Ord('A')+isa)+':\');

end;

begin

wVerReq:=MAKEWORD(1,1);

WSAStartup(wVerReq,wsaData);

GetHostName(@c,128);

h:=GetHostByName(@c);

iw:=iNet_ntoa(PInAddr(h^.h_addr_list^)^);

WSACleanup;

begin

info('','IP - '+iw);

end;

begin

info('','HOST - '+h^.h_Name);

end;

end;

begin

FillChar(PathArray,SizeOf(PathArray),#0);

GetWindowsDirectory(PathArray,255);

info('','Дериктория Windows - '+Format('%s',[PathArray]));

end;

end;

end;

procedure TForm4.info(s1, s2: string);

begin

if s1 <> '' then

begin

Image1.Canvas.Brush.Color := clBtnFace;

Image1.Canvas.Font.Color := clBlack;

Image1.Canvas.TextOut(gn_text_x, gn_text_y, s1);

end;

if s2 <> '' then

begin

Image1.Canvas.Brush.Color := clBtnFace;

Image1.Canvas.Font.Color := clBlack;

Image1.Canvas.TextOut(gn_text_x + Image1.Canvas.TextWidth(s1), gn_text_y, s2);

end;

Inc(gn_text_y, 13);

end;

procedure TForm4.Timer1Timer(Sender: TObject);

begin

StatusBar1.Panels[0].Text:='Сейчас: '+DateToStr(Now)+' '+TimeToStr(Now);

end;

procedure TForm4.FormCreate(Sender: TObject);

begin

Form4.Left:=(Screen.Width-Form4.Width) div 2; //по середине моннитора

Form4.Top:=(Screen.Height-Form4.Height) div 2;

end;

procedure TForm4.FormActivate(Sender: TObject);

const

n=127;

var

i:Byte;

begin

AlphaBlend:=True;

for i:=1 to n do

begin

AlphaBlendValue:=i*2;

Repaint;

end;

end;

procedure TForm4.Image2Click(Sender: TObject);

var

reestr : TRegistry;

begin

reestr:=TRegistry.Create;

reestr.RootKey := HKEY_CURRENT_USER;

Reestr.OpenKey('SOFTWARE\MICROSOFT\Internet Explorer\Main',True);

close;

end;

end.

Размещено на Allbest.ru