Hallo ich mal wieder!

Ich sitze zur Zeit an einem Program, das mir die Wörter einer Internetseite Filtert.

Ich habe mehrere Überprüfungen eingebaut, damit keine Leerzeichen und einzelnen Buchstaben enthalten sind.
Es trägt mir aber trotzdem einzelne Buchstaben ein.

Mein Code:

zusammenfalten · markieren

Delphi-Quellcode:

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~ Warten bis Seite da ist ~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TWortsuche.WebBrowserDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
Memo_Seitentext.Lines.Add(Webbrowser.OleObject.Document.documentElement.innerText);
ExtractLinks(Sender);
Wortertrennen(Sender);
Textzerlegen(Sender);
Sonderzeichen(Sender);
Leerestellenweg(Sender);
end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~ Links extrahieren ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TWortsuche.ExtractLinks(Sender:TObject);
var i:integer;
begin
For i:=0 to WebBrowser.OleObject.Document.Links.Length-1 do// um die Anzahl der Links zu ermitteln
begin
Application.ProcessMessages;
IF bAbbruch then break;
IF MatchesMask(WebBrowser.OleObject.Document.Links.Item(i).href,'http*://*') then// damit http protokoll benutzt wird
Listbox_Seitenlinks.Items.Add(WebBrowser.OleObject.Document.Links.Item(i).href);// in Linkliste eintragen
end;
end;


//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~ Wörter trennen ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TWortsuche.Wortertrennen(Sender: TObject);
var
  tmp: String;
  i: Integer;
begin
  tmp := Memo_Seitentext.Text;
  for i := Ord('A') to Ord('Z') do
  begin
    Application.ProcessMessages;
    IF bAbbruch then break;
    tmp := StringReplace(tmp, Chr(i), #13#10 + Chr(i), [rfReplaceAll]);
    Memo_Seitentext.Text := Trim(tmp);
  end;//for
end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~ Text zerlegen ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TWortsuche.Textzerlegen(Sender: TObject);
var sWort, sZeile:string;iLauf, iLauf2:integer;
begin
  For iLauf:=0 to Memo_Seitentext.Lines.Count-1 do
    Begin
    Application.ProcessMessages;
    IF bAbbruch then break;
    sZeile:=Memo_Seitentext.Lines[iLauf]+' ';
      For iLauf2:=1 to LENGTH(sZeile) do
      begin
        sWort:=COPY(sZeile,1,POS(' ',sZeile));
        sZeile:=COPY(sZeile,POS(' ',sZeile)+1, LENGTH(sZeile));
        IF LENGTH(sWort)>1 then
        Listbox_Seitenwoerter.Items.Add(TRIM(sWort));
      end;//for Length(sZeile)
    end; // for Memolines
end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~ Sonderzeichen löschen ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TWortsuche.SonderZeichen(Sender: TObject);
var iLauf, i:integer;
begin
  For iLauf:=0 to Listbox_Seitenwoerter.Items.Count-1 do
  begin
    FOR i:=32 to 255 do
    Begin
      Application.ProcessMessages;
      IF bAbbruch then break;
     CASE i OF
       32..64 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       91..96 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       123..195 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       197..213 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       215..219 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       221..227 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       229..245 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       247..251 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
       253..255 : Listbox_Seitenwoerter.Items[iLauf]:=StringReplace(Listbox_Seitenwoerter.Items[iLauf],chr(i),'',[rfReplaceAll]);
     End;//case
    End;//for i
  end; //For iLauf
end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~ Leere Zeilen entfernen ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
procedure TWortsuche.Leerestellenweg(Sender: TObject);
var iLauf,iEnd:integer;
begin
  iEnd:=Listbox_Seitenwoerter.Items.Count;
  iLauf:=0;
  While iLauf<=iEnd-1 do
  begin
  IF (LENGTH(TRIM(Listbox_Seitenwoerter.Items[iLauf]))<2) then Listbox_Seitenwoerter.Items.Delete(iLauf);
  iLauf:=iLauf+1;
  iEnd:=Listbox_Seitenwoerter.Items.Count;
  end;//while
end;

Ich persönlich finde keinen Fehler. Vielleicht habe ich aber auch nur einen Knick in der Optik.
Kann sich mal bitte jmd den COde anschauen und mir sagen wo mein Fehler ist?

mfg knolli

Versuche doch mal das

Listbox_Seitenwoerter.Items.Add(TRIM(sWort)); mit
Listbox_Seitenwoerter.Items.Add('>'+sWort+'<'); testweise zu ersetzen, vermutlich ist dein "getrimmtes i" in der Listbox vor dem Trimmen kein einzelner Buchstabe. Wenn das so ist, dann untersuche die vorherigen Schritte.

hm... das "getrimmte i" kommt von

iGoogle
ich trenne das i ab und schreibe es auf eine neue zeile in dem memo, wo ich den Text der Seite erst auffange.

ich habe deinen Vorschlag probiert, aber es kommt das gleiche ergebnis dabei raus.

Hallo knolli,

deine Routinen zur Wortzerlegung sind sehr ungewöhnlich. Camel-Case Wörter werden zerissen - warum?

Bei mir und vielen anderen besteht ein Text aus Wörtern, die durch bestimmte Zeichen voneinander getrennt sind:

zusammenfalten · markieren

Delphi-Quellcode:

procedure ExtractWords(const Text: string; const breakChars: TSysCharSet; s: TStrings);
var
  iFirst, iLast: Integer;
begin
  s.BeginUpdate;
  try
    iFirst := 0;
    while iFirst < Length(Text) do
    begin
      repeat
        Inc(iFirst);
      until (iFirst > Length(Text))
      or not (Text[iFirst] in breakChars);
      iLast := iFirst;
      while (iLast <= Length(Text))
      and not (Text[iLast] in breakChars) do
        Inc(iLast);
      s.Add(Copy(Text, iFirst, iLast - iFirst));
      iFirst := iLast;
    end;
  finally
    s.EndUpdate;
  end;
end;

Als BreakChars kannst du alles verwenden, was kein Buchstabe ist. Auf der Suche nach einem Palindrom interessiert dich die Groß-Kleinschreibung überhaupt nicht:

markieren

Delphi-Quellcode:

procedure TDemoForm.WebBrowserDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  with pDisp as IWebBrowser2 do
    with Document as IHTMLDocument2 do
      ExtractWords(AnsiLowerCase(body.innerText),
        [#1..#255] - ['a'..'z', 'ä', 'ö', 'ü', 'ß'],
        Memo.Lines
      );
end;

ExtractWords() arbeitet kummulativ, also löschst du die Liste besser vorher:

markieren

Delphi-Quellcode:

procedure TDemoForm.ButtonClick(Sender: TObject);
begin
  Memo.Clear;
  WebBrowser.Navigate(Edit.Text);
end;

Grüße vom marabu

Manno!
Knolli!

Zitat:

ich habe deinen Vorschlag probiert, aber es kommt das gleiche ergebnis dabei raus

Mein Beitrag #2 war doch kein Lösungsvorschlag, sondern nur eine "Krücke" um auf die Schnelle zu überprüfen, was das Trim() leistet bzw. nicht leistet! Mit dem Beitrag von marabu kommst du nun aber bestimmt weiter