روش بدست آوردن اطلاعات Cpu
روش بدست آوردن اطلاعات CPU
کد:
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
Tfrm_main = class(TForm)
img_info: TImage;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure info(s1, s2: string);
end;
var
frm_main: Tfrm_main;
gn_speed_y: Integer;
gn_text_y: Integer;
const
gn_speed_x: Integer = 8;
gn_text_x: Integer = 15;
gl_start: Boolean = True;
implementation
{$R *.DFM}
procedure Tfrm_main.FormShow(Sender: TObject);
var
_eax, _ebx, _ecx, _edx: Longword;
i: Integer;
b: Byte;
b1: Word;
s, s1, s2, s3, s_all: string;
begin
//Set the startup colour of the image
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));
gn_text_y := 5; //position of the 1st text
asm //asm call to the CPUID inst.
mov eax,0 //sub. func call
db $0F,$A2 //db $0F,$A2 = CPUID instruction
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
for i := 0 to 3 do //extract vendor id
begin
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1:= s1 + chr(b);
b := lo(_edx);
s2:= s2 + chr(b);
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('CPU', '');
info(' - ' + 'Vendor ID: ', s + s2 + s1);
asm
mov eax,1
db $0F,$A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
//06B1
//|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
b := lo(_eax) and 15;
info(' - ' + 'Stepping ID: ', IntToStr(b));
b := lo(_eax) shr 4;
info(' - ' + 'Model Number: ', IntToHex(b, 1));
b := hi(_eax) and 15;
info(' - ' + 'Family Code: ', IntToStr(b));
b := hi(_eax) shr 4;
info(' - ' + 'Processor Type: ', IntToStr(b));
//31. 28. 27. 24. 23. 20. 19. 16.
// 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
b := lo((_eax shr 16)) and 15;
info(' - ' + 'Extended Model: ', IntToStr(b));
b := lo((_eax shr 20));
info(' - ' + 'Extended Family: ', IntToStr(b));
b := lo(_ebx);
info(' - ' + 'Brand ID: ', IntToStr(b));
b := hi(_ebx);
info(' - ' + 'Chunks: ', IntToStr(b));
b := lo(_ebx shr 16);
info(' - ' + 'Count: ', IntToStr(b));
b := hi(_ebx shr 16);
info(' - ' + 'APIC ID: ', IntToStr(b));
//Bit 18 =? 1 //is serial number enabled?
if (_edx and $40000) = $40000 then
info(' - ' + 'Serial Number ', 'Enabled')
else
info(' - ' + 'Serial Number ', 'Disabled');
s := IntToHex(_eax, 8);
asm //determine the serial number
mov eax,3
db $0F,$A2
mov _ecx,ecx
mov _edx,edx
end;
s1 := IntToHex(_edx, 8);
s2 := IntToHex(_ecx, 8);
Insert('-', s, 5);
Insert('-', s1, 5);
Insert('-', s2, 5);
info(' - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);
asm
mov eax,1
db $0F,$A2
mov _edx,edx
end;
info('', '');
//Bit 23 =? 1
if (_edx and $800000) = $800000 then
info('MMX ', 'Supported')
else
info('MMX ', 'Not Supported');
//Bit 24 =? 1
if (_edx and $01000000) = $01000000 then
info('FXSAVE & FXRSTOR Instructions ', 'Supported')
else
info('FXSAVE & FXRSTOR Instructions Not ', 'Supported');
//Bit 25 =? 1
if (_edx and $02000000) = $02000000 then
info('SSE ', 'Supported')
else
info('SSE ', 'Not Supported');
//Bit 26 =? 1
if (_edx and $04000000) = $04000000 then
info('SSE2 ', 'Supported')
else
info('SSE2 ', 'Not Supported');
info('', '');
asm //execute the extended CPUID inst.
mov eax,$80000000 //sub. func call
db $0F,$A2
mov _eax,eax
end;
if _eax > $80000000 then //any other sub. funct avail. ?
begin
info('Extended CPUID: ', 'Supported');
info(' - Largest Function Supported: ', IntToStr(_eax - $80000000));
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;
info('Brand String: ', '');
if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
info('', ' - ' + s_all + s3 + s + s1 + s2);
end
else
info(' - Extended CPUID ', 'Not Supported.');
end;
procedure Tfrm_main.info(s1, s2: string);
begin
if s1 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clyellow;
img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
end;
if s2 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clWhite;
img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
end;
Inc(gn_text_y, 13);
end;
end.
مشخص كردن وجود Terminal Service ها
مشخص كردن وجود Terminal Service ها
کد:
function IsRemoteSession: Boolean;
const
sm_RemoteSession = $1000; { from WinUser.h }
begin
Result := (GetSystemMetrics(sm_RemoteSession) <> 0);
end;
کد:
type
OSVERSIONINFOEX = packed record
dwOSVersionInfoSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
szCSDVersion: array[0..127] of Char;
wServicePackMajor: WORD;
wServicePackMinor: WORD;
wSuiteMask: WORD;
wProductType: BYTE;
wReserved: BYTE;
end;
TOSVersionInfoEx = OSVERSIONINFOEX;
POSVersionInfoEx = ^TOSVersionInfoEx;
const
VER_SUITE_TERMINAL = $00000010;
VER_SUITENAME = $00000040;
VER_AND = 6;
function VerSetConditionMask(
ConditionMask: int64;
TypeMask: DWORD;
Condition: Byte
): int64; stdcall; external kernel32;
function VerifyVersionInfo(
var VersionInformation: OSVERSIONINFOEX;
dwTypeMask: DWORD;
dwlConditionMask: int64
): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';
function IsTerminalServicesEnabled: Boolean;
var
osVersionInfo: OSVERSIONINFOEX;
dwlConditionMask: int64;
begin
FillChar(osVersionInfo, SizeOf(osVersionInfo), 0);
osVersionInfo.dwOSVersionInfoSize := sizeof(osVersionInfo);
osVersionInfo.wSuiteMask := VER_SUITE_TERMINAL;
dwlConditionMask := 0;
dwlConditionMask :=
VerSetConditionMask(dwlConditionMask,
VER_SUITENAME,
VER_AND);
Result := VerifyVersionInfo(
osVersionInfo,
VER_SUITENAME,
dwlConditionMask);
end;
تعيين نسخه MS Word نصب شده روي كامپيوتر
تعيين نسخه MS Word نصب شده روي كامپيوتر
کد:
uses ComObj;
{
const
Wordversion97 = 8;
Wordversion2000 = 9;
WordversionXP = 10;
Wordversion2003 = 11;
}
function GetInstalledWordVersion: Integer;
var
word: OLEVariant;
begin
word := CreateOLEObject('Word.Application');
result := word.version;
word.Quit;
word := UnAssigned;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetInstalledWordVersion));
end;
وارد كردن يك متن RTF در Word
وارد كردن يك متن RTF در Word
کد:
uses
Word_TLB, ActiveX, ComObj;
function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
Formats: IEnumFORMATETC;
TempFormat: TFormatEtc;
pFormatName: PChar;
Found: Boolean;
begin
try
OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
Found := False;
while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
begin
pFormatName := AllocMem(255);
GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
if (string(pFormatName) = 'Rich Text Format') then
begin
RTFFormat := TempFormat;
Found := True;
end;
FreeMem(pFormatName);
end;
Result := Found;
except
Result := False;
end;
end;
procedure WriteToMSWord(const RTFText: String);
var
WordDoc: _Document;
WordApp: _Application;
DataObj : IDataObject;
Formats : IEnumFormatEtc;
RTFFormat: TFormatEtc;
Medium : TStgMedium;
pGlobal : Pointer;
begin
try
GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
except
WordApp := CoWordApplication.Create;
end;
WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
WordApp.Visible := True;
WordDoc := WordApp.ActiveDocument;
OleCheck(WordDoc.QueryInterface(IDataObject,DataObj));
GetRTFFormat(DataObj, RTFFormat);
FillChar(Medium,SizeOf(Medium),0);
Medium.tymed := RTFFormat.tymed;
Medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(RTFText)+1);
try
pGlobal := GlobalLock(Medium.hGlobal);
CopyMemory(PGlobal,PChar(RTFText),Length(RTFText)+1);
GlobalUnlock(Medium.hGlobal);
OleCheck(DataOBJ.SetData(RTFFormat,Medium,True));
finally
GlobalFree(Medium.hGlobal);
ReleaseStgMedium(Medium);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
WriteToMSWord(Memo1.Text); // may be rtf-formatted text
end;
فشرده سازي و ترميم يك بانك اطلاعاتي Access
فشرده سازي و ترميم يك بانك اطلاعاتي Access
کد:
uses
ComObj;
function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var
v: OLEvariant;
begin
Result := True;
try
v := CreateOLEObject('JRO.JetEngine');
try
V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB,
'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
DeleteFile(DB);
RenameFile(DB+'x',DB);
finally
V := Unassigned;
end;
except
Result := False;
end;
end;
ايجاد Database در يك بانك اطلاعاتي sql sever 2000 در حالت local
ايجاد Database در يك بانك اطلاعاتي sql sever 2000 در حالت local
کد:
procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: String);
var
ConnectionString: String;
CommandText: String;
begin
if WindowsSecurity then
ConnectionString := 'Provider=SQLOLEDB.1;' +
'Integrated Security=SSPI;' +
'Persist Security Info=False;' +
'Initial Catalog=master'
else
ConnectionString := 'Provider=SQLOLEDB.1;' +
'Password=' + Password + ';' +
'Persist Security Info=True;' +
'User ID=' + Username + ';' +
'Initial Catalog=master';
try
try
ADOConnection.ConnectionString := ConnectionString;
ADOConnection.LoginPrompt := False;
ADOConnection.Connected := True;
CommandText := 'CREATE DATABASE test ON ' +
'( NAME = test_dat, ' +
'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
'SIZE = 4, ' +
'MAXSIZE = 10, ' +
'FILEGROWTH = 1 )';
ADOCommand.CommandText := CommandText;
ADOCommand.Connection := ADOConnection;
ADOCommand.Execute;
MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);
except
on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
end;
finally
ADOConnection.Connected := False;
ADOCommand.Connection := nil;
end;
end;
پيدا كردن يك مقدار در فيلد ايندكس نشده به كمك TTable
پيدا كردن يك مقدار در فيلد ايندكس نشده به كمك TTable
کد:
function Locate(const oTable: TTable; const oField: TField;
const sValue: string): Boolean;
var
bmPos: TBookMark;
bFound: Boolean;
begin
Locate := False;
bFound := False;
if not oTable.Active then Exit;
if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then Exit;
bmPos := oTable.GetBookMark;
with oTable do
begin
DisableControls;
First;
while not EOF do
if oField.AsString = sValue then
begin
Locate := True;
bFound := True;
Break;
end
else
Next;
end;
if (not bFound) then
oTable.GotoBookMark(bmPos);
oTable.FreeBookMark(bmPos);
oTable.EnableControls;
end;