بعض اكود لغة الدلفي

[/center]السلام عليكم

اقدم لكم بعض الافكار من خبرتي في البرمجة



كيف تبحث في أكثر من حقل بإستخدام تعليمة Locate :

يمكن البحث بإستخدام تعليمة Locate في أكثر من حقل بحيث نبحث عن الموظف حسب حقل الإسم الأول و حقل الإسم الثاني . فإذا كان حقل الإسم الأول F_name والإسم الثاني L_name والقيم في Edit1 و Edit2 على التوالي أمكننا ببساطة كتابة الشفرة التالية :

SQL

if not ClientDataSet1.Locate( 'F_Name;L_Name',vararrayof([edit1.Text,Edit2.Text]),[]) then
showmessage( 'Filed Not Found');



ويتم ذلك بفصل الحقول المراد البحث فيها بفاصلة منقوطة , وفصل القيم بإستخدام الدالة VarArrayOf



كيف تبحث عن تطابق جزئي بإستخدام تعليمة Locate :

مثلا يمكننا البحث حسب بداية كلمة ما , حيث يكفي كتابة الأحرف الأولى من الإسم لإظهار نتيجة السجل . مثال يكفي كتابة "عرو" لإظهار سجل الموظف "عروة "


كود

if not ClientDataSet1.Locate('F_Name',edit3.Text,[loPartialKey]) then
showmessage('Filed Not Found');

ويتم ذلك بإستخدام الخيار [loPartialKey] الذي يحدد التطابق الجزئي للبحث



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

أولا أضف الوحدة WinInet مع الوحدات :



SQL

USES
WinInet;



ثم أكتب التابع التالي



SQL

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;
BEG IN dwConnectionTypes : =
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
Result : = InternetGetConnectedState(@dwConnectionTypes,0);
END;



من أجل فتح مربع الإتصال بإنترنت أكتب الشفرة التالية :



SQL

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


من أجل إختبار إذا كنا متصلين بإنترنت أو لا :



SQL

procedure TForm1.Button2Click(Sender: TObject);
beg in if InternetConnected then
showmessage( ' متصل حاليا بإنترنت ')
else beg in showmessage( ' غير متصل بإنترنت ');
InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, Application.Handle);
end;
end;




تحويل الكتابه عربي > أنكليزي وبالعكس

للتحويل إلى اللغة العربية :



كود

LOADKEYBOARdlayout('00000401',klf_activate);



للتحويل إلى اللغة الإنكليزية :



كود

LOADKEYBOARdlayout('00000409',klf_activate);





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


أضف الوحدة JPEG :

كود

uses JPEG


ثم ضع هذا الكود في المكان المناسب



كود

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


لكتابة الأصفار يسار العدد نستخدم الكود التالي


كود

label1.Caption := Format('%.*d', [10, 1456]);




تغيير خلفية سطح المكتب من الدلفي

إستخدم الإجراء التالي :
كود

Uses
Windows;
procedure ChangeWallpaper(Bitmap: string);
begin
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Pchar(Bitmap),
SPIF_UPDATEINIFILE);
end;





إخراج وإغلاق السواقة الليزرية

إستخدم الإجرائين التاليين :




كود

Uses

Windows,

MMSystem;

procedure EjectCDROM;

begin

mciSendString('Set cdaudio door open wait', nil, 0, GetDesktopWindow);

end;


procedure CloseCDROM;

begin

mciSendString('Set cdaudio door closed wait', nil, 0,GetDesktopWindow)

end;




حساب سرعة المعالج

إستخدم الإجراء التالي

كود

Uses

Windows;

function GetCPUSpeed: Double;

const

DelayTime = 500; // measure time in ms

var

TimerHi, TimerLo: DWORD;

PriorityClass, Priority: Integer;

begin

PriorityClass := GetPriorityClass(GetCurrentProcess);

Priority := GetThreadPriority(GetCurrentThread);



SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);

SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);

Sleep(10);

asm

dw 310Fh // rdtsc

mov TimerLo, eax

mov TimerHi, edx

end;

Sleep(DelayTime);

asm

dw 310Fh // rdtsc

sub eax, TimerLo

sbb edx, TimerHi

mov TimerLo, eax

mov TimerHi, edx

end;

SetThreadPriority(GetCurrentThread, Priority);

SetPriorityClass(GetCurrentProcess, PriorityClass);

Result := TimerLo / (1000.0 * DelayTime);

end;




إظهار مربع حوار تغيير أيقونة :


كود

function PickIconDlgA(OwnerWnd: HWND; lpstrFile: PAnsiChar; var nMaxFile: LongInt; var lpdwIconIndex: LongInt): LongBool; stdcall; external 'SHELL32.DLL' index 62;

procedure TForm1.Button1Click(Sender: TObject);
var
FileName: array[0..MAX_PATH-1] of Char;
Size, Index: LongInt;
begin
Size := MAX_PATH;
PickIconDlgA(0, FileName, Size, Index);
end;





هذا الكود لإصلاح وضغط قاعدة بيانات من نوع أكسيس

كود

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;



قراءة وتعديل خصائص ملف :

لقراءة خصائص ملف ما (أرشيف , مخفي , للقراءة فقط .... )
نستخدم الإجراء التالي :

كود

Procedure GetFileAttr(Filename:String);
var
Attr : Word;
Begin
Attr:=FileGetAttr(Filename);
if (Attr and faReadOnly) <>0 then ShowMessage('Read Only');
if (Attr and faHidden) <>0 then ShowMessage('Hidden');
if (Attr and faSysFile) <>0 then ShowMessage('System Files');
if (Attr and faVolumeID) <>0 then ShowMessage('Volume ID');
if (Attr and faDirectory)<>0 then ShowMessage('Directory');
if (Attr and faArchive) <>0 then ShowMessage('Archive');
if (Attr and faAnyFile) <>0 then ShowMessage('AnyFile');
End;



لضبط خصائص ملف ما نستخدم الإجراء التالي :




كود

Procedure SetFileAttr(Filename:String;Hidden,ReadOnly:Boolean);
Var
Attr : Word;
Begin
Attr:=FileGetAttr(Filename);
if Hidden then
Attr:=Attr or faHidden else
Attr:=Attr and not FaHidden;
if ReadOnly then
Attr:=Attr or faReadOnly else
Attr:=Attr and not FaReadOnly;
FileSetAttr(Filename,Attr);
End;




هذا الكود لجعل لون الفورم متدرج




كود

var
Row,Ht: word;
begin
Ht := (ClientHeight + 255) div 256;
For Row := 0 to 255 Do
With Canvas Do Begin
Brush.Color := Rgb(Row,0,0);
FillRect(Rect(0,Row*Ht,ClientWidth,(Row+1)*Ht));
end;






Taskbar إخفاء و إظهار شريط المهام

اضف هذا السطر إلي الـ private:

كود

hTaskBar: HWND;



و في حدث انشاء النافذة (OnFormCreate) ضع الكود التالي :



كود

hTaskBar := FindWindow('Shell_TrayWnd', nil);



لإخفاء شريط المهام :



كود

ShowWindow(hTaskBar, SW_HIDE);



و لإظهار شريط المهام :




كود

ShowWindow(hTaskBar, SW_SHOW);






قلب أزرار الماوس

من أجل قلب أزرار الماوس إستخدم

كود

// تغيير زر الماوس الأيمن إلي الأيسر

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, NIL, 0);



ومن أجل إعادتها إلى وضعها إستخدم



كود

// إعادة أزرار الماوس إلي الوضع الطبيعي

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 0, NIL, 0);




تشغيل برنامج أو ملف برمجيا من داخل تطبيقك :




كود

uses shellapi;
// ...
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Handle, 'open', PChar('c:\a.txt'), nil, nil, SW_SHOW);
// إستبدل إسم الملف
end;



طباعة ملف في الخلفية


كود

;(ShellExecute(Handle,'print','c:\MyFile.txt',nil,nil,SW_Hide



لفتح مجلد folder في جهاز كمبيوتر MyComputer



كود

;(ShellExecute(Handle,'open','c:\Windows',nil,nil,SW_SHOWNormal



لفتح مجلد folder في مستكشف explore



كود

;(ShellExecute(Handle,'explore','c:\Windows',nil,nil,SW_SHOWNormal



ملاحظة
-----: يمكن أستخدام الدالة WinExec المبنية في الدلفي لتشغيل البرامج :



كود

;(WinExec('C:WindowsNotePad.exe',SW_SHOWNORMAL





تعطيل زر إبدأ


كود

لتعطيل زر إبدأ :


EnableWindow(FindWindowEx(FindWindow('Shell_TrayWn
d', nil), 0, 'Button', nil), false);



لتفعيل زر إبدأ :



كود

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWn
d', nil), 0, 'Button', nil), true);




إخفاء أيقونات سطح المكتب

بإستخدام الإجراء التالي :

كود

procedure DisableIcons(b:boolean);
var

wnd: HWND;
begin

wnd := FindWindow('progman', nil);
if wnd <> 0 then
begin
if b then
ShowWindow(wnd, SW_SHOW)
else
ShowWindow(wnd, SW_HIDE);
b := not(b);
end
else
showmessage('Desktop not found');
end;



لإخفاء الأيقونات :



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
DisableIcons(false);
end;
كود


لإظهار الأيقونات :




procedure TForm1.Button2Click(Sender: TObject);
begin
DisableIcons(true);

end;

كود


وضع برنامجك فوق التطبيقات .. في المقدمة دائماً :



Application.NormalizeTopMosts;
SetWindowPos(form1.Handle, HWND_TOPMOST, 0,0,0,0,
SWP_NOACTIVATE+SWP_NOMOVE+SWP_NOSIZE);

كود


تنفيذ برنامج مع عدم ظهوره فى task bar :




SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);


كود
وللحصول على رقم الهادرسك اليك هذه الدالة :





function GetHardisSNO : Double;
var
serialnum, maxname, flags: dword;
buffer: array[0..255] of char;
begin
GetVolumeInformation('C:', buffer, sizeof(buffer), @serialnum,
maxname, flags, nil, 0);

result := serialnum;
end;




وهذا كود للحماية ..... تشغيل مرة واحدة ...او اعادة تشغيل الجهاز حتى يعمل البرنامج



كود


procedure TForm1.FormShow(Sender : TObject);
var atom : integer;
CRLF : string;
begin
if
GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then
atom := GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT')
else
begin
CRLF := #10 + #13;
ShowMessage('This version may only be run once for every Windows Session.' + CRLF +
'To run this program again, you need to restart Windows, or better yet:' + CRLF +
'REGISTER !!');
Close;
end;
end;




اكثر من سطر في الهنت :



كود

Button1.Hint := 'First line' + chr(13) + 'Second line';



تشغيل ملف صوتي بدون كمبوننت .. كود فقط :



كود

Function :
function sndPlaySound(lpszSoundName: PChar; uFlags: UINT): BOOL;
stdcall; external 'winmm.dll' name 'sndPlaySoundA';

CODE :
sndPlaySound(PChar(FileName),SND_ASYNC);
او
CODE :
sndPlaySound(PChar(FileName),1);



معرفة مسار البرنامج :



كود

{put this in the public part}
Function GetAppDir:string; //Get Application install directory

{put this in the implementation part}
Function TForm1.GetAppDir:string;
var
ExeFile:string;
Num:integer;
begin
ExeFile:=application.ExeName;
num:=length(Exefile);
while (ExeFile[num]<>'\') and (num>0) do begin
delete(ExeFile,num,1);
num:=num-1;
end;
Result:=ExeFile;
end;



اوتو ستارت ... تشغيل تلقائي عند اعادة تشغيل النظام :



كود

procedure SetAutoStart(AppName, AppTitle: string; bRegister: Boolean);
const
RegKey = '\Software\Microsoft\Windows\CurrentVersion\Run';
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
try
Registry.RootKey := HKEY_LOCAL_MACHINE;
if Registry.OpenKey(RegKey, False) then
begin
if bRegister = False then
Registry.DeleteValue(AppTitle)
else
Registry.WriteString(AppTitle, AppName);
end;
finally
Registry.Free;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
SetAutoStart(ParamStr(0), 'TEST', True);
end;



ولمعرفة اسم سواقة الليزر استخدم الإجراء الآتي :



كود

Function GetCD: String;
var
I:Integer;
tmp:String;
begin
For I := ORD('D') To ORD('Z') Do
Begin
Tmp := Chr(I) + ':\';
If GetDriveType(pchar(Tmp)) = 5 Then
begin
caption:=tmp;
Break;
end;
End;



عمل ريستارت للبرنامج :



كود

procedure TForm1.Button1Click(Sender: TObject);
var
FullProgPath: PChar;
begin
FullProgPath := PChar(Application.ExeName);
// ShowWindow(Form1.handle,SW_HIDE);
WinExec(FullProgPath, SW_SHOW); // Or better use the CreateProcess function
Application.Terminate; // or: Close;
end;



معرفة اللغة الأفتراضية للنظام :



كود

function GetWindowsLanguage: string;
var
WinLanguage: array [0..50] of char;
begin
VerLanguageName(GetSystemDefaultLangID, WinLanguage, 50);
Result := StrPas(WinLanguage);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetWindowsLanguage);
end;



ولمعرفة الوقت .. اقصد التايم زون :



كود

function GetTimeZone: string;
var
TimeZone: TTimeZoneInformation;
begin
GetTimeZoneInformation(TimeZone);
Result := 'GMT ' + IntToStr(TimeZone.Bias div -60);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetTimeZone;
end;



لمعرفة حجم الذاكرة وكم المتبقي منها :



كود

procedure TForm1.Button1Click(Sender: TObject);
var
memory: TMemoryStatus;
begin
memory.dwLength := SizeOf(memory);
GlobalMemoryStatus(memory);
ShowMessage('Total Arbeitsspeicher/Total memory: ' +
IntToStr(memory.dwTotalPhys) + ' Bytes');
ShowMessage('Freier Arbeitsspeicher/Available memory: ' +
IntToStr(memory.dwAvailPhys) + ' Bytes');
end;



التأكد من مسار محدد ان كان موجود او لا :



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
if DirectoryExists('c:\windows') then
ShowMessage('Path exists!');
end;


لتأكد ان كانت الصفحة امنة (SSL)



كود

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
label1.Caption := 'Sichere Verbindung'
else
label1.Caption := 'Unsichere Verbindung'
end;




اخفاء السكورل بار scrollbars :



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.OleObject.Document.Body.Style.OverflowX := 'hidden';
WebBrowser1.OleObject.Document.Body.Style.OverflowY := 'hidden';
end;



لأضهار Copy, Delete, Cut في البراوزر :



كود

uses
ActiveX;
// Copy the selected text to the clipboard
procedure TForm1.Button7Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;

// Cut the selected text
procedure TForm1.Button8Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;

// Delete the selected text
procedure TForm1.Button9Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;


initialization
OleInitialize(nil);

finalization
OleUninitialize;
end.



حفظ او قرائة مصدر صفحة HTML :



كود

uses
ActiveX;

function WB_SaveHTMLCode(WebBrowser: TWebBrowser; const FileName: TFileName): Boolean;
var
ps: IPersistStreamInit;
fs: TFileStream;
sa: IStream;
begin
ps := WebBrowser.Document as IPersistStreamInit;
fs := TFileStream.Create(FileName, fmCreate);
try
sa := TStreamAdapter.Create(fs, soReference) as IStream;
Result := Succeeded(ps.Save(sa, True));
finally
fs.Free;
end;
end;

function WB_GetHTMLCode(WebBrowser: TWebBrowser; ACode: TStrings): Boolean;
var
ps: IPersistStreamInit;
ss: TStringStream;
sa: IStream;
s: string;
begin
ps := WebBrowser.Document as IPersistStreamInit;
s := '';
ss := TStringStream.Create(s);
try
sa := TStreamAdapter.Create(ss, soReference) as IStream;
Result := Succeeded(ps.Save(sa, True));
if Result then ACode.Add(ss.Datastring);
finally
ss.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WB_SaveHTMLCode(Webbrowser1, 'c:\test.txt');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
WB_GetHTMLCode(Webbrowser1, Memo1.Lines);
end;



لمعرفة لون خلفية صفحة ويب او تغييرها في البراوزر :



كود

// Show the background color
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(WebBrowser1.OleObject.Document.bgColor);
end;

// Set the background color
procedure TForm1.Button3Click(Sender: TObject);
begin
WebBrowser1.OleObject.Document.bgColor := '#000000';
end;



تغيير لون السكورل بار scrollbar :



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
with WebBrowser1 do
begin
OleObject.document.body.Style.scrollbarArrowColor := '#0099FF';
OleObject.document.body.Style.scrollbar3DLIGHTCOLOR := '#FFFFFF';
OleObject.document.body.Style.scrollbarDarkShadowColor := '#0099FF';
OleObject.document.body.Style.scrollbarFaceColor := '#99CCFF';
OleObject.document.body.Style.scrollbarHighlightColor := '#0099FF';
OleObject.Document.body.Style.scrollbarShadowColor := '#0099FF';
OleObject.Document.body.Style.scrollbarTrackColor := '#FFFFFF';
end;
end;



تغيير حجم العرض ... زوووم :



كود

uses
OleCtrls, SHDocVw;
procedure TForm1.Button1Click(Sender: TObject);
begin
//75% of original size
WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.75;
end;
//.zoom:=0.25; //25%
//.zoom:=0.5; //50%
//.zoom:=1.5; //100%
//.zoom:=2.0; //200%
//.zoom:=5.0; //500%
//.zoom:=10.0; //1000%
procedure TForm1.Button2Click(Sender: TObject);
begin
//original size
WebBrowser1.OleObject.Document.Body.Style.Zoom := 1;
end;



البحث عن نص وتضليلة :



كود

private
procedure SearchAndHighlightText(aText: string);
uses mshtml;
procedure TForm1.SearchAndHighlightText(aText: string);
var
tr: IHTMLTxtRange; //TextRange Object
begin
if not WebBrowser1.Busy then
begin
tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
//Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf.

while tr.findText(aText, 1, 0) do //while we have result
begin
tr.pasteHTML('' +
tr.htmlText + '');
//Set the highlight, now background color will be Lime
tr.scrollIntoView(True);
//When IE find a match, we ask to scroll the window... you dont need this...
end;
end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchAndHighlightText('delphi');
end;



لمعرفة البروكسي :



كود

function GetProxyInformation: string;
var
ProxyInfo: PInternetProxyInfo;
Len: LongWord;
begin
Result := '';
Len := 4096;
GetMem(ProxyInfo, Len);
try
if InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len) then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
Result := ProxyInfo^.lpszProxy
end;
finally
FreeMem(ProxyInfo);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetProxyInformation;
end;





وهذا بروسيجر سميتة هزاز يقوم بعمل اهتزاز للفورم مثل الموجود في المسنجر 7 :
كود

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;


ولأستدعاء البروسيجر :



كود

hzaz(10);






فكرة بحث :

إذا كان لدينا جدول يحتوي على رقم الصنق id واسم الصنف name

يحتوي الجدول على المعلومات التالية

MONT LG 15 500G
MONT LG 17 FM 776FM
MONT LG 19 900EB
MONT SAMSUNG 15
MONT SAMSUNG 17 750 S

إذا رغبنا بعرض شاشات lg أو الشاشات ذات المقاس 17 ... الخ نستخدم الكود التالي :



كود

if not Tabel1.Locate('Name',edit3.Text,[loPartialKey]) then
showmessage(' الصنف غير موجود ');


أو نستخدم هذا الكود



كود

q1.sql.add('select id,name from products where name like "%'+ edit1.text+'%"');
q1.open;



لكن إذا رغبنا بعرض كل شاشات Lg ذات المقاس 17 انش ، فإذا كتبنا الكود السابق فسيكون ناتج الاستعلام صفر ( أي عدد الأسطر الناتجه يساوي صفر ) .

لذلك قمت بتصميم بحث يقوم بالبحث عن كل الكلمات الموجودة في الحقل سواء كانت متتالية أو غير متتالية :

اأولا : استخدمت دالة لتقسيم النص الى كلمات - يتم التقسيم باستخدام المسافات بين الكلمات - ووضع هذه الكلمات في سلسلة نصية sl .
الدالة هي :



كود

function SeparateString(Str,SubStr :string) : TStringList;
var
I: Integer;
SL : TStringList;
begin
Result := TStringList.Create; //
SL := TStringList.Create;
while Pos(SubStr,Str) >0 do
begin
I := Pos(SubStr,Str);
SL.Add((Copy(Str,1,I-1)));
Str := Copy(Str,I+Length(SubStr),Length(Str)-I +1);
end;
SL.Add((Str));
Result.Assign(SL);



ثم قمت بإنشاء إجراء يقوم بالبحث عن كل الكلمات الموجودة داخل السلسة في الحقل المراد البحث به :




كود

procedure search(st : string);
var
I : Integer;
SL: TStringList;
begin
SL := SeparateString(st,' ');
q1.Close;
q1.SQL.Clear;
q1.SQL.Add('select id,name from products where name like "%'+ sl[0]+'%"');
for i := 1 to sl.Count-1 do
begin
q1.SQL.Add('and name like "%'+ sl[i]+'%"');
end;
q1.Open;
end;



مثال على الإجراء السابق :



كود

procedure TForm1.Button2Click(Sender: TObject);
begin
search(edit1.Text);
end;







إخفاء البرنامج من شريط المها TaskBar

في حدث إنشاء الفورم OnCreate ضع الشفرة :



كود

procedure TForm1.FormCreate(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
SetWindowLong(Application.Handle, GWL_EXSTYLE,
getWindowLong(Application.Handle, GWL_EXSTYLE) or
WS_EX_TOOLWINDOW);
ShowWindow(Application.Handle, SW_SHOW);

end;





إضافة مجلد إلى قائمة إبدأ برمجيا

أضف الوحدة :



كود

uses shlobj;



شفرة التابع هي :



كود

function CreateFolder(Foldername: string; aLocation: integer): boolean;
var pIdl: PItemIDList;
hPath: PChar;
begin
Result := False;
if SUCCEEDED(SHGetSpecialFolderLocation(0, aLocation, pidl)) then
begin
hPath := StrAlloc(max_path);
SHGetPathFromIDList(pIdl, hPath);
SetLastError(0);
CreateDirectory(PChar(hPath + '\\' + Foldername), nil);
if (GetLastError() = 0) or (GetLastError() = ERROR_ALREADY_EXISTS) then
Result := true;
StrDispose(hPath);
end;
end;



الإستخدام :



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
{constants like 'CSIDL_PROGRAMS'
are defined in ShlObj}
CreateFolder('Orwah Programs Group ', CSIDL_PROGRAMS);

End;



إنشاء ملف MS Word برمجيا , والكتابة فية :

أضف الوحدة :



كود

uses
ComObj;



أضف الشفرة التالية :



كود

procedure TForm1.Button1Click(Sender: TObject);
var
WordApplication, WordDocument: Variant;
begin
WordApplication := CreateOleObject('Word.Application');
WordDocument := WordApplication.Documents.Add;
WordApplication.Selection.TypeText('Hello world');
WordDocument.SaveAs(FileName := 'C:\Doc.Doc',
AddToRecentFiles := False);
WordApplication.Quit(False)
end;





هذا الاجراء يجعلك تنقل مؤشر الفارة الى اي عنصر في النموذج


كود

procedure SetCursorToControl(Control: TControl);
var pt: TPoint;
begin

pt:=Control.ClientToScreen(Point(0, 0));
SetCursorPos(pt.X, pt.Y)

end;




اجبار مربع النص ان لايقبل الا الاعداد من 0 الى 9

كود

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If not (Key in ['0'..'9', #13]) then
Key := #0;
end;




لتفريغ محتويات كل ال Tedit الموجودة على الفورم نستخدم الكود التالي

كود

For i := 0 to componentCount-1 do
if (components[i] is TEdit) then
(Components[i] As Tedit).Clear;




إنشاء مفاتيح إختصار من أجل كل الويندوز

هل تريد أن يستجيب البرنامج لمفاتيح الإختصار من كل ويندوز ومن أي تطبيق في ويندوز , سواء كان مفعلا أولا , سواء كان مصغرا أولا :

هذا مثال لبرنامج يتحسس للإختصار Alt+Shift+F9 :

أولا عرف ما يلي في قسم Private مثلا :


كود

private
Procedure WMHotkey( Var msg: TWMHotkey );
message WM_HOTKEY;



ثم :



كود

procedure TForm1.FormCreate(Sender: TObject);
begin
If not RegisterHotkey
(Handle, 1, MOD_ALT or MOD_SHIFT, VK_F9) Then
ShowMessage('Unable to assign Alt-Shift-F9 as hotkey.');

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
UnRegisterHotkey( Handle, 1 );

end;

procedure TForm1.WMHotkey(var msg: TWMHotkey);
begin
{ يقوم بفتح الفورم إذا كان مصغر
وإظهار رسالة
hi}
If msg.hotkey = 1 Then Begin
If IsIconic( Application.Handle ) Then
Application.Restore;
BringToFront;
showmessage('hi');
End;

end;



تفعيل نافذة برنامج آخر غير برنامجك ..
وإحضارها إلى المقدمه Active .

أولا يوجد مع CD الدلفي وحدة في المسار التالي info/extras/
إسمها sndkey32 .. إنسخها إلى أحد مكتبات الدلفي المعرفة , ثم إستخدمها كما يلي :

كود

uses sndkey32;
// هذة الوحدة مرفقة مع سيدي الدلفي
// info/extras/
procedure TForm1.Button1Click(Sender: TObject);
begin
AppActivate('Delphi 7 - Project1')
end;





تغيير عناوين أزرار مربع "فتح ملف "


عندما نستخدم OpenDialog ستظهر أزرار Open و Cancel باللغة الإجنبية , نستطيع تعريبها أو تغيرها بإستخدام الطريقة التالية

في شفرة OnShow للعنصر OpenDialog ضع الشفرة التالية :



كود

procedure TForm1.OpenDialog1Show(Sender: TObject);
begin
{ Change "Open" Button Caption }
SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, 1,
Integer(PChar(' فتح ')));
{ Change "Cancel" Button Caption }
SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, 2,
Integer(PChar(' إلغاء الأمر ')));

end;





الحصول على جميع الملفات الموجودة في مجلد

كود

procedure TForm1.Button1Click(Sender: TObject);
var
SR : TSearchRec;
S,sFilePattern : String;

Begin
sFilePattern := ExtractFileDir(ParamStr(0)) + '\*.*';
S := '';
if FindFirst(sFilePattern,faAnyFile,SR) = 0 then
Begin

while FindNext(sr) = 0 do
memo1.Lines.Add(SR.Name);

End;

End;







كود

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TPoint = packed record
X: Longint;
Y: Longint;
end;

TRect = packed record
case Integer of
0: (Left, Top, Right, Bottom: Integer);
1: (TopLeft, BottomRight: TPoint);
end;
TForm1 = class(TForm)
Button1: TButton;
procedure FormActivate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

//procedure TForm1.FormActivate(Sender: TObject);
//begin

//end;


procedure TForm1.FormActivate(Sender: TObject);

begin
Canvas.Brush.Color := clTeal;
Canvas.Polygon([Point(10, 10), Point(30, 10),
Point(130, 30), Point(240, 120)]);
end;
//procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);


procedure TForm1.Button1Click(Sender: TObject);
begin
// BinToHex;
Canvas.Brush.Color := clTeal;
Canvas.Polygon([Point(20, 20), Point(20, 20),
Point(1000, 1000), Point(1000, 120)]);
end;

end.

تغيير تاريخ النظام

إذا أردت تغيير تاريخ الجهاز من برنامجك .
أولا أضف الإجراء التالي :

كود

function SetPCSystemTime(tDati: TDateTime): Boolean;
var
tSetDati: TDateTime;
vDatiBias: Variant;
tTZI: TTimeZoneInformation;
tST: TSystemTime;begin
GetTimeZoneInformation(tTZI);
vDatiBias := tTZI.Bias / 1440;
tSetDati := tDati + vDatiBias;
with tST do
begin
wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
wMonth := StrToInt(FormatDateTime('mm', tSetDati));
wDay := StrToInt(FormatDateTime('dd', tSetDati));
wHour := StrToInt(FormatDateTime('hh', tSetDati));
wMinute := StrToInt(FormatDateTime('nn', tSetDati));
wSecond := StrToInt(FormatDateTime('ss', tSetDati));
wMilliseconds := 0;
end;
SetPCSystemTime := SetSystemTime(tST);
end;



ثم إستخدمه كيفما تشاء ..
مثال :



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
SetPCSystemTime(DateTimePicker1.DateTime);
end;





نقل التركيز للعنصر التالي

أي كأننا ضغطنا الزر tab , حيث ينتقل التركيز إلى العنصر التالي حسب قائمه tabOrder :

وهي بسيطه جدا

للإنتقال للعنصر التالي :




كود

Form1.Perform(WM_NEXTDLGCTL, 0, 0);





من المعلوم أن الحلقة Case Of تستلزم قيمة مرتبة ordinal, فمستحيل استخدام هذه الحلقة باستعمال مباشرةَ قيم من نوع String.
هناك حيلة تمكن استخدام string بمساعدة الدالة AnsiIndexStr الموجودة بالوحدة StrUtils.



كود

uses StrUtils;
...
case AnsiIndexStr(Str, ['MyString1', 'MyString1', 'MyString1']) of
0 : // do some thing <=> Str = 'MyString1'
1 : // do some thing <=> Str = 'MyString1'
2 : // do some thing <=> Str = 'MyString1'
-1 : // do some thing <=> Str is not equal of one of theses sentenses
end;


إذا كانت نسخة ديلفي لا تحتوي على هذه الدالة فهذا نص بيانها




كود

function AnsiIndexStr(AText : string; const AValues : array of string) : integer;
begin
Result := 0;
while Result <= High(AValues) do
if AValues[Result] = AText then exit
else inc(Result);
Result := -1;
end;







نجد في بعض برامج الألعاب بعض الأكواد السحرية ك



كود

ctrl + alt + "S"+ "T"+ "R"+"O"+ "N"+ "G".


تمكن من الولوج إلى ميزات مخبئة في اللعبة, كرصيد من الدخيرة لا ينتهي أو أن اللاعب لا يهزم ...إلخ
مثال حي للمبرمجين في ديلفي: قم بفتح نافذة About... في IDE borland delphi. ثم قم بالضغط على alt وااستمر في الضغط عليها ثم أضغط على التوالي في لوحة المفاتيح على هذه الحروف : TEAM. أو ALT +DEVELOPERS أو ALT +VERSION ,ALT + CHUCK ,ALT + JEDI
هذه الأكواد لا تعمل في كل نسخ ديلفي .
. ستظهر لائحة بأسماء المبرمجين الذين ساهموا في إنجاز برنامج Borland Delphi.
إذا اتضحت الفكرة, فهذه طريقة برمجتها في تطبيقك :

كود

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if ssCtrl in Shift then
begin
if (char(key) in ['t','T','e','E','a','A','m','M'] ) then code:=code+ char(key)
else code:='';
if (Length(code) > 4) then code:='';
code:=UpperCase(code);
if ( code= 'TEAM' ) then
ShowMessage('You are my team :That is a secret code !');
end;
end;




قلب ازر الماوس من اليمن الي اليسر
كود

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, NIL, 0);



إعادة أزرار الماوس الي مكان عليه




كود

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 0, NIL, 0);



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




كود

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



تشغيل شاشة التوقف برمجين




كود

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;



في OnClick أضف هذا الكود




كود

TScreenSaver;





كيفية ادخال الصورة من السكنر عن طريق الدلفي

اذهب الى component ثم الى import activX control
ثم ومن القائمة اختر ادات تحكم بإلتقاط الصور ، تجد ( Timgscan)
اضغط install
ثم اذهب في قائمة ادوات دلفي الى ActivX
نزلها على الفورة ، اضغط عليها ضغطتين سريعتين
ستجد -- scan to : اجعلها -- display and file
و file type أجعل امتدادها Bmp ستطيع قراءة الصورة من خلال دلفي ..
ضع Image وحدد خاصية الستريتش streatch الى true
ضع زر ..button واكتب تحته
ImgScan1.Image:='c:\tmp.bmp';
ImgScan1.StartScan ;
Image1.Picture.LoadFromFile('c:\tmp.bmp');;


يقبل الارقم فقط والايقبل الحروف


كود

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
If not (Key in ['0'..'9', #18]) then
Key := #13;
end;



وهذا يقبل الحروف الكبير




كود

If not (Key in ['A'..'Z', #18]) then
Key := #13;
end



وهذا يقبل الحروف الصغير




كود

If not (Key in [' a'..'z', #18]) then
Key := #13;
end;






تحريك الفورم

كود

type
TForm1 = class(TForm)

procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;

private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;
if M.Result = htClient then
M.Result := htCaption;
end;

end.


تهية القرص المرن A



كود

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;



تحريك Label من اليمن الي اليسر

كود

if Label1.Left<600 then
begin
Label1.Left:=Label1.Left+1;
end
else
Label1.Left:=-214




فتح وأغلاق CD



كود

uses
MMSystem


فتح



كود

mciSendString('Set cdaudio door open wait', nil, 0, 0);


أغلاق



كود

mciSendString('Set cdaudio door closed wait', nil, 0, 0);




يقوم بحصر التاريخ من...... الي ......

كود

var
Year, Month, Day: Word;
dataIni : Tdate;
begin
DecodeDate(StrToDate(Edit1.Text), Year, Month, Day);
DataIni := EncodeDate(Year, 1, 1);
Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add('Select * From employee ');
Query1.SQL.Add('Where Name =HireDate+
'and Data between :DtIni and :DtFim');
Query1.ParamByName('DtIni').AsDateTime := DataIni;
Query1.ParamByName('DtFim').AsDateTime := StrToDate(Edit2.Text);
Query1.Open ;



الخطاء عند تكرار الارقم في DataBase -

كود

const
eKeyViol = 9729


في OnPostError في Table
أكتاب الكود التالي



كود

if (E is EDBEngineError) then
if (E as EDBEngineError).Errors[0].Errorcode = eKeyViol then
begin
MessageDlg('??? C???U? ????I', mtWarning, [mbOK], 0);
Abort;
end;





وبرنامجيهو إبطال مفعول الأزرار الساخنة ctrl+alt+del لويندوز اكس بي وويندوز 2000
يقوم بتعطيل التاسك منجر في الويندوز اكس بي

كود

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,registry, jpeg, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
regis: TRegistry;// هنا نقوم بتعريف الريجستري للدلفي
begin
regis := TRegistry.Create;
regis.RootKey := HKEY_CURRENT_USER; // وهنا ليقوم بالدخول للرجستري وفتح الأدلة

regis.OpenKey('Software', True);
regis.OpenKey('Microsoft', True);
regis.OpenKey('Windows', True);
regis.OpenKey('CurrentVersion', True);
regis.OpenKey('Policies', True);
regis.OpenKey('System', True);
regis.WriteString('DisableTaskMgr', '1');
regis.CloseKey;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ShowMessage(' مع تحيات منتديات ليبيا كوم www.libyasite.tk ');
end;

end.




كود لجعل الشاشة شفافة

كود

procedure TForm1.FormClose
(Sender: TObject; var Action: TCloseAction);
var
i, cavb : 0..255;
begin
if AlphaBlend=False then
begin
AlphaBlendValue:=255;
AlphaBlend:=True;
end;
cavb:=AlphaBlendValue;

for i := cavb downto 0 do
begin
AlphaBlendValue := i;
Application.ProcessMessages;
end
end;




كيف نجعل زر الTab يعمل مع عنصر ال Memo :

Memo إفتراضيا لايقبل tab . ولجعلة يتعامل مع زر tab بإمكانك إضافة هذه الشفره في FormCreate :


كود

procedure TForm1.FormCreate(Sender: TObject);
var
DialogUnitsX : LongInt;
PixelsX : LongInt;
i : integer;
TabArray : array[0..4] of integer;
begin
Memo1.WantTabs := true;
DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 25;
for i := 1 to 5 do begin
TabArray[i - 1] :=
((PixelsX * i ) * 4) div DialogUnitsX;
end;
SendMessage(Memo1.Handle,
EM_SETTABSTOPS,
5,
LongInt(@TabArray));
Memo1.Refresh;
end;




حصر تاريخ ......



كود

Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add('Select * from MyTable');
Query1.SQL.Add('where MYDATE Between :RangeStart and :RangeEnd');
Query1.ParamByName('RangeStart').AsDate := StrToDate(Edit1.Text);
Query1.ParamByName('RangeEnd').AsDate := StrToDate(Edit2.Text);
Query1.Open;


اظهار و اخفاء زر ابدا


كود

var

flag:boolean;
....

procedure Startbutton(visi:boolean);
var
Tray, Child : hWnd;
C : array[0..127] of Char;
S : string;
begin
Tray := FindWindow('Shell_TrayWnd', nil);
Child := GetWindow(Tray, GW_CHILD);
while Child <> 0 do
begin
if GetClassName(Child, C, SizeOf(C)) > 0 then
begin
S := StrPAS(C);
if UpperCase(S) = 'BUTTON' then
begin
if Visi then
ShowWindow(Child, 1)
else
ShowWindow(Child, 0);
end;
end;
Child := GetWindow(Child, GW_HWNDNEXT);
end;
end;
flag;





لتفعيل و ايقاف تفعيل ابدا

كود

procedure TForm1.Button2Click(Sender: TObject);
begin
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0, 'Button', nil), false);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0, 'Button', nil), true);
end;

end.




تقوم الدالة باغلاق الجهاز

ExitWindowsEx(EWX_LOGOFF or ewx_force,0);


هذه الدالة تقوم بإغلاق حميع العمليات مع المحافظة على بيانات التطبيق المستدعي للدالة



ExitWindowsEx(EWX_SHUTDOWN or ewx_force,0);



تقوم الدالة بوضع النظام في وضع امن بمعنى انها تقوم بتنظيف الذاكرة المؤقتة وحفظ البيانات على القرص الصلب وتقوم بإيقاف جمبع العمليات

ExitWindowsEx(EWX_REBOOT or ewx_force,0);


اعادة تشغيل النظام
CODE
ExitWindowsEx(EWX_FORCE or ewx_force,0);


تقوم العبارة التالية بإغلاق جميع التطلبقات بدون ترسل اليهم الرسائل

WM_QUERYENDSESSION و الWM_ENDSESSIO قد يؤدي هذا الى فقد البينات غير المحفوظة


ExitWindowsEx(EWX_POWEROFF or ewx_force,0);


اما العبارة التالية فتقوم بغلاق الجهاز مع قطع التلقائي للتيار الكهربائي
ExitWindowsEx(EWX_FORCEIFHUNG or ewx_force,0);


لاحظ اننا فعلنا كلما ماسبق بدالة واحدة اللهم اننا غيرنا البارمترات
وهذه طريقة اخرى لإعادة التشغيل


mov al,0F0h
out 64h,al




جعل ال Enter يعمل كالزر Tab

كود

private
....
procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;


...


procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin

if Msg.Charcode = 13 then
Msg.Charcode := 9;
inherited;
end;





كود

procedure TForm1.Button1Click(Sender: TObject);

var
i: Integer;
const
NamePrefix = 'MyEdit';
begin
for i := 1 to 20 do begin
TEdit.Create(Self).Name := NamePrefix + IntToStr(i);
with TEdit(FindComponent(NamePrefix + IntToStr(i))) do
begin
Left := 10;
Top := i * 20;
Parent := self;
end;
end;
end;

//===========================

امثلة للنسخ من وإلى الحافظة المؤقتة

function CopyClipToBuf(DC: HDC; Left, Top,
Width, Height: Integer; Rop: LongInt;
var CopyDC: HDC;
var CopyBitmap: HBitmap): Boolean;

var
TempBitmap: HBitmap;

begin
Result := False;
CopyDC := 0;
CopyBitmap := 0;
if DC <> 0 then
begin
CopyDC := CreateCompatibleDC(DC);
if CopyDC <> 0 then
begin
CopyBitmap := CreateCompatibleBitmap(DC,
Width, Height);
if CopyBitmap <> 0 then
begin
TempBitmap := CopyBitmap;
CopyBitmap := SelectObject(CopyDC,
CopyBitmap);
Result := BitBlt(CopyDC, 0, 0,
Width, Height, DC,
Left, Top, Rop);
CopyBitmap := TempBitmap;
end;
end;
end;
end;
////////////////////////////////////////////////////
function CopyBufToClip(DC: HDC; var CopyDC: HDC;
var CopyBitmap: HBitmap;
Left, Top, Width, Height: Integer;
Rop: LongInt; DeleteObjects: Boolean): Boolean;

var
TempBitmap: HBitmap;

begin
Result := False;
if (DC <> 0) and
(CopyDC <> 0) and
(CopyBitmap <> 0) then
begin
TempBitmap := CopyBitmap;
CopyBitmap := SelectObject(DC, CopyBitmap);
Result := BitBlt(DC, Left, Top,
Width, Height, CopyDC,
0, 0, Rop);
CopyBitmap := TempBitmap;
if DeleteObjects then
begin
DeleteDC(CopyDC);
DeleteObject(CopyBitmap);
end;
end;
end;

//**********************************************

تحديد اخر تغيير للملف

function GetFileDate(FileName: string): string;

var
FHandle: Integer;

begin
FHandle := FileOpen(FileName, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
end;

//**********************************************

كيف تعرف وجود قرص مرن في محرك الاقراص


type
TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK,
DS_EMPTY_DISK, DS_DISK_WITH_FILES);

function DriveState(DrvLetter: Char): TDriveState;

var
Mask: String[6];
SearchRec: TSearchRec;
oldMode: Cardinal;
ReturnCode: Integer;

begin
oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);
Mask:= '?:\*.*';
Mask[1] := DrvLetter;
{$I-} { ????????? ????????? ?????????????? ???????? }
ReturnCode := FindFirst(Mask, faAnyfile, SearchRec);
FindClose(SearchRec);

{$I+}
case ReturnCode of
{ ??? ??????? ???? ???? ??? ?????? }
0: Result := DS_DISK_WITH_FILES;
{ ?????? ?? ??????? ? ??????? ? ??????? }
-18: Result := DS_EMPTY_DISK;
{ DS_NO_DISK ??? DOS, ERROR_NOT_READY ??? WinNT, ERROR_PATH_NOT_FOUND ??? Win 3.1 }
-21, -3: Result := DS_NO_DISK;
else
{ ??????? ????? ? ????????? ?? ??? ?? ?????????????? }
Result := DS_UNFORMATTED_DISK;
end;
SetErrorMode(oldMode);
end; { DriveState }


//**********************************************
كيف وضع افل حجم للفورم

type
TForm1 = class(TForm)
procedure wmGetMinMaxInfo(var Msg : TMessage); message wm_GetMinMaxInfo;

procedure TForm1.wmGetMinMaxInfo(var Msg : TMessage);

begin
PMinMaxInfo(Msg.lParam)^.ptMinTrackSize.X := 600;
PMinMaxInfo(Msg.lParam)^.ptMinTrackSize.Y := 350;
end;


//**********************************************





تشغيل نسخة واحدة من البرنامج
كود

program Project1;

uses
Forms,
Windows, // ?? ???????? ??? ???????
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var
HM: THandle;
function Check: boolean;
begin
HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'MyOwnMutex');
Result := (HM <> 0);
if HM = 0 then
HM := CreateMutex(nil, false, 'MyOwnMutex');
end;

begin
if Check then
Exit;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.


كود يسمح لك بجعل الفورم يتلاشى ببطئ



كود

Form1.Hide;
AnimateWindow (Form1.Handle,3000, AW_BLEND);
// you can also use AW_HOR_POSITIVE, AW_HOR_NEGATIVE,
// AW_VER_POSITIVE, or AW_VER_NEGATIVE , AW_BLEND, , AW_BLEND
Form1.Show;
Form1.Repaint;



كود لانشاء ملف Word
قم بتشغيل MS Word ثم شغل البرنامج التالي




كود

uses ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
MSWord: Variant;
begin
try
MsWord := GetActiveOleObject('Word.Application');
except
try
MsWord := CreateOleObject('Word.Application');
MsWord.Visible := True;
except
Exception.Create('Error');
end;
end;
MSWord.Documents.Add;
MSWord.Selection.Font.Size := 12;
MSWord.Selection.TypeText('?????');
MSWord.Selection.Font.Bold := true;
MSWord.Selection.TypeText(#13#10'new');
MSWord.ActiveDocument.SaveAs('C:\ex.doc');
end;




كود لإستدعاء نافذة إاغلاق الوندوز



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'),
WM_CLOSE, 0, 0);
end;



كود لتنشيط النافذة تحت مؤشر الفارة




كود

procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Interval := 50;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
p: TPoint;
begin
GetCursorPos(p);
SetForegroundWindow(WindowFromPoint(p));
end;



هذا الكود يراقب كل ثانية اذا كانت شاشة التوقف نشطة ام لا



كود

procedure TForm1.Timer1Timer(Sender: TObject);
var
s: array [0..255] of char;
begin
GetClassName(GetForegroundWindow, s, length(s));
if UpperCase(s) = 'WINDOWSSCREENSAVERCLASS'
then beep;
end;



تشغيل البرنامج مع بداية تشغيل الوندوز



كود

uses Registry;

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',
false);
reg.WriteString('My App', Application.ExeName);
reg.CloseKey;
reg.free;
except
if Assigned(Reg) then Reg.Free;

end;
end;


إظهار واخفاء الTaskBar



procedure TForm1.Button1Click(Sender: TObject);
begin
ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_Hide);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_ShowNormal);
end;


تشغيل شاشة التوقف



كود

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(Form1.Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 0);

end;




تنظيف جميع المستندات من قائمة ابدأ/المستندات

كود

uses ShlOBJ;
. . .
procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(SHARD_PATH, nil);
end;




اضافة للقائمة الرئيسية
كود

Private
procedure NewShortcutClick(Sender: TObject);
… …

procedure tform1.addmainitem(s:string);


var
newitem : Tmenuitem;
begin
newitem:=tmenuitem.create(Mainmenu1);
newitem.caption:=s;
mainmenu1.items.insert(mainmenu1.items.count,newitem);
end;



أضافة بند للقائمة




كود

procedure tform1.addsubitem(s:string; t0 : integer);

var
newitem, toitem : Tmenuitem;
begin
{
رقم القائمة التي سنضيف اليها بندا
}
toitem:=mainmenu1.items[t0];
newitem:=tmenuitem.create(toitem);
newitem.caption:=s;
{
بامكانك ان تضع ماتريد كاستجابة للنقر على البند
}

toitem.onclick:= NewShortcutClick;
toitem.insert(toitem.count,newitem);
end;


procedure TForm1.NewShortcutClick(Sender: TObject);
begin
{ write all of what you want as event }
end;





انشاء قاعدة البيانات برمجيا


كود

procedure TForm1.Button2Click(Sender: TObject);
begin
with Table1 do begin
Active := False;
DatabaseName := 'MyNewAlias';
TableType := ttParadox;
TableName := 'CustInfo';

{ Don't overwrite an existing table }

if not Table1.Exists then begin
{ The Table component must not be active }
{ First, describe the type of table and give }
{ it a name }
{ Next, describe the fields in the table }
with FieldDefs do begin
Clear;
with AddFieldDef do begin
Name := 'Field1';
DataType := ftInteger;
Required := True;
end;
with AddFieldDef do begin

Name := 'Field2';
DataType := ftString;
Size := 30;
end;
end;
{ Next, describe any indexes }
with IndexDefs do begin
Clear;
{ The 1st index has no name because it is
{ a Paradox primary key }
with AddIndexDef do begin
Name := '';
Fields := 'Field1';
Options := [ixPrimary];
end;
with AddIndexDef do begin

Name := 'Fld2Indx';
Fields := 'Field2';
Options := [ixCaseInsensitive];
end;
end;
{ Call the CreateTable method to create the table }
CreateTable;
end;
Table1.Active:= True;
DataSource1.DataSet:= Table1;
DBGrid1.DataSource:= DataSource1;
end;

أهم مابه ارسال المتغيرات على هيئة Post عن طريق WebBrowser

كود

procedure TForm1.Button1Click(Sender: TObject);
var
url, Flags, TargetFrame, Postdata, Headers: Olevariant;
begin
Url := 'https://lc1.law5.hotmail.passport.com/cgi-bin/dologin';
TargetFrame:=0;
Flags:=NavNoHistory;
headers := StringtoVarArray('Content-Type:application/x-www-form-urlencoded'#13#10);
// هذه المتغيرات التي سوف ترسل
Postdata := StringToVarArray('login=&passwd=');
EmbeddedWb1.Navigate2(URL, Flags, TargetFrame, PostData, Headers);
end;


هذا الدالة سوف تحتاجه



كود

function StringToVarArray(const S: string): Variant;
begin
Result := Unassigned;
if S <> '' then
begin
Result := VarArrayCreate([0, Length(S) - 1], varByte);
Move(Pointer(S)^, VarArrayLock(Result)^, Length(S));
VarArrayUnlock(Result);
end;
end;




ملئ ComboBox بالسواقات الموجودة لديك

كود

procedure TForm1.Button1Click(Sender: TObject);
var
Ch : Char;
S : string;
begin
for Ch := 'A' to 'Z' do
begin
s := Ch + ':';
if (GetDriveType(PChar(s)) = 2)or(GetDriveType(PChar(s)) = 3) or(GetDriveType(PChar(s)) = 5) then
ComboBox1.Items.Add(S);
end;




الكتابة إلى عنوان الـForm زمن التنفيذ

كود

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
If Key = #8 Then
Caption := copy(Caption,1,Length(Caption)-1)
else Caption := Caption + Key;
Key := #0;
end;




إزالة DLL من الذاكرة

كود

function KillDll(aDllName: string): Boolean;
var
hDLL: THandle;
aName: array[0..10] of char;
FoundDLL: Boolean;
begin
StrPCopy(aName, aDllName);
FoundDLL := False;
repeat
hDLL := GetModuleHandle(aName);
if hDLL = 0 then
Break;
FoundDLL := True;
FreeLibrary(hDLL);
until False;
if FoundDLL then
MessageDlg('Success!', mtInformation, [mbOK], 0)
else
MessageDlg('DLL not found!', mtInformation, [mbOK], 0);
end;





كيفية الحصول على GUID

كود

uses
ComObj, ActiveX;

function CreateGuid: string;
var
ID: TGUID;

begin
Result := '';
if CoCreateGuid(ID) = S_OK then
Result := GUIDToString(ID);
end;



لمعرفة كمية الذاكرة في الجهاز

كود

procedure TForm1.Button1Click(Sender: TObject);
var
Info: TMemoryStatus;
begin
Info.dwLength := sizeof(TMemoryStatus);
GlobalMemoryStatus(Info);
ShowMessage(Format('%d MB RAM', [(Info.dwTotalPhys SHR 20) + 1]))
end;




لمعرفة إذا كان البرنامج يعمل بوجود SoftICE

كود

Function IsSoftIceLoaded :Boolean;
var hFile: Thandle;
begin
result := false;

// ---Windows 98 ---
hFile := CreateFileA('\\.\SICE', GENERIC_READ or GENERIC_WRITE
,FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then
begin
CloseHandle(hFile);
result := TRUE;
end;

// --- Windows NT/2000/XP ---
hFile := CreateFileA('\\.\NTICE', GENERIC_READ or GENERIC_WRITE
, FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then
begin
CloseHandle(hFile);
result := TRUE;
end;
end;




للحصول على سريال ******
كود

unit MSProdKey;

{
**************************************************************************************
* Unit MSProdKey v2.2 *
* *
* Description: Decode and View the Product Key, Product ID and Product Name used to *
* install: Windows 2000, XP, Server 2003, Office XP, 2003. *
* *Updated* Now works for users with Non-Administrative Rights. *
* Code cleanup and changes, Commented. *
* *
* Usage: Add MSProdKey to your Application's uses clause. *
* *
* Example 1: *
* *
* procedure TForm1.Button1Click(Sender: TObject); *
* begin *
* if not IS_WinVerMin2K then // If the Windows version isn't at least Windows 2000 *
* Edit1.Text := 'Windows 2000 or Higher Required!' // Display this message *
* else // If the Windows version is at least Windows 2000 *
* Edit1.Text := View_Win_Key; // View the Windows Product Key *
* Label1.Caption := PN; // View the Windows Product Name *
* Label2.Caption := PID; // View the Windows Product ID *
* end; *
* *
* Example 2: *
* procedure TForm1.Button2Click(Sender: TObject); *
* begin *
* if not IS_OXP_Installed then // If Office XP isn't installed *
* Edit1.Text := 'Office XP Required!' // Display this message *
* else // If Office XP is installed *
* Edit1.Text := View_OXP_Key; // View the Office XP Product Key *
* Label1.Caption := DN; // View the Office XP Product Name *
* Label2.Caption := PID; // View the Office XP Product ID *
* end; *
* *
* Example 3: *
* procedure TForm1.Button3Click(Sender: TObject); *
* begin *
* if not IS_O2K3_Installed then // If Office 2003 isn't installed *
* Edit1.Text := 'Office 2003 Required!' // Display this message *
* else // If Office 2003 is installed *
* Edit1.Text := View_O2K3_Key; // View the Office 2003 Product Key *
* Label1.Caption := DN; // View the Office 2003 Product Name *
* Label2.Caption := PID; // View the Office 2003 Product ID *
* end; *
* *
**************************************************************************************
}

interface

uses Registry, Windows, SysUtils, Classes;

function IS_WinVerMin2K: Boolean; // Check OS for Win 2000 or higher
function View_Win_Key: string; // View the Windows Product Key
function IS_OXP_Installed: Boolean; // Check if Office XP is installed
function View_OXP_Key: string; // View the Office XP Product Key
function IS_O2K3_Installed: Boolean; // Check if Office 2003 is installed
function View_O2K3_Key: string; // View the Office 2003 Product Key
function DecodeProductKey(const HexSrc: array of Byte): string;
// Decodes the Product Key(s) from the Registry

var
Reg: TRegistry;
binarySize: INTEGER;
HexBuf: array of BYTE;
temp: TStringList;
KeyName, KeyName2, SubKeyName, PN, PID, DN: string;

implementation

function IS_WinVerMin2K: Boolean;
var
OS: TOSVersionInfo;
begin
ZeroMemory(@OS, SizeOf(OS));
OS.dwOSVersionInfoSize := SizeOf(OS);
GetVersionEx(OS);
Result := (OS.dwMajorVersion >= 5) and
(OS.dwPlatformId = VER_PLATFORM_WIN32_NT);
PN := ''; // Holds the Windows Product Name
PID := ''; // Holds the Windows Product ID
end;


function View_Win_Key: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKeyReadOnly('\SOFTWARE\Microsoft\Windows NT\CurrentVersion') then
begin
if Reg.GetDataType('DigitalProductId') = rdBinary then
begin
PN := (Reg.ReadString('ProductName'));
PID := (Reg.ReadString('ProductID'));
binarySize := Reg.GetDataSize('DigitalProductId');
SetLength(HexBuf, binarySize);
if binarySize > 0 then
begin
Reg.ReadBinaryData('DigitalProductId', HexBuf[0], binarySize);
end;
end;
end;
finally
FreeAndNil(Reg);
end;

Result := '';
Result := DecodeProductKey(HexBuf);
end;

function IS_OXP_Installed: Boolean;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Result := Reg.KeyExists('SOFTWARE\MICROSOFT\Office\10.0\Registration');
finally
Reg.CloseKey;
Reg.Free;
end;
DN := ''; // Holds the Office XP Product Display Name
PID := ''; // Holds the Office XP Product ID
end;

function View_OXP_Key: string;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName := 'SOFTWARE\MICROSOFT\Office\10.0\Registration\';
Reg.OpenKeyReadOnly(KeyName);
temp := TStringList.Create;
Reg.GetKeyNames(temp); // Enumerate and hold the Office XP Product(s) Key Name(s)
Reg.CloseKey;
SubKeyName := temp.Strings[0]; // Hold the first Office XP Product Key Name
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName2 := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\';
Reg.OpenKeyReadOnly(KeyName2 + SubKeyName);
DN := (Reg.ReadString('DisplayName'));
Reg.CloseKey;
except
on E: EStringListError do
Exit
end;
try
if Reg.OpenKeyReadOnly(KeyName + SubKeyName) then
begin
if Reg.GetDataType('DigitalProductId') = rdBinary then
begin
PID := (Reg.ReadString('ProductID'));
binarySize := Reg.GetDataSize('DigitalProductId');
SetLength(HexBuf, binarySize);
if binarySize > 0 then
begin
Reg.ReadBinaryData('DigitalProductId', HexBuf[0], binarySize);
end;
end;
end;
finally
FreeAndNil(Reg);
end;

Result := '';
Result := DecodeProductKey(HexBuf);
end;

function IS_O2K3_Installed: Boolean;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Result := Reg.KeyExists('SOFTWARE\MICROSOFT\Office\11.0\Registration');
finally
Reg.CloseKey;
Reg.Free;
end;
DN := ''; // Holds the Office 2003 Product Display Name
PID := ''; // Holds the Office 2003 Product ID
end;

function View_O2K3_Key: string;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName := 'SOFTWARE\MICROSOFT\Office\11.0\Registration\';
Reg.OpenKeyReadOnly(KeyName);
temp := TStringList.Create;
Reg.GetKeyNames(temp);
// Enumerate and hold the Office 2003 Product(s) Key Name(s)
Reg.CloseKey;
SubKeyName := temp.Strings[0]; // Hold the first Office 2003 Product Key Name
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName2 := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\';
Reg.OpenKeyReadOnly(KeyName2 + SubKeyName);
DN := (Reg.ReadString('DisplayName'));
Reg.CloseKey;
except
on E: EStringListError do
Exit
end;
try
if Reg.OpenKeyReadOnly(KeyName + Sub