delphi4arab منتديات دلفي للعرب

السلام عليكم
كيف يمكن جعل memo2 يقوم بعرض فقط الرابط ملون بلون الأخضر بداخله فصورة , بدون عرض بقية أكواد Html المتبقية من الصفحة

وهذا هو كود البحث ماذا أضيف حتى يجلب الرابط فقط بدون باقى كود الصفحة

هذا الكود سيعرض لك ما تحدده فقط صورة لينك او اي شئ من الصفحة

كود :
Title: How to get the Selected Objects in a TWebbrowser

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Webbrowser1.OleObject.Document.Selection.type = 'Control' then
  begin
    if Webbrowser1.OleObject.Document.Selection.CreateRange.CommonParentElement.tagName =
      'IMAGE' then
      ShowMessage('An Image is selected');
  end
  else
  begin
    if Webbrowser1.OleObject.Document.Selection.createRange.Text = '' then
      ShowMessage('Nothing is selected - ');
  end;
end;

هذا سوف يعطيك كل الروابط التي بالصفحة

كود :
Title: How to list all links of a page of a TWebbrowser

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do
    Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i));
end;


{*****************}

{ if there are frames }

procedure TForm1.Button2Click(Sender: TObject);
var
  u : variant;
  v : IDispatch;
  s : string;

  procedure RecurseLinks(htmlDoc: variant);
  var
    BodyElement : variant;
    ElementCo: variant;
    HTMLFrames: variant;
    HTMLWnd : variant;
    j, i : integer;
  begin
    if VarIsEmpty(htmlDoc) then
      exit;
    BodyElement := htmlDoc.body;
    if BodyElement.tagName = 'BODY' then
    begin
      ElementCo := htmlDoc.links;
      j := ElementCo.Length - 1;
      for i := 0 to j do
      begin
        u := ElementCo.item(i);
        s := u.href;
        listLinks.Items.Add(s);
      end;
    end;
    HTMLFrames := htmlDoc.Frames;
    j := HTMLFrames.length - 1;
    for i := 0 to j do
    begin
      HTMLWnd := HTMLFrames.Item(i);
      RecurseLinks(HTMLWnd.Document);
    end;
  end; // RecurseLinks
begin
  v := WebBrowser1.document;
  listLinks.Clear;
  RecurseLinks(v);
end;

هذا سيعطيك النص الذي تضلله

كود :
Title: How to find and highlight text in TWebBrowser

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;
Usage Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  SearchAndHighlightText('delphi');
end;

جرب هذا يعطيك ايضا الروابط

كود :
Title: get all Frame URLs in TWebbrowser?

procedure TForm1.Button2Click(Sender: TObject);
var
  i: Integer;
begin
  Listbox1.Clear;
  //if frames available
  if Webbrowser1.OleObject.Document.Frames.Length  0 then
  begin
    //walk through all frames and get the url
    //to the Listbox
    for i := 0 to Webbrowser1.OleObject.Document.Frames.Length - 1 do
    begin
      Listbox1.Items.Add(Webbrowser1.OleObject.Document.Frames.item(i).Document.URL);
    end;
  end;
end;

مشكور أخى على المساعدة والأكود المفيدة , ولكن انا قمت بكتابة كود البحث داخل memo لكى يستخرج الرابط فلبرنامج يقوم بتحويل موقع الأنسغرام إلى صفحة html داخل memo 1 ويقوم بفلترة و يستخراج رابط الصورة فى momo2 , الكود يعمل جيدا ولكن انا أريد فقط ان يتوقف عند كلمة .jpg , بدون إظهار باقى أكواد صفحة html , الموجودة داخل memo 2 وهذا هو الكود كامل حتى تتضح الصورة الموجودة فى السؤال الأول

كود :
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleCtrls, SHDocVw, MSHTML, ActiveX;

type
  TForm1 = class(TForm)
    
    WebBrowser1: TWebBrowser;
    source: TMemo;
    dest: TMemo;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure WebBrowser1DocumentComplete(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    
    
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
function Extracteur(Source,c1,c2:string):string;
begin

    Source := Copy(Source, Pos(c1, Source)+length(c1), length(Source));

   result:=Source;
end;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
 var
  Document: IHtmlDocument2;
begin
  edit1.text:=url;
  document := webbrowser1.document as IHtmlDocument2;

  source.lines.add(trim(document.body.innerHTML));

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate('https://www.instagram.com/cristiano/');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin


  dest.Text:= Extracteur(source.Text, 'img class="_iv4d5" src="','"');

end;



procedure TForm1.Button3Click(Sender: TObject);
begin
WebBrowser1.Navigate(dest.Lines.GetText);
end;

(13-04-2017, 12:55 AM)Delphi4Us كتب : [ -> ]هذا الكود سيعرض لك ما تحدده فقط صورة لينك او اي شئ من الصفحة

كود :
Title: How to get the Selected Objects in a TWebbrowser procedure TForm1.Button1Click(Sender: TObject); begin if Webbrowser1.OleObject.Document.Selection.type = 'Control' then begin if Webbrowser1.OleObject.Document.Selection.CreateRange.CommonParentElement.tagName = 'IMAGE' then ShowMessage('An Image is selected'); end else begin if Webbrowser1.OleObject.Document.Selection.createRange.Text = '' then ShowMessage('Nothing is selected - '); end; end;
هذا سوف يعطيك كل الروابط التي بالصفحة

كود :
Title: How to list all links of a page of a TWebbrowser procedure TForm1.Button1Click(Sender: TObject); var i: Integer; begin for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i)); end; {*****************} { if there are frames } procedure TForm1.Button2Click(Sender: TObject); var u : variant; v : IDispatch; s : string; procedure RecurseLinks(htmlDoc: variant); var BodyElement : variant; ElementCo: variant; HTMLFrames: variant; HTMLWnd : variant; j, i : integer; begin if VarIsEmpty(htmlDoc) then exit; BodyElement := htmlDoc.body; if BodyElement.tagName = 'BODY' then begin ElementCo := htmlDoc.links; j := ElementCo.Length - 1; for i := 0 to j do begin u := ElementCo.item(i); s := u.href; listLinks.Items.Add(s); end; end; HTMLFrames := htmlDoc.Frames; j := HTMLFrames.length - 1; for i := 0 to j do begin HTMLWnd := HTMLFrames.Item(i); RecurseLinks(HTMLWnd.Document); end; end; // RecurseLinks begin v := WebBrowser1.document; listLinks.Clear; RecurseLinks(v); end;
هذا سيعطيك النص الذي تضلله

كود :
Title: How to find and highlight text in TWebBrowser 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; Usage Example: procedure TForm1.Button1Click(Sender: TObject); begin SearchAndHighlightText('delphi'); end;
جرب هذا يعطيك ايضا الروابط

كود :
Title: get all Frame URLs in TWebbrowser? procedure TForm1.Button2Click(Sender: TObject); var i: Integer; begin Listbox1.Clear; //if frames available if Webbrowser1.OleObject.Document.Frames.Length 0 then begin //walk through all frames and get the url //to the Listbox for i := 0 to Webbrowser1.OleObject.Document.Frames.Length - 1 do begin Listbox1.Items.Add(Webbrowser1.OleObject.Document.Frames.item(i).Document.URL); end; end; end;

مشكور أخى على المساعدة والأكود المفيدة , ولكن انا قمت بكتابة كود البحث داخل memo لكى يستخرج الرابط فلبرنامج يقوم بتحويل موقع الأنسغرام إلى صفحة html داخل memo 1 ويقوم بفلترة و يستخراج رابط الصورة فى momo2 , الكود يعمل جيدا ولكن انا أريد فقط ان يتوقف عند كلمة .jpg , بدون إظهار باقى أكواد صفحة html , الموجودة داخل memo 2 وهذا هو الكود كامل حتى تتضح الصورة الموجودة فى السؤال الأول

كود :
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleCtrls, SHDocVw, MSHTML, ActiveX;

type
  TForm1 = class(TForm)
    
    WebBrowser1: TWebBrowser;
    source: TMemo;
    dest: TMemo;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure WebBrowser1DocumentComplete(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    
    
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
function Extracteur(Source,c1,c2:string):string;
begin

    Source := Copy(Source, Pos(c1, Source)+length(c1), length(Source));

   result:=Source;
end;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
 var
  Document: IHtmlDocument2;
begin
  edit1.text:=url;
  document := webbrowser1.document as IHtmlDocument2;

  source.lines.add(trim(document.body.innerHTML));

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate('https://www.instagram.com/cristiano/');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin


  dest.Text:= Extracteur(source.Text, 'img class="_iv4d5" src="','"');

end;



procedure TForm1.Button3Click(Sender: TObject);
begin
WebBrowser1.Navigate(dest.Lines.GetText);
end;

هل افهم من كلامك ان هناك صورة واحدة فقط باللاحقة JPG ام ان هناك اكثر من صور في الصفحة
وبحال كان هناك اكثر من صورة
هل تريد ان تظهر روابطهم كلهم ام تريد اظهار رابط صورة واحدة معينة فقط

(13-04-2017, 08:58 PM)Delphi4Us كتب : [ -> ]هل افهم من كلامك ان هناك صورة واحدة فقط باللاحقة JPG ام ان هناك اكثر من صور في الصفحة
وبحال كان هناك اكثر من صورة
هل تريد ان تظهر روابطهم كلهم ام تريد اظهار رابط صورة واحدة معينة فقط

نعم اخى أنا أريد إستخرج صورة واحد فقط فى memo2 وهى صورة بروفايل الأنستغرام وهذا هو كود الصورة فى داخل memo1

كود :
<img class="_iv4d5" src="https://ig-s-d-a.akamaihd.net/hphotos-ak-xfa1/t51.2885-19/s150x150/17818385_679572845578447_7005629359616688128_a.jpg">

وعند إستخراجها يوم البرنامج بفتحها فى البراوزر حتى تضهر كاملة 
فمثلا الرابط المستخرج يكون هكذا
https://ig-s-d-a.akamaihd.net/hphotos-ak-xfa1/t51.2885-19/s150x150/17818385_679572845578447_7005629359616688128_a.jpg
وعند حذف s150x150/ سوف تضهر كامل الصورة بمقاسها الحقيقى

مع انك تستطيع جلب ما تريد مباشرة من الاداة TWEB ولكن على العموم
انت بحاجة الى البحث عن كلمات اساسية متواجدة دائما
وعندك الكلمة الاولى هي HTTP ونهاية الكلمة هي .JPG
اذا تبحث عن الكلمة الاولى وتعرف موقعها وكذلك مع الثانية
تم تقوم بنسخ الجملة التي تقع بين العددين
لا اعرف لضيق الوقت اجريت اختبار سريع لمثال يبدوا انه نفسه الذي معك وعدلت فيه قليلا

حاول ان تجربه اكثر من مرة
[صورة: 0dde133f6e1b616.jpg]

كود :
var
  i,k1,k2: Integer;
  a: string;
begin
  edt2.Text:='https';

  mmo1.Lines.Add('');
  mmo1.Lines.Text := ' ' + mmo1.Lines.Text;
  for i := 0 to Length(mmo1.Lines.Text) - Length(edt2.Text) do
  begin
    a := Copy(mmo1.Lines.Text, i, Length(edt2.Text));
    if chk1.Checked = True then
    begin
      if a = edt2.Text then
      begin
        find := True;
        x    := 2;
        mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1);
        mmo1.SetFocus;
        mmo1.SelStart  := i - 2;
        mmo1.SelLength := Length(edt2.Text);
        break;
      end;
    end
    else
    begin
      if lowercase(a) = lowercase(edt2.Text) then
      begin
        mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1);
        find := True;
        x    := 2;
        mmo1.SetFocus;
        mmo1.SelStart  := i - 2;
        mmo1.SelLength := Length(edt2.Text);
        break;
      end;
    end;
  end;

  k1:=i;
  edt2.Text:='.jpg';
  i:=0;

  mmo1.Lines.Add('');
  mmo1.Lines.Text := ' ' + mmo1.Lines.Text;
  for i := 0 to Length(mmo1.Lines.Text) - Length(edt2.Text) do
  begin
    a := Copy(mmo1.Lines.Text, i, Length(edt2.Text));
    if chk1.Checked = True then
    begin
      if a = edt2.Text then
      begin
        find := True;
        x    := 2;
        mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1);
        mmo1.SetFocus;
        mmo1.SelStart  := i - 2;
        mmo1.SelLength := Length(edt2.Text);
        break;
      end;
    end
    else
    begin
      if lowercase(a) = lowercase(edt2.Text) then
      begin
        mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1);
        find := True;
        x    := 2;
        mmo1.SetFocus;
        mmo1.SelStart  := i - 2;
        mmo1.SelLength := Length(edt2.Text);
        break;
      end;
    end;
  end;



  k2:=i;

  mmo1.SelStart  := k1-2 ;
  mmo1.SelLength := k2-k1+Length(edt2.Text)  ;
 // ShowMessage('');

   mmo1.SetFocus;
 // mmo1.SelStart  := i - 2;


end;

(13-04-2017, 11:51 PM)Delphi4Us كتب : [ -> ]مع انك تستطيع جلب ما تريد مباشرة من الاداة TWEB ولكن على العموم
انت بحاجة الى البحث عن كلمات اساسية متواجدة دائما
وعندك الكلمة الاولى هي HTTP ونهاية الكلمة هي .JPG
اذا تبحث عن الكلمة الاولى وتعرف موقعها وكذلك مع الثانية
تم تقوم بنسخ الجملة التي تقع بين العددين
لا اعرف لضيق الوقت اجريت اختبار سريع لمثال يبدوا انه نفسه الذي معك وعدلت فيه قليلا

حاول ان تجربه اكثر من مرة

كود :
var i,k1,k2: Integer; a: string; begin edt2.Text:='https'; mmo1.Lines.Add(''); mmo1.Lines.Text := ' ' + mmo1.Lines.Text; for i := 0 to Length(mmo1.Lines.Text) - Length(edt2.Text) do begin a := Copy(mmo1.Lines.Text, i, Length(edt2.Text)); if chk1.Checked = True then begin if a = edt2.Text then begin find := True; x := 2; mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1); mmo1.SetFocus; mmo1.SelStart := i - 2; mmo1.SelLength := Length(edt2.Text); break; end; end else begin if lowercase(a) = lowercase(edt2.Text) then begin mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1); find := True; x := 2; mmo1.SetFocus; mmo1.SelStart := i - 2; mmo1.SelLength := Length(edt2.Text); break; end; end; end; k1:=i; edt2.Text:='.jpg'; i:=0; mmo1.Lines.Add(''); mmo1.Lines.Text := ' ' + mmo1.Lines.Text; for i := 0 to Length(mmo1.Lines.Text) - Length(edt2.Text) do begin a := Copy(mmo1.Lines.Text, i, Length(edt2.Text)); if chk1.Checked = True then begin if a = edt2.Text then begin find := True; x := 2; mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1); mmo1.SetFocus; mmo1.SelStart := i - 2; mmo1.SelLength := Length(edt2.Text); break; end; end else begin if lowercase(a) = lowercase(edt2.Text) then begin mmo1.Lines.Text := Copy(mmo1.Lines.Text, 2, Length(mmo1.Lines.Text) - 1); find := True; x := 2; mmo1.SetFocus; mmo1.SelStart := i - 2; mmo1.SelLength := Length(edt2.Text); break; end; end; end; k2:=i; mmo1.SelStart := k1-2 ; mmo1.SelLength := k2-k1+Length(edt2.Text) ; // ShowMessage(''); mmo1.SetFocus; // mmo1.SelStart := i - 2; end;

شكرا أخى على الكود والمساعدة , سأقوم بتجربة والبحث فى منتديات أخرى مشكور Smile

marinzo

Delphi4Us

marinzo

Delphi4Us

marinzo

Delphi4Us

marinzo