Parse edip ListBoxa eklemek

[doktoraltun]

s.a. kusura bakmayın basit bir soru olacak ama bi turlu uyarluyamadım

Kod: Tümünü seç

<h1>deneme1</h1>
<h1>deneme2</h1>
<h1>deneme3</h1>
<h1>deneme4</h1>
<h1>deneme5</h1>
<h1>deneme6</h1>
<h1>deneme7</h1>
<h1>deneme8</h1>
<h1>deneme9</h1>

şeklinde html kodu parse ediyorum ama listboxa eklemeye gelince ise ilk satır tek ekleniyor geri kalan 8 satır eklenmiyor yardımcı ufak bir kod verebilirmisiniz teşekurler.

[greenegitim]

nasıl bir kod kullandınız?

[doktoraltun]

hocam parsellemeyi

Kod: Tümünü seç

var
cumle1,cumle2,ilkmetin,sonmetin:string;
begin
ilkmetin:=WebBrowser1.OleObject.Document.Body.InnerHTML;
cumle1:='<h>';
cumle2:='</h>';
sonmetin:=copy(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
end;

şeklinde yaptım
listeleyince ilk satır tek ekleniyor.

[greenegitim]

breakpoint koyup baktığınızda sonmetin değişkeninin null değer döndürdüğünü göreceksiniz web sitesinde göründüğü gibi satır satır çekmeyip hepsini tek satırda çekiyor yazdığın kod
amaç taglar arasındaki yazıyı almak ise daha önce kullandığım bir function

Kod: Tümünü seç

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; 

kullanımı
procedure TForm1.btn_memmoyatClick(Sender: TObject);
begin
WB_GetHTMLCode(Webbrowser1, Memo1.Lines);
end;

[doktoraltun]

hocam vermiş oldugunuz kod sadece site içerigini çekiyor. her satırı bir link olacak şekilde listboxa veya memoya sıralamak istiyordum. neyse sizi yordum teşekur ediyorum.

[emin_as]

Kodunda mantık hatası var, pos ilk aradıgını bulunca durur, bu nedenle her seferinde ilk elemanı getirecektir.

Kod: Tümünü seç

ilkmetin:=WebBrowser1.OleObject.Document.Body.InnerHTML;
cumle1:='<h>';
cumle2:='</h>';
// döngü ile kaç tane varsa aktaracagız
while pos(cumle1,ilkmetin) > 0 do
begin
  sonmetin:=copy(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
  listbox1.Items.Add(sonmetin);
  // bu satırla aktardıgımız bölümü siliyoruz
  delete(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
end;

[SimaWB]

Aşağıdaki kodla web sayfasında bulunan tüm h1 tag'larının içeriğini ListBox'a atabilirsiniz. Belki işinize yarayabilir:

Kod: Tümünü seç

var Elements: IHTMLElementCollection;
    Element : IHTMLElement;
    i : Integer;
begin
  Elements := Doc.all.tags('h1') as IHTMLElementCollection;
  i := Elements.length;
  while i > 0 do
  begin
    Dec(i);
    Element := Elements.item(i, '') as IHTMLElement;
    Lisbox1.Lines.Add(Element.innerText);
  end;
end;

[doktoraltun]

Kodunda mantık hatası var, pos ilk aradıgını bulunca durur, bu nedenle her seferinde ilk elemanı getirecektir.

Kod: Tümünü seç

ilkmetin:=WebBrowser1.OleObject.Document.Body.InnerHTML;
cumle1:='<h>';
cumle2:='</h>';
// döngü ile kaç tane varsa aktaracagız
while pos(cumle1,ilkmetin) > 0 do
begin
  sonmetin:=copy(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
  listbox1.Items.Add(sonmetin);
  // bu satırla aktardıgımız bölümü siliyoruz
  delete(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
end;

hocam dediğiniz şeyi yaptım ama listboxa boş satırlar doluyor ve sonunda tıkanıp kalıyor kapat hatası veriyor

kodlarınızıda şöyle uyarladım

Kod: Tümünü seç

procedure TForm1.Button2Click(Sender: TObject);
var

cumle1,cumle2,ilkmetin,sonmetin:string;
begin

ilkmetin:=WebBrowser1.OleObject.Document.Body.InnerHTML;
cumle1:='<A class=Member';
cumle2:='<SPAN>&nbsp;</SPAN>';
// döngü ile kaç tane varsa aktaracagız
while pos(cumle1,ilkmetin) > 0 do
begin
  sonmetin:=copy(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
  listbox1.Items.Add(sonmetin);
  delete(ilkmetin,pos(cumle1,ilkmetin)+1,pos(cumle2,ilkmetin)-pos(cumle1,ilkmetin)-1);
  // bu satırla aktardıgımız bölümü siliyoruz

end;
end;

[doktoraltun]

şöyle birşeyle başardım ama bu seferde memo daki satırların uzunluğu ne kadar kısa olursa taglar arasındaki bilgi satır başı yaptıgından eksik bilgi ekleniyor

buldugum kod ise şu

Kod: Tümünü seç

i:integer;
tmpstr,s,s1 : String;
begin
ListBox1.Items.Clear;
for i := 0 to memo1.Lines.Count - 1 do
begin
tmpstr := Memo1.Lines[i];

s := aradansec(Memo1.Lines[i],'<NOBR>','</NOBR>');

s := s;
if Length(s) > 1 then
ListBox1.Items.Add(trim(s));
end;
end;

[doktoraltun]

şükür çözdüm belki ben gibi acemi biri için lazım olur.

html verisini xml dosyasına çevirdim

Kod: Tümünü seç

procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
  const pDisp: IDispatch; const URL: OleVariant);
  var
  p1,p2:integer;
  m1,m2,a1,a2:string;
  begin

memo1.clear;
memo1.text:=WebBrowser1.OleObject.Document.Body.InnerHTML;
m1:=memo1.Text;
p1:=pos('<TH>Tarih</TH></TR></THEAD>',m1);
p2:=pos('</SPAN></TD></TR></TBODY>',m1);
memo1.clear;
memo1.text:=copy(m1,p1,p2-p1+17);
m2:=memo1.text;
m2:=StringReplace(m2,'<TH>Tarih</TH>','', [rfReplaceAll]);
m2:=StringReplace(m2,'</TR></THEAD>','', [rfReplaceAll]);
m2:=StringReplace(m2,'<TBODY>','', [rfReplaceAll]);
m2:=StringReplace(m2,'<TD><INPUT onpropertychange=checkedChange(); name=msgs value=','<MESAJNO>', [rfReplaceAll]);
m2:=StringReplace(m2,'type=checkbox></TD>','</MESAJNO>', [rfReplaceAll]);
m2:=StringReplace(m2,'<TD><A href="/profile.aspx?id=','<PROFILID>', [rfReplaceAll]);
m2:=StringReplace(m2,'"><IMG','</PROFILID>', [rfReplaceAll]);
m2:=StringReplace(m2,'class=NoPrint','', [rfReplaceAll]);
m2:=StringReplace(m2,'align=absMiddle','', [rfReplaceAll]);
m2:=StringReplace(m2,'src="','<FOTO>', [rfReplaceAll]);
m2:=StringReplace(m2,'">&','</FOTO>', [rfReplaceAll]);
m2:=StringReplace(m2,'<TR class=Row0_64>','<ITEM><MSJ>Yeni Mesaj</MSJ>', [rfReplaceAll]);
m2:=StringReplace(m2,'<TR class=Row1_64>','<ITEM><MSJ>Yeni Mesaj</MSJ>', [rfReplaceAll]);
m2:=StringReplace(m2,'<TR class=Row0_0>','<ITEM><MSJ>Eski Mesaj</MSJ>', [rfReplaceAll]);
m2:=StringReplace(m2,'<TR class=Row1_0>','<ITEM><MSJ>Eski Mesaj</MSJ>', [rfReplaceAll]);
m2:=StringReplace(m2,'nbsp;','<KIMDEN>', [rfReplaceAll]);
m2:=StringReplace(m2,'<TD><A href=','', [rfReplaceAll]);
m2:=StringReplace(m2,'<TD><SPAN class=Date>','</KIMDEN><TARIH>', [rfReplaceAll]);
m2:=StringReplace(m2,'</SPAN></TD></TR>','</TARIH></ITEM>', [rfReplaceAll]);
m2:=StringReplace(m2,'"/messagein.aspx?id=',' No : ', [rfReplaceAll]);
m2:=StringReplace(m2,'">',' / Konusu : ', [rfReplaceAll]);
m2:=StringReplace(m2,'</A></TD>','', [rfReplaceAll]);
MEMO2.Clear;
a1:='<?xml version="1.0" encoding="ISO-8859-9"?><rss version="2.0"><channel>';
a2:='</channel></rss>';
memo2.Text:=a1+m2+a2;
memo2.lines.SaveToFile(ExtractFilePath(Application.EXEName) + 'mesaj.xml');
end;

Sonrada xml dosyasını listboxa dizdim veri kabı olmadı. Sadece memo1 dosyasının boyutunu küçük tutarsanız işlemler geç oluyor.

Kod: Tümünü seç

procedure TForm1.Button4Click(Sender: TObject);
var
i,e1:integer;
begin
  listbox1.Clear;
  if kontrol=0 then
   begin
      XMLDocument1.Active:=false;
      XMLDocument1.FileName:=ExtractFilePath(Application.EXEName) +'mesaj.xml';
      XMLDocument1.Active:=true;
   end;
   i:=1;
   baslangic:=XMLDocument1.DocumentElement.ChildNodes.First.ChildNodes.FindNode('ITEM');
   repeat
      msj:=baslangic.ChildNodes.Nodes['MSJ'].Text;
      kimden:=baslangic.ChildNodes.Nodes['KIMDEN'].Text;
      tarih:=baslangic.ChildNodes.Nodes['TARIH'].Text;
      i:=i+1;
      ListBox1.Items.Add(msj+'---'+kimden+'---'+tarih);
    baslangic:=baslangic.NextSibling;
     Until baslangic=nil;
   end;