Gönderen Konu: html içinde arama yaptırmak (Okunma sayısı 1553 defa)

muderless · « : 26 Kasım 2005 01:44:42 »

Kod: (Unknown Language)

(*******************************************************
 TheLiandRi/DeveloperX
 24.11.2004
********************************************************)
 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw, MShtml,StdCtrls;
 
type
  TForm1 = class(TForm)
    btnAra: TButton;
    edSearchText: TEdit;
    WebBrowser1: TWebBrowser;
    Label1: TLabel;
    edDIR: TEdit;
    Label2: TLabel;
    Label3: TLabel;
    lbURL: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    function SearchHtml(Aranan:String):string;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure GetHTMLFileList;
    procedure btnAraClick(Sender: TObject);
    procedure SearchAndHighlightText(aText: string);
    procedure WebBrowser1DocumentComplete(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
  private
    { Private declarations }
  public
    FileList:TStringList;
 
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
function TForm1.SearchHtml(Aranan:String):string;
var
  strl:TStringList;
  i:integer;
begin
  Result:='';
  strl:=TStringList.Create;
  for i:=0 to FileList.Count-1 do
  begin
   strl.LoadFromFile(FileList.Strings[i]);
   if Pos(Aranan,strl.Text)>0 then     // aranan text dosyada varmı
   begin
     Result:=FileList.Strings[i];   // varsa dosyanın adını al 
     Break;                         // ve işlemi durdur
   end;
  end;
  strl.Free;
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  FileList:=TStringList.Create;
  edDIR.Text:=ExtractFilePath(Application.ExeName)+'html\';
 
  ///html dosyalarını bul
  GetHTMLFileList;
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FileList.Free;
end;
 
procedure TForm1.GetHTMLFileList;
var
  myDir: TSearchRec;
  c : Integer;
begin
   /// eğer dosya uzantıları .html ise burayı değiştir
  c := FindFirst(edDIR.Text+'*.htm', FaAnyfile, myDir); // dizindeki .htm dosyalarını
  while c = 0 do
  begin
    FileList.Add(edDIR.Text+myDir.Name); /// filelistemize ekliyoruz
    c := FindNext(myDir);
  end;
  FindClose(myDir);
end;
 
procedure TForm1.SearchAndHighlightText(aText: string);
var
tr: IHTMLTxtRange;
begin
  if not WebBrowser1.Busy then
  begin
    tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
    while tr.findText(aText, 1, 0) do
    begin
      tr.pasteHTML('<span style="background-color: Lime; font-weight: bolder;">' +
        tr.htmlText + '</span>');
      tr.scrollIntoView(True);
    end;
  end;
end;
 
procedure TForm1.btnAraClick(Sender: TObject);
var
 nFile:string;
begin
 if edSearchText.Text<>'' then
 begin
   nFile:=SearchHtml(edSearchText.Text);
   if nFile<>'' then
   begin
     lbURL.Caption:=ExtractFileName(nFile);
     WebBrowser1.Navigate('file:///'+nFile);
   end;
 end
 else
   ShowMessage('Aranacak texti giriniz!');
end;
 
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
 try
  SearchAndHighlightText(edSearchText.Text);
 except
 end;
end;
 
end.

Delphi Dünyası Facebook'ta

Duyurular

Kodbank İndir

Gönderen Konu: html içinde arama yaptırmak (Okunma sayısı 1553 defa)

muderless

html içinde arama yaptırmak