مرجع المبتدإ (مجموعة من الأكواد)

[nabilkeb]

1- عرض أو استخراج اسم قارئ الأقراص المضغوطة :

function GetFirstCdRomDrive: string;
var
r: LongWord;
Drives: array[0..128] of char;
pDrive: pchar;
begin
Result := '';
r := GetLogicalDriveStrings(sizeof(Drives), Drives);
if r = 0 then exit;
if r > sizeof(Drives) then
raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY ));
pDrive := Drives;
while pDrive^ <> #0 do begin
if GetDriveType(pDrive) = DRIVE_CDROM then begin
Result := pDrive;
exit;
end;
inc(pDrive, 4);
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
edit1.text:=(GetFirstCdRomDrive);
end;



2- إضافة DateTimePicker إلى DBGrid ____ مرفق

3- تغيير شكل الأزرار Btn1: TBitBtn - Btn2: TBitBtn

Function Shape_Bounds(Btn: TButton; Polygon_Elliptic: Byte): Integer;
var
P: array[1..4]of TPoint;
begin
with Btn do
begin
case Polygon_Elliptic of
0:
begin
P[1].X := Round(ClientWidth / 2);
P[1].Y := 0;

P[2].X := 0;
P[2].Y := Round(ClientHeight / 2);

P[3].X := Round(ClientWidth / 2);
P[3].Y := ClientHeight;

P[4].X := ClientWidth;
P[4].Y := Round(ClientHeight / 2);

Result := CreatePolygonRgn(P, 4, POLYFILL_LAST);
end;
1: Result := CreateEllipticRgn(0, 0, Width, Height);
end;
SetWindowRgn(Handle, Result, True);
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
Shape_Bounds(btn1, 0);
Shape_Bounds(btn2, 1);
end;


4- فورم هزاز مثل الياهوووو (Buzzzzz)
var
Form1: TForm1;

implementation
procedure hzaz (no:integer);
var
i,ix:Integer;
begin
ix:=Form1.Left;
i:=0;
repeat
if Form1.Left=ix-4 then begin
i:=i+1;
repeat
Form1.Left:=Form1.Left+1;
Form1.Top:=Form1.Top-1;
until Form1.Left=ix
end
else
repeat
Form1.Left:=Form1.Left-1;
Form1.Top:=Form1.Top+1;
until Form1.Left=ix-4;
until i=no;
end;
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
hzaz(20);
end;

5- اخفاء البرنامج عن مدير المهام Gestionaire des taches و شريط المهام Bare des taches
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_SHOW);
end;


6- طريقة جمبلة في اخفاء برنامج عن مدير المهام Gestionaire des taches(Processus)p
______ مرفق

7- تغيير اسم الزر ابدأ ___ مرفق

8- تغيير تاريخ و وقت النظام ___ مرفق

9- تغيير اللغة _____ مرفق

..../ ...... يتبع ..../.....

[nabilkeb]

10- مسح مجموعة من EDt بكبسة زر ____ مرفق

11- تلوين DBGrid
A/
procedure Tform1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var dataset:Tdataset;
begin
dataset:= (Sender as TDBGrid).DataSource.DataSet;
with AlternGrid(Sender) do
begin
if (DataSet.RecNo mod 2 = 1 ) then
Canvas.Brush.Color := $00E6D9C4
else
Canvas.Brush.Color := $00EAF7FF;
if DataLink.ActiveRecord = Row -1 then
begin
Canvas.Font.Color:=clwhite ;
Canvas.Brush.Color:=clblack;
end; end ;
DBGrid1.DefaultDrawColumnCell(Rect,DataCol,Column, State);


B/

procedure TForm1.FormCreate(Sender: TObject);
var I: Integer;
begin
I:=0;
while I<DBGrid1.Columns.Count-1 do
begin
DBGrid1.Columns[I].Color:=$00E6D9C4;
// DBGrid1.Columns[I].Title.Color:=$00EAF7FF;
I:=I+1;
DBGrid1.Columns[I].Color:=$00EAF7FF;
// DBGrid1.Columns[I].Title.Color:=$00E6D9C4;
I:=I+1;
end;
end;


12- الشاشة الترحيبية+حساب و استعراض ملفات البرنامج أثناء الإقلاع ____ مرفق
رابـــط (http://www.delphi4arab.com/forum/showthread.php?t=481)

13- انشاء قاعدة بيانات بارادوكس برمجيا _____ مرفق

14- تحويل قاعدة بيانات بارادوكس إلى الاكسل و العكس ___ مرفق

15- استعمال الدالة DecodeDate
procedure TForm1.Button1Click(Sender: TObject);
var M,J,A:Word;
begin
try
DecodeDate(StrToDate(MaskEdit1.Text),A,M,J);
if (A < 1900) or (M > 12) or(J > 31) then
begin

ShowMessage('date:anneé moin que 1900');
MaskEdit1.Text:= '';
end else ShowMessage('date correcte');
except
ShowMessage('date incorrecte');
MaskEdit1.Text:= '';
end;
end;


16- ملئ الشاشة:

procedure TForm1.Button1Click(Sender: TObject);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
try
// Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
SystemParametersInfo(97, Word(True), @OldVal, 0);
// Disable the taskbar
EnableWindow(HTaskBar, False);
// Hide the taskbar
ShowWindow(HTaskbar, SW_HIDE);
finally
with Form1 do
begin
BorderStyle := bsNone;
// FormStyle := fsStayOnTop;
Left := 0;
Top := 0;
Height := Screen.Height;
Width := Screen.Width;

end;
end;
end;


العكس:

procedure TForm1.Button2Click(Sender: TObject);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
HTaskBar := FindWindow('Shell_TrayWnd', nil);
SystemParametersInfo(97, Word(False), @OldVal, 0);
EnableWindow(HTaskBar, true);
ShowWindow(HTaskbar, SW_SHOW) ;
// finally
with Form1 do
begin
BorderStyle := bsSizeable ; // bsNone ;
FormStyle :=fsNormal ; // fsStayOnTop;
// Height := 540 ; // Screen.Height;
// Width := 770 ; // Screen.Width;
Left := 20 ; // 0;
Top := 5 ; // 0;
Position :=podesktopCenter
end;
end;

17- الفلترة بين تاريخين بقاعدة بيانات ___ مرفق


.../.... يتبع .../....

[nabilkeb]

18- تشغيل البرنامج مع اقلاع الويندوز :

procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
Reg := nil;
try
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVer sion\Run',false);
reg.WriteString('Default',ExtractFilePath(Applicat ion.ExeName)+Application.ExeName);
reg.CloseKey;
reg.free;
except
if Assigned(Reg) then Reg.Free;

end;
end;

19- اجبار Edt من قبول الأرقام فقط ، أو الحروف فقط:
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if (Key in ['0'..'9', #8]) then
begin
Key := #0;
Beep;
end;
end;

procedure TForm1.Edit2KeyPress(Sender: TObject; var Key: Char);
begin
if not(Key in ['0'..'9', #8]) then
begin
Key := #0;
Beep;
end;
end;


20- افراغ كل محتويات الجدول:
while not Table1.IsEmpty do Table1.Delete;
أو:
Table1.close;
Table1.emptytable;
Table1.Open;
مع وجود فارق بين الطريقتين.

21- فتح و غلق قارئ الأقراص:
procedure TForm1.Button1Click(Sender: TObject);
begin
mcisendstring('set cdaudio door open wait',nil,0,GetDesktopWindow)// metez closed ou open

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
mcisendstring('set cdaudio door closed wait',nil,0,GetDesktopWindow)
end;

MasterSource-22 ____ مرفق

23- التعامل مع الرسائل في دلفي ___ مرفق

24- انشاء - فتح / ملف أو مجلد ___ مرفق

25-System_SourceCodes ____ مرفق

26- WindowsExit ______ مرفق

27- كيفية إظهار مربع الإتصال بإنترنت وكيفية إختبار إذا كنا متصلين بإنترنت أو لا

function InternetConnected: Boolean;
CONST
INTERNET_CONNECTION_MODEM = 1;
// local system uses a modem to connect to the Internet.
INTERNET_CONNECTION_LAN = 2;
// local system uses a local area network to connect to the Internet.
INTERNET_CONNECTION_PROXY = 4;
// local system uses a proxy server to connect to the Internet.
INTERNET_CONNECTION_MODEM_BUSY = 8;
// local system's modem is busy with a non-Internet connection.
VAR
dwConnectionTypes : DWORD;
BEGIN
dwConnectionTypes :=
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
Result := InternetGetConnectedState(@dwConnectionTypes,0);
END;

من أجل فتح مربع الإتصال بإنترنت :

procedure TForm1.Button1Click(Sender: TObject);
begin
if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, Application.Handle)
then
MessageDlg('لايوجد إتصال', mtError, [mbOk], 0);
end;

من أجل إختبار إذا كنا متصلين بإنترنت أو لا :
procedure TForm1.Button2Click(Sender: TObject);
begin
if InternetConnected then
showmessage('متصل حاليا بإنترنت')
else begin
showmessage('غير متصل بإنترنت');
InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, Application.Handle);
end;
end;


28- تحويل الصورة من BMP إلى JPG

var jpg:TJPEGImage;
begin
jpg:=TJPEGImage.Create;
with jpg do begin
Assign(Image1.Picture.Bitmap);
SaveToFile('my jpeg.jpg');
end;
end;

29- قلب زر الماوس من اليمين إلى اليسار و العكس :
SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, NIL, 0);
SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 0, NIL, 0);

30- اخفاء سطح المكتب :



procedure Desktop(Desk:boolean);
begin

DID := FindWindow('progman', nil);
if DID <> 0 then
begin
if Desk then
ShowWindow(DID, SW_SHOW)
else
ShowWindow(DID, SW_HIDE);
Desk := not(Desk);
end;

end

الإخفاء أو الإظهار :
Desktop(False);
Desktop(True);

31- تشغيل شاشة التوقف برمجيا :

function TScreenSaver : BOOL;
var
B_1 : bool;
begin
result := false;
if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE,
0,
@B_1,
0) <> true then exit;
if not B_1 then exit;
PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := true;
ثم:

TScreenSaver;

32- تهيئة القرص المرن:

const
SHFMT_ID_DEFAULT = $FFFF;
SHFMT_OPT_QUICKFORMAT = 0;
SHFMT_OPT_FULLFORMAT = 1;
SHFMT_OPT_SYSONLY = 2;

SHFMT_ERROR = -1;
SHFMT_CANCEL = -2;
SHFMT_NOFORMAT = -3;


var
Form1: TForm1;

implementation

{$R *.dfm}
function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options :
Word) : Longint; stdcall;
external 'Shell32.dll' name 'SHFormatDrive';

procedure DiskFormat(Drive:Char);
var
RetCode : Integer;
begin
retCode:= SHFormatDrive(GetDesktopwindow,
Ord(Upcase(Drive))-Ord('A'),
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DiskFormat('A');
end;

..... / ..... يتبع ...../.....

[nabilkeb]

ملاحظة يجب اضافة الى اليوز use ، الوحدة المخصصة للذلك مثل اضافة :
.......... Jpeg - WinInet - SysUtils - registry
مقالات أعجبتني ، ..... لكل أعضاء دلفي العرب
سلام

[nabilkeb]

- أكواد لجلب سيريال : القرص الصلب ، اللوحة الأم ، المعالج ، فلاش ميموري :


33-سيريال القرص:
function GetVolSN(Volumn:String):string;
var
sVolName, sFName: Array[0..20] of Char;
dwVolSN, dwMaxFNameLen, dwFlag: DWORD;
begin
result:='';
if GetVolumeInformation(PChar(Volumn), sVolName, 20,
@dwVolSN,dwMaxFNameLen, dwFlag, sFName, 20) then
result := IntToHex(dwVolSN, 8);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
edit1.Text:=(GetVolSN('c:'));
end; 34- معلومات و سيريال الفلاش ميموري أو قطاع القرص C أو D أو ...

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
kernel32 = 'kernel32.dll';
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Type
TVolumeInfo = record
Name : String;
SerialNumber : DWORD;
MaxComponentLength : DWORD;
FileSystemFlags : DWORD;
FileSystemName : String;
end; // TVolumeInfo

function GetVolumeInformationA(lpRootPathName: PAnsiChar;
lpVolumeNameBuffer: PAnsiChar; nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD;
var lpMaximumComponentLength, lpFileSystemFlags: DWORD;
lpFileSystemNameBuffer: PAnsiChar; nFileSystemNameSize: DWORD): BOOL; stdcall;
external 'kernel32.dll' name 'GetVolumeInformationA';
function GetVolumeInformationW(lpRootPathName: PWideChar;
lpVolumeNameBuffer: PWideChar; nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD;
var lpMaximumComponentLength, lpFileSystemFlags: DWORD;
lpFileSystemNameBuffer: PWideChar; nFileSystemNameSize: DWORD): BOOL; stdcall;
external 'kernel32.dll' name 'GetVolumeInformationW';
function GetVolumeInformation(lpRootPathName: PChar;
lpVolumeNameBuffer: PChar; nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD;
var lpMaximumComponentLength, lpFileSystemFlags: DWORD;
lpFileSystemNameBuffer: PChar; nFileSystemNameSize: DWORD): BOOL; stdcall;
external 'kernel32.dll' name 'GetVolumeInformationA';
var
Form1: TForm1;
implementation
{$R *.dfm}
function MyGetVolumeInformation( const Drive : Char ) : TVolumeInfo;
var
lpRootPathName : PChar; // address of root directory of the file system
lpVolumeNameBuffer : PChar; // address of name of the volume
nVolumeNameSize : DWORD; // length of lpVolumeNameBuffer
lpVolumeSerialNumber : DWORD; // address of volume serial number
lpMaximumComponentLength : DWORD; // address of system's maximum filename length
lpFileSystemFlags : DWORD; // address of file system flags
lpFileSystemNameBuffer : PChar; // address of name of file system
nFileSystemNameSize : DWORD; // length of lpFileSystemNameBuffer
begin
GetMem( lpVolumeNameBuffer, MAX_PATH + 1 );
GetMem( lpFileSystemNameBuffer, MAX_PATH + 1 );
try
nVolumeNameSize := MAX_PATH + 1;
nFileSystemNameSize := MAX_PATH + 1;
lpRootPathName := PChar( Drive + ':\' );
if GetVolumeInformation( lpRootPathName,
lpVolumeNameBuffer,
nVolumeNameSize,
@lpVolumeSerialNumber,
lpMaximumComponentLength,
lpFileSystemFlags,
lpFileSystemNameBuffer,
nFileSystemNameSize ) then
begin
with Result do
begin
Name := lpVolumeNameBuffer;
SerialNumber := lpVolumeSerialNumber;
MaxComponentLength := lpMaximumComponentLength;
FileSystemFlags := lpFileSystemFlags;
FileSystemName := lpFileSystemNameBuffer;
end; // with Result
end // if
else
begin
with Result do
begin
Name := '';
SerialNumber := 1;
MaxComponentLength := 1;
FileSystemFlags := 1;
FileSystemName := '';
end; // with Result
end; // else
finally
FreeMem( lpVolumeNameBuffer );
FreeMem( lpFileSystemNameBuffer );
end; // try
end;

procedure TForm1.Button1Click(Sender: TObject);
var
VolumeInfo : TVolumeInfo;
flags : String;
begin
VolumeInfo := MyGetVolumeInformation( 'C' );
with VolumeInfo do
begin
if (FileSystemFlags and FS_CASE_IS_PRESERVED) <> 0 then
if Length( flags ) <> 0 then
flags := flags + #13#10#9'FS_CASE_IS_PRESERVED'
else
flags := 'FS_CASE_IS_PRESERVED';
if (FileSystemFlags and FS_CASE_SENSITIVE) <> 0 then
if Length( flags ) <> 0 then
flags := flags + #13#10#9'FS_CASE_SENSITIVE'
else
flags := 'FS_CASE_SENSITIVE';

if (FileSystemFlags and FS_UNICODE_STORED_ON_DISK) <> 0 then
if Length( flags ) <> 0 then
flags := flags + #13#10#9'FS_UNICODE_STORED_ON_DISK'
else
flags := 'FS_UNICODE_STORED_ON_DISK';
if (FileSystemFlags and FS_PERSISTENT_ACLS) <> 0 then
if Length( flags ) <> 0 then
flags := flags + #13#10#9'FS_PERSISTENT_ACLS'
else
flags := 'FS_PERSISTENT_ACLS';

if (FileSystemFlags and FS_FILE_COMPRESSION) <> 0 then
if Length( flags ) <> 0 then
flags := flags + #13#10#9'FS_FILE_COMPRESSION'
else
flags := 'FS_FILE_COMPRESSION';
if (FileSystemFlags and FS_VOL_IS_COMPRESSED) <> 0 then
if Length( flags ) <> 0 then
flags := flags + #13#10#9'FS_VOL_IS_COMPRESSED'
else
flags := 'FS_VOL_IS_COMPRESSED';
ShowMessage( 'Volume Information For Drive C'#13#10#13#10 +
'Name:'#9 + Name + #13#10 +
//'Serial Number:'#9 + Copy( IntToHex( SerialNumber, 0 ), 1, 4 ) + '-' + Copy( IntToHex( SerialNumber, 0 ), 5, 4 )+ #13#10 +
'Serial Number:'#9 + Copy( IntToHex( SerialNumber, 0 ), 1, 8)+ #13#10 +
'Max Component Length:'#9 + IntToStr( MaxComponentLength ) + #13#10 +
'File System Flags:'#13#10#9 + Flags + #13#10 +
'File System:'#9 + FileSystemName );
end; // with VolumeInfo
end;

[nabilkeb]

35- المعالـــج :
const
ID_BIT = $200000; // EFLAGS ID bit
type
TCPUID = array[1..4] of Longint;
TVendor = array [0..11] of char;
function IsCPUID_Available : Boolean; register;
asm
PUSHFD {direct access to flags no possible, only via stack}
POP EAX {flags to EAX}
MOV EDX,EAX {save current flags}
XOR EAX,ID_BIT {not ID bit}
PUSH EAX {onto stack}
POPFD {from stack to flags, with not ID bit}
PUSHFD {back to stack}
POP EAX {get back to EAX}
XOR EAX,EDX {check if ID bit affected}
JZ @exit {no, CPUID not availavle}
MOV AL,True {Result=True}
@exit:
end;

function GetCPUID : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;

function GetCPUVendor : TVendor; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Result (TVendor)}
MOV EAX,0
DW $A20F {CPUID Command}
MOV EAX,EBX
XCHG EBX,ECX {save ECX result}
MOV ECX,4
@1:
STOSB
SHR EAX,8
LOOP @1
MOV EAX,EDX
MOV ECX,4
@2:
STOSB
SHR EAX,8
LOOP @2
MOV EAX,EBX
MOV ECX,4
@3:
STOSB
SHR EAX,8
LOOP @3
POP EDI {Restore registers}
POP EBX
end;
procedure TForm1.Button1Click(Sender: TObject);
var
CPUID : TCPUID;
I : Integer;
S : TVendor;
begin
for I := Low(CPUID) to High(CPUID) do CPUID[i] := -1;
if IsCPUID_Available then begin
CPUID := GetCPUID;
Memo1.Lines.Add('CPUID[1] = ' + IntToHex(CPUID[1],8));
Memo1.Lines.Add('CPUID[2] = ' + IntToHex(CPUID[2],8));
Memo1.Lines.Add('CPUID[3] = ' + IntToHex(CPUID[3],8));
Memo1.Lines.Add( 'CPUID[4] = ' + IntToHex(CPUID[4],8));
Memo1.Lines.Add('PValue = '+ IntToStr(CPUID[1] shr 12 and 3));
Memo1.Lines.Add( 'FValue = '+IntToStr(CPUID[1] shr 8 and $f));
Memo1.Lines.Add( 'MValue = '+IntToStr(CPUID[1] shr 4 and $f));
Memo1.Lines.Add( 'SValue = '+IntToStr(CPUID[1] and $f));
S := GetCPUVendor;
Memo1.Lines.Add( 'Vendor: ' + S); end
else begin
Memo1.Lines.Add( 'CPUID not available');
end;
end;



36- اللوحــة الأم :
function GetAdapterInfo(Lana: Char): String;
var
Adapter: TAdapterStatus;
NCB: TNCB;
begin
FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBRESET);
NCB.ncb_lana_num := Lana;
if Netbios(@NCB) <> Char(NRC_GOODRET) then
begin
Result := 'mac not found';
Exit;
end;

FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBASTAT);
NCB.ncb_lana_num := Lana;
NCB.ncb_callname := '*';

FillChar(Adapter, SizeOf(Adapter), 0);
NCB.ncb_buffer := @Adapter;
NCB.ncb_length := SizeOf(Adapter);
if Netbios(@NCB) <> Char(NRC_GOODRET) then
begin
Result := 'mac not found';
Exit;
end;
Result :=
IntToHex(Byte(Adapter.adapter_address[0]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[1]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[2]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[3]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[4]), 2) + '-' +
IntToHex(Byte(Adapter.adapter_address[5]), 2);
end;

function GetMACAddress: string;
var
AdapterList: TLanaEnum;
NCB: TNCB;
begin
FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBENUM);
NCB.ncb_buffer := @AdapterList;
NCB.ncb_length := SizeOf(AdapterList);
Netbios(@NCB);
if Byte(AdapterList.length) > 0 then
Result := GetAdapterInfo(AdapterList.lana[0])
else
Result := 'mac not found';
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text:=(GetMACAddress);
end;

[nabilkeb]

37- كود اجبار Edit على كتابة الحروف الكبيرة فقط (Majuscule) :

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if Key in['a'..'z']then Dec(Key,32)
end;


38- اجبار Edit على كتابة الحروف فقط + كتابة الأرقام و الفاصل وزر المسح فقط
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if key in ['.' , ','] then
begin key:= DecimalSeparator; end;
if (Key in ['0'..'9',DecimalSeparator ]) then begin
Key := #0;
end;
end;

if key in ['.' , ','] then
begin key:= DecimalSeparator; end;
if Not (Key in ['0'..'9',DecimalSeparator, #8 ]) then begin
Key := #0;
end;

[nabilkeb]

39- حساب الفارق بين تاريخين DateTimePicker1 - DateTimePicker2 بالأيام:
function RemainingDays(from, _to: Tdate) : integer;
begin
Result := Trunc(_to - from);
if Result < 0 then
Result := 0;
end;
للاستخراج:
Label1.Caption:=IntToStr(RemainingDays(DateTimePic ker1.Date, DateTimePicker2.Date));



40- الحساب المتجدد للفارق بين توقيت معين و التوقيت الحالي : ___ مرفق


* الأكواد 8 - 17- 39 -40 ربما من شأنها أن تفيد أصحاب البرامج المتخصصة في التاريخ و التوقيت كعداد مقهى نت أو المؤذن ....

[nabilkeb]

41- منع البرنامج من الإغلاق (ALT+F4)

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose:=FALSE;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
application.Terminate;
end


42- الحد من أزرار شريط نافدة البرنامج (تعطيل زر الإغلاق):
procedure TForm1.Button1Click(Sender:TObject);
var
handle: THandle;

begin
handle:=GetSystemMenu(Self.Handle,false);
RemoveMenu(handle, 8, mf_byposition);
RemoveMenu(handle, 7, mf_byposition);
RemoveMenu(handle, 6, mf_byposition);
RemoveMenu(handle, 5, mf_byposition);
end;


43- التحويل من ASCII إلى ANSI
procedure TForm1.Button1Click(Sender: TObject);
var
asciistring:string;
ansistring: string;

begin
asciistring:='??ü';
OEMtoChar(PChar(asciistring), PChar(ansistring));
end;

44- فتح صندوق حوار التهيئة :
Uses: ShellAPI
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Application.Handle,Pchar('Open'),
Pchar('C:\Windows\Rundll32.exe'),
Pchar('Shell32.dll,SHFormatDrive'),
Pchar('C:\Windows'),SW_SHOWNORMAL);
end;

45- تشغيل أصوات النظام :
uses: mmsystem

procedure TForm1.Button1Click(Sender: TObject);
begin
PlaySound(pChar('SYSTEMSTART'),0,SND_ASYNC);
end;
أصوات أخرى :
SYSTEMSTART
SYSTEMEXIT
SYSTEMHAND
SYSTEMASTERISK
SYSTEMQUESTION
SYSTEMEXCLAMATION
SYSTEMWELCOME
SYSTEMDEFAULT

46- تشغيل برنامج آخر مثلا المفكرة :
uses: shellapi
procedure TForm1.Button1Click(Sender: TObject);
begin
Shellexecute(handle,'open','notepad.exe','',nil,sw _shownormal);
// WinExec('C:\Windows\notepad.exe',SW_Show);
end;

[nabilkeb]

47- اظهار التاريخ و الوقت على نمودج مختار :
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption:=FormatDatetime('d. mmmm yyyy hh:mm:ss', Now);
end ; 48- برمجة Timer (أي شيء موقت)
Uses: mmsystem

var
Form1: TForm1;
fid:Integer;
implementation
{$R *.dfm}
procedure TimeCallBack(TimerID, Msg:Uint; dwUser, dw1, dw2: DWord); pascal;
begin
//Do something here
//This procedure will executed each 10 ms , for example
form1.Label1.Caption:=form1.Label1.Caption+'%';
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
TimeKillEvent(fid);
end;

//Set a new timer with a delay of 10 ms
procedure TForm1.Button1Click(Sender: TObject);
begin
fid:=TimeSetEvent(10,0,@TimeCallBack,0,TIME_PERIOD IC);
end;
end.
49- جعل البرنامج يرمش على شريط المهام (تنبيه):
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if timer1.tag = 0 then begin
flashwindow(application.handle, false);
timer1.tag := 1;
end
else
begin
flashwindow(application.handle, true);
timer1.tag := 0;
end;
end; يمكن تعديل المدة على الخاصية : Interval للتايمر.

50- تمكين و تعطيل زر الإغلاق على شريط نافذة البرنامج (برمجيا) :
procedure TForm1.FormCreate(Sender: TObject);
begin
EnableMenuItem( GetSystemMenu( Form1.Handle, LongBool(false)),
SC_CLOSE, MF_BYCOMMAND or MF_GRAYED);
end; 51- الصياغة و التحكم برسائل الخطأ:
procedure TForm1.Button1Click(Sender: TObject);
var
lpMsgBuf : PChar;
begin
FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER OR FORMAT_MESSAGE_FROM_SYSTEM,
nil, GetLastError(), 0, @lpMsgBuf, 0, nil );
Application.MessageBox(lpMsgBuf,0,0);
end;52- اجبار الفورم أن تظهر الأولى فوق البقية _en premier plan )
-
function ForceForegroundWindow(hwnd: THandle): boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID : DWORD;
timeout : DWORD;


begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd then Result := true
else begin

// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus

if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and
(Win32MinorVersion > 0)))) then
begin

// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16

Result := false;
ForegroundThreadID :=
GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false);
Result := (GetForegroundWindow = hwnd);
end;
if not Result then begin

// Code by Daniel P. Stasinski

SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0),
SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0,
TObject(timeout), SPIF_SENDCHANGE);
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
end;

Result := (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
53- تعطيل شاشة التوقف في تنفيد برنامجك :
interface
...
private
procedure AppMessage(var msg: TMsg; var handled: boolean);
...
implementation
...
procedure TForm1.AppMessage(var msg : TMsg; var handled : boolean);
begin
if (Msg.Message = WM_SYSCOMMAND) and (Msg.wParam = SC_SCREENSAVE) then
Handled := true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;



54- اخبارك إذا كان المستخدم غير القرص المضغوط
(اخراج أو ادخال_ و لا يتعلق الأمر بفتح و اغلاق قارئ الأقراص بدون القرص) :
type
TForm1 = class(TForm)
private
{ Déclarations privées }
procedure WMDeviceChange(var Msg: TMessage);
message WM_DEVICECHANGE;


public
{ Déclarations publiques }
end;

var
Form1: TForm1;

implementation
{$R *.dfm}
procedure TForm1.WMDeviceChange (var Msg: TMessage);
const
CD_IN = $8000;
CD_OUT = $8004;
var
myMsg : String;
begin
inherited;
case Msg.wParam of
CD_IN : myMsg := 'CD inserted!';
CD_OUT : myMsg := 'CD removed!';
end;
ShowMessage(myMsg);
end;

end.

[nabilkeb]

إضافة إلى الكود رقم 28

55- كود تحويل Ico إلى Bmp
procedure TForm1.Button1Click(Sender: TObject);
var Icon : TIcon;
Bitmap : TBitmap;
begin
if OpenDialog1.Execute then begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile(OpenDialog1.FileName);
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw(0, 0, Icon);
Bitmap.SaveToFile('c:\picture.bmp');
Icon.Free;
Bitmap.Free;
end;
end; 56- كود تحويل أو استخراج ICO من BMP
procedure TForm1.Button1Click(Sender: TObject);
var
IconSizeX: integer;
IconSizeY: integer;
XOrMask: TBitmap;
IconInfo: TIconInfo;
Icon: TIcon;
begin
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);
XOrMask := TBitmap.Create;
XOrMask.Width := IconSizeX;
XOrMask.Height := IconSizeY;
XOrMask.LoadFromFile('C:\picture.bmp');{}
Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);
{Create a icon}
Icon := TIcon.Create;
IconInfo.fIcon := true;
IconInfo.xHotspot := 0;
IconInfo.yHotspot := 0;
IconInfo.hbmMask := XOrMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;
Icon.Handle := CreateIconIndirect(IconInfo);
{Destroy the temporary bitmaps}
// AndMask.Free;
XOrMask.Free;
{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);
{Assign the application icon}
Application.Icon := Icon;
{Force a repaint}
InvalidateRect(Application.Handle, nil, true);
{Free the icon}
Icon.Free;
end;
57- التحكم بحج الصورة :
function ResizeBmp(bitmp: TBitmap; wid, hei: Integer): Boolean;
var
TmpBmp: TBitmap;
ARect: TRect;
begin
Result := False;
try
TmpBmp := TBitmap.Create;
try
TmpBmp.Width := wid;
TmpBmp.Height := hei;
ARect := Rect(0,0, wid, hei);
TmpBmp.Canvas.StretchDraw(ARect, Bitmp);
bitmp.Assign(TmpBmp);
finally
TmpBmp.Free;
end;
Result := True;
except
Result := False;
end;
end; * للإستدعاء :
procedure TForm1.Button1Click(Sender: TObject);
begin
ResizeBmp(Image1.Picture.Bitmap,70,70)
end;

[izd2010]

والله انك تستحق كل شكر

[nt-SS]

عندي ملاحظة:
في الكود 30 (إخفاء سطح المكتب)
1-نسيت الإعلان عن المتغير DID من نوع HWND
var DID:HWND;
2- نسيت وضع الفاصلة المنقوطة في النهاية end
end;

مشكور nabilkeb مرجع رائع جداً, تحياتي لك

[nabilkeb]

العفو إخواني
بالتوفيق للجميع