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

مرجع المبتدإ (مجموعة من الأكواد) - نسخة قابلة للطباعة

+- delphi4arab منتديات دلفي للعرب (https://delphi4arab.net/forum)
+-- قسم : منتديات دلفي للعرب التعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=3)
+--- قسم : دروس دلفي للمبتدئين (https://delphi4arab.net/forum/forumdisplay.php?fid=13)
+--- الموضوع : مرجع المبتدإ (مجموعة من الأكواد) (/showthread.php?tid=1192)

الصفحات: 1 2

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

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 - 09-09-2009

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);

كود :
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- الشاشة الترحيبية+حساب و استعراض ملفات البرنامج أثناء الإقلاع ____ مرفق
رابـــط

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 - 09-09-2009

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\CurrentVersion\Run',[COLOR=Sienna]false[/COLOR]);
   reg.WriteString('Default',ExtractFilePath(Application.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- كيفية إظهار مربع الإتصال بإنترنت وكيفية إختبار إذا كنا متصلين بإنترنت أو لا

كود :
[COLOR=#000000][COLOR=#0000BB]
[/COLOR][/COLOR]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;

ثم:

كود :
[COLOR=#000000][COLOR=#0000BB]
[/COLOR][/COLOR]TScreenSaver;

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

كود :
[COLOR=#000000][COLOR=#0000BB]
[/COLOR][/COLOR]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 - 09-09-2009

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

مرجع المبتدإ (مجموعة من الأكواد) - nabilkeb - 10-09-2009

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

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
     [COLOR=DarkRed]VolumeInfo := MyGetVolumeInformation[/COLOR]( '[COLOR=Blue][B]C[/B][/COLOR]' );
     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 - 10-09-2009

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 - 11-09-2009

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 - 11-09-2009

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(DateTimePicker1.Date, DateTimePicker2.Date));

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

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

مرجع المبتدإ (مجموعة من الأكواد) - nabilkeb - 23-10-2009

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 - 23-10-2009

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_PERIODIC);
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([COLOR=Blue]false[/COLOR])),
  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.