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- تغيير اللغة _____ مرفق
..../ ...... يتبع ..../.....
كل من 1 user says قال شكرا ل nabilkeb على المشاركة المفيدة1 user says Thank You to nabilkeb for this post • zouaidahmed
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- الشاشة الترحيبية+حساب و استعراض ملفات البرنامج أثناء الإقلاع ____ مرفق رابـــط
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- الفلترة بين تاريخين بقاعدة بيانات ___ مرفق
.../.... يتبع .../....
كل من 1 user says قال شكرا ل nabilkeb على المشاركة المفيدة1 user says Thank You to nabilkeb for this post • zouaidahmed
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;
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;
ملاحظة يجب اضافة الى اليوز use ، الوحدة المخصصة للذلك مثل اضافة :
.......... Jpeg - WinInet - SysUtils - registry
مقالات أعجبتني ، ..... لكل أعضاء دلفي العرب
سلام
كل من 1 user says قال شكرا ل nabilkeb على المشاركة المفيدة1 user says Thank You to nabilkeb for this post • zouaidahmed
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;
كل من 1 user says قال شكرا ل nabilkeb على المشاركة المفيدة1 user says Thank You to nabilkeb for this post • zouaidahmed
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;
كل من 1 user says قال شكرا ل nabilkeb على المشاركة المفيدة1 user says Thank You to nabilkeb for this post • zouaidahmed
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;
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.
كل من 1 user says قال شكرا ل nabilkeb على المشاركة المفيدة1 user says Thank You to nabilkeb for this post • zouaidahmed
![[-]](https://delphi4arab.net/forum/D4A2020/collapse.png)