أفكار سريعة

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

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

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 مع الوحدات :

USES
  WinInet;

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

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;

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

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

LOADKEYBOARdlayout('00000401',klf_activate);

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

LOADKEYBOARdlayout('00000409',klf_activate);

شكرا لـ جيمس بوند 007 (ملتقى المبرمجين العرب)

تحويل الصورة من 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;

شكرا لـ Justnick (ملتقى المبرمجين العرب)

السلام عليكم

فكرة الموضوع رائعة تشكر عليها أخي العزيز عروة وأتمنى من جميع الإخوان المشاركة لكي نحصل على كم كبير من الأكواد التي ستفيد بإذن الله كل مبتدئ

سأبدأ ببعض الأكواد

لملأ قائمة بخطوط الوندوز

ComboBox1.Items := Screen.Fonts

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

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

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

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

Uses

  Windows;



procedure ChangeWallpaper(Bitmap: string);

begin

  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Pchar(Bitmap),
SPIF_UPDATEINIFILE);

end;

شكرا لـ Jazarsoft.com

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

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

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;

شكرا لـ Jazarsoft.com

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

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

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;

شكرا لـ Jazarsoft.com .

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

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

شكرا لـ *vegatron*

من Arabdevelopers.com

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

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

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

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, NIL, 0);

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

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

 SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 0, NIL, 0);

شكرا لـ *vegatron*

من Arabdevelopers.com

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

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

شكرا لـ *vegatron*

من Arabdevelopers.com

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

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

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;

شكرا لـ مصطفى ممم

من Arabdevelopers.com

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

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;

مجموعة اكواد للتعامل مع البراوزر TWebbrowser

-------------------------------------

لتأكد ان كانت الصفحة امنة (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('<span style="background-color: Lime; font-weight: bolder;">' + 
        tr.htmlText + '</span>'); 
      //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+'%"');
                      end;
                    q1.Open;
end;

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

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