Исходники.Ру - Программирование
Исходники
Статьи
Книги и учебники
Скрипты
Новости RSS
Магазин программиста

Главная » Статьи по программированию » Delphi - Все статьи »

Обсудить на форуме Обсудить на форуме

Функции для парсинга строк

Здесь представлен модуль, в котором я разместил много методов для обработки строк.

Некоторые функции поименованы по-шведски, но, может-быть, Вы сможете понять, что они делают.

Вам потребуется один из методов, называющийся stringreplaceall, который принимает при параметра - исходную строку, подстроку для поиска и подстроку для замены, и возвращает измененную строку. Будьте осторожны, если Вы меняется одну подстроку на другую, чьей частью является первая. Вы должны делать это в два прохода, или Вы попадете в бесконечный цикл.

Так, если Вы имеете текст, содержащий слово Joe, и Вы хотите все его вхождения изменить на Joey, то Вы должны сделать сперва нечто похожее на:

text := stringreplaceall (text,'Joe','Joeey');

И потом

text := stringreplaceall (text,'Joeey','Joey'); 

===
unit sparfunc;

interface

uses sysutils,classes;

function antaltecken (orgtext,soktext : string) : integer;
function beginsWith (text,teststreng : string):boolean;
function endsWith (text,teststreng : string):boolean;
function hamtastreng (text,strt,slut : string):string;
function hamtastrengmellan (text,strt,slut : string):string;
function nastadelare (progtext : string):integer;
function rtf2sgml (text : string) : string;
Function sgml2win(text : String) : String;
Function sgml2mac(text : String) : String;
Function sgml2rtf(text : string) : String;
function sistamening(text : string) : string;
function stringnthfield (text,delim : string; vilken : integer) : string;
function stringreplace (text,byt,mot : string) : string;
function stringreplaceall (text,byt,mot : string) : string;
function text2sgml (text : string) : string;
procedure SurePath (pathen : string);
procedure KopieraFil (infil,utfil : string);
function LasInEnTextfil (filnamn : string) : string;


implementation

function LasInEnTextfil (filnamn : string) : string;
var
  infil : textfile;
  temptext, filtext : string;
begin
  filtext := '';
  //Oppna angiven fil och las in den
  try
    assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname
    reset (infil);             //Oppna filen
    while not eof(infil) do begin    //Sa lange vi inte natt slutet
      readln (infil,temptext); //Las in en rad
      filtext := filtext+temptext; //Lagg den till variabeln SGMLTEXT
    end; // while
  finally  //slutligen
    closefile (infil); //Stang filen
  end; //try
  result := filtext;
end;

procedure KopieraFil (infil,utfil : string);
var
  InStream : TFileStream;
  OutStream : TFileStream;
begin
  InStream := TFileStream.Create(infil,fmOpenRead);
  try
    OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate);
    try
      OutStream.CopyFrom(InStream,0);
    finally
      OutStream.Free;
    end;
  finally
    InStream.Free;
  end;
end;

procedure SurePath (pathen : string);
var
  temprad,del1 : string;
  antal : integer;
begin
  antal := antaltecken (pathen,'\');
  if antal<3 then
    createdir(pathen)
  else  begin
    if pathen[length(pathen)] <> '\' then pathen := pathen+'\';
    pathen := stringreplace(pathen,'\','/');
    del1 := copy(pathen,1,pos('\',pathen));
    pathen := stringreplace(pathen,del1,'');
    del1 := stringreplace(del1,'/','\');
    createdir (del1);
    while pathen <> '' do begin
      temprad := copy(pathen,1,pos('\',pathen));
      pathen := stringreplace(pathen,temprad,'');
      del1 := del1+ temprad;
      temprad := '';
      createdir(del1);
    end;
  end;
end;

function antaltecken (orgtext,soktext : string) : integer;
var
  i,traffar,soklengd : integer;
begin
  traffar := 0;
  soklengd := length(soktext);
  for i := 1 to length(orgtext) do
    begin
      if soktext = copy(orgtext,i,soklengd) then
        traffar := traffar +1;
    end;
  result := traffar;
end;

function nastadelare (progtext : string):integer;
var
  i,j : integer;
begin
  i := pos('.',progtext);
  j := pos('!',progtext);
  if (j<i) and (j>0) then i := j;
  j := pos('!',progtext);
  if (j<i) and (j>0) then i := j;
  j := pos('?',progtext);
  if (j<i) and (j>0) then i := j;
  result := i;
end;

function stringnthfield (text,delim : string; vilken : integer) : string;
var
  start,slut,i : integer;
  temptext : string;
begin
start := 0;
if vilken >0 then
  begin
    temptext := text;
    if vilken = 1 then
      begin
        start := 1;
        slut := pos (delim,text);
      end
    else
      begin
        for i:= 1 to vilken -1 do
          begin
            start := pos(delim,temptext)+length(delim);
            temptext := copy(temptext,start,length(temptext));
          end;
        slut := pos (delim,temptext);
      end;
    if start >0 then
      begin
         if slut = 0 then slut := length(text);
         result := copy (temptext,1,slut-1);
      end
    else
      result := text;
  end
else
  result := text;
end;

function StringReplaceAll (text,byt,mot : string ) :string;
{Funktion for att byta ut alla forekomster av en strang mot en
annan strang in en strang. Den konverterade strangen returneras.
Om byt finns i mot maste vi ga via en temporar variant!!!}
var
   plats : integer;
begin
While pos(byt,text) > 0 do
      begin
      plats := pos(byt,text);
      delete (text,plats,length(byt));
      insert (mot,text,plats);
      end;
result := text;
end;

function StringReplace (text,byt,mot : string ) :string;
{Funktion for att byta ut den forsta forekomsten av en strang mot en
annan strang in en strang. Den konverterade strangen returneras.}
var
   plats : integer;
begin
if pos(byt,text) > 0 then
      begin
      plats := pos(byt,text);
      delete (text,plats,length(byt));
      insert (mot,text,plats);
      end;
result := text;
end;

function hamtastreng (text,strt,slut : string):string;
{Funktion for att hamta ut en delstrang ur en annan strang.
Om start och slut finns i text sa returneras en strang dar start
ingar i borjan och fram till tecknet fore slut.}
var
   stplats,slutplats : integer;
   resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
   begin
   text := copy (text,stplats,length(text));
   slutplats := pos(slut,text);
   if slutplats >0 then
     begin
       resultat := copy(text,1,slutplats-1);
     end;
end;
result := resultat;
end;

function hamtastrengmellan (text,strt,slut : string):string;
{Funktion for att hamta ut en delstrang ur en annan strang.
Om start och slut finns i text sa returneras en strang dar start
ingar i borjan och fram till tecknet fore slut.}
var
   stplats,slutplats : integer;
   resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
   begin
   text := copy (text,stplats+length(strt),length(text));
   slutplats := pos(slut,text);
   if slutplats >0 then
     begin
       resultat := copy(text,1,slutplats-1);
     end;
end;
result := resultat;
end;

function endsWith (text,teststreng : string):boolean;
{Kollar om en strang slutar med en annan strang.
Returnerar true eller false.}
var
   textlngd,testlngd : integer;
   kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd > testlngd then
  begin
    kollstreng := copy (text,(textlngd+1)-testlngd,testlngd);
    if kollstreng = teststreng then
      result := true
    else
      result := false;
  end
else
  result := false;
end;

function beginsWith (text,teststreng : string):boolean;
{Funktion for att kolla om text borjar med teststreng.
Returnerar true eller false.}
var
   textlngd,testlngd : integer;
   kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd >= testlngd then
  begin
    kollstreng := copy (text,1,testlngd);
    if kollstreng = teststreng then
      result := true
    else
      result := false;
  end
else
  result := false;
end;

function sistamening(text : string) : string;
//Funktion for att ta fram sista meningen i en strang. Soker pa !?.
var
  i:integer;
begin
  i :=length(text)-1;
  while (copy(text,i,1)<> '.') and (copy(text,i,1)<> '!') and 
        (copy(text,i,1)<> '?') do
    begin
      dec(i);
      if i =1 then break

    end;
  if i>1 then
    result := copy(text,i,length(text))
  else
    result := '';
end;

Function text2sgml(text : String) : String;
{Funktion som byter ut alla ovanliga tecken mot entiteter.
Den fardiga texten returneras.}
begin
  text := stringreplaceall (text,'&','##amp;');
  text := stringreplaceall (text,'##amp','&amp');
  text := stringreplaceall (text,'a','&aring;');
  text := stringreplaceall (text,'A','&Aring;');
  text := stringreplaceall (text,'a','&auml;');
  text := stringreplaceall (text,'A','&Auml;');
  text := stringreplaceall (text,'a','&aacute;');
  text := stringreplaceall (text,'A','&Aacute;');
  text := stringreplaceall (text,'a','&agrave;');
  text := stringreplaceall (text,'A','&Agrave;');
  text := stringreplaceall (text,'?','&aelig;');
  text := stringreplaceall (text,'?','&Aelig;');
  text := stringreplaceall (text,'A','&Acirc;');
  text := stringreplaceall (text,'a','&acirc;');
  text := stringreplaceall (text,'a','&atilde;');
  text := stringreplaceall (text,'A','&Atilde;');
  text := stringreplaceall (text,'c','&ccedil;');
  text := stringreplaceall (text,'C','&Ccedil;');
  text := stringreplaceall (text,'e','&eacute;');
  text := stringreplaceall (text,'E','&Eacute;');
  text := stringreplaceall (text,'e','&ecirc;');
  text := stringreplaceall (text,'E','&Ecirc;');
  text := stringreplaceall (text,'e','&euml;');
  text := stringreplaceall (text,'E','&Euml;');
  text := stringreplaceall (text,'e','&egrave;');
  text := stringreplaceall (text,'E','&Egrave;');
  text := stringreplaceall (text,'i','&icirc;');
  text := stringreplaceall (text,'I','&Icirc;');
  text := stringreplaceall (text,'i','&iacute;');
  text := stringreplaceall (text,'I','&Iacute;');
  text := stringreplaceall (text,'i','&igrave;');
  text := stringreplaceall (text,'I','&Igrave;');
  text := stringreplaceall (text,'i','&iuml;');
  text := stringreplaceall (text,'I','&Iuml;');
  text := stringreplaceall (text,'n','&ntilde;');
  text := stringreplaceall (text,'N','&Ntilde;');
  text := stringreplaceall (text,'o','&ouml;');
  text := stringreplaceall (text,'O','&Ouml;');
  text := stringreplaceall (text,'o','&ograve;');
  text := stringreplaceall (text,'O','&Ograve;');
  text := stringreplaceall (text,'o','&oacute;');
  text := stringreplaceall (text,'O','&Oacute;');
  text := stringreplaceall (text,'o','&oslash;');
  text := stringreplaceall (text,'O','&Oslash;');
  text := stringreplaceall (text,'O','&Ocirc;');
  text := stringreplaceall (text,'o','&ocirc;');
  text := stringreplaceall (text,'o','&otilde;');
  text := stringreplaceall (text,'O','&Otilde;');
  text := stringreplaceall (text,'u','&uuml;');
  text := stringreplaceall (text,'U','&Uuml;');
  text := stringreplaceall (text,'u','&uacute;');
  text := stringreplaceall (text,'U','&Uacute;');
  text := stringreplaceall (text,'U','&Ugrave;');
  text := stringreplaceall (text,'u','&ugrave;');
  text := stringreplaceall (text,'u','&ucirc;');
  text := stringreplaceall (text,'U','&Ucirc;');
  text := stringreplaceall (text,'y','&yacute;');
  text := stringreplaceall (text,'Y','&Yacute;');
  text := stringreplaceall (text,'y','&yuml;');
  text := stringreplaceall (text,'|','&nbsp;');
  result := text;
End;

Function sgml2win(text : String) : String;
{Funktion som ersatter alla entiteter mot deras tecken i
windows. Den fardiga strangen returneras.}
begin
text := stringreplaceall (text,'&aacute;','a');
text := stringreplaceall (text,'&Aacute;','A');
text := stringreplaceall (text,'&aelig;','?');
text := stringreplaceall (text,'&Aelig;','?');
text := stringreplaceall (text,'&agrave;','a');
text := stringreplaceall (text,'&Agrave;','A');
text := stringreplaceall (text,'&aring;','a');
text := stringreplaceall (text,'&Aring;','A');
text := stringreplaceall (text,'&auml;','a');
text := stringreplaceall (text,'&Auml;','A');
text := stringreplaceall (text,'&Acirc;' ,'A');
text := stringreplaceall (text,'&acirc;' ,'a');
text := stringreplaceall (text,'&atilde;','a');
text := stringreplaceall (text,'&Atilde;','A');
text := stringreplaceall (text,'&ccedil;','c');
text := stringreplaceall (text,'&Ccedil;','C');
text := stringreplaceall (text,'&eacute;','e');
text := stringreplaceall (text,'&Eacute;','E');
text := stringreplaceall (text,'&egrave;','e');
text := stringreplaceall (text,'&Egrave;','E');
text := stringreplaceall (text,'&ecirc;' ,'e');
text := stringreplaceall (text,'&Ecirc;' ,'E');
text := stringreplaceall (text,'&euml;'  ,'e');
text := stringreplaceall (text,'&Euml;'  ,'E');
text := stringreplaceall (text,'&icirc;' ,'i');
text := stringreplaceall (text,'&Icirc;' ,'I');
text := stringreplaceall (text,'&iacute;','i');
text := stringreplaceall (text,'&Iacute;','I');
text := stringreplaceall (text,'&igrave;','i');
text := stringreplaceall (text,'&Igrave;','I');
text := stringreplaceall (text,'&iuml;'  ,'i');
text := stringreplaceall (text,'&Iuml;'  ,'I');
text := stringreplaceall (text,'&ntilde;','n');
text := stringreplaceall (text,'&Ntilde;','N');
text := stringreplaceall (text,'&ograve;','o');
text := stringreplaceall (text,'&Ograve;','O');
text := stringreplaceall (text,'&oacute;','o');
text := stringreplaceall (text,'&Oacute;','O');
text := stringreplaceall (text,'&ouml;','o');
text := stringreplaceall (text,'&Ouml;','O');
text := stringreplaceall (text,'&oslash;','o');
text := stringreplaceall (text,'&Oslash;','O');
text := stringreplaceall (text,'&Ocirc;' ,'O');
text := stringreplaceall (text,'&ocirc;' ,'o');
text := stringreplaceall (text,'&otilde;','o');
text := stringreplaceall (text,'&Otilde;','O');
text := stringreplaceall (text,'&uuml;','u');
text := stringreplaceall (text,'&Uuml;','U');
text := stringreplaceall (text,'&uacute;','u');
text := stringreplaceall (text,'&Uacute;','U');
text := stringreplaceall (text,'&ucirc;' ,'u');
text := stringreplaceall (text,'&Ucirc;' ,'U');
text := stringreplaceall (text,'&Ugrave;','U');
text := stringreplaceall (text,'&ugrave;','u');
text := stringreplaceall (text,'&yacute;','y');
text := stringreplaceall (text,'&Yacute;','Y');
text := stringreplaceall (text,'&yuml;'  ,'y');
text := stringreplaceall (text,'&nbsp;','|');
text := stringreplaceall (text,'&amp;','&');
result := text;
End;

Function sgml2mac(text : String) : String;
{Funktion som ersatter alla entiteter mot deras tecken i
mac. Den fardiga strangen returneras.}
begin
text := stringreplaceall (text,'&aacute;',chr(135));
text := stringreplaceall (text,'&Aacute;',chr(231));
text := stringreplaceall (text,'&aelig;',chr(190));
text := stringreplaceall (text,'&Aelig;',chr(174));
text := stringreplaceall (text,'&agrave;',chr(136));
text := stringreplaceall (text,'&Agrave;',chr(203));
text := stringreplaceall (text,'&aring;',chr(140));
text := stringreplaceall (text,'&Aring;',chr(129));
text := stringreplaceall (text,'&Auml;',chr(128));
text := stringreplaceall (text,'&auml;',chr(138));
text := stringreplaceall (text,'&Acirc;' ,chr(229));
text := stringreplaceall (text,'&acirc;' ,chr(137));
text := stringreplaceall (text,'&atilde;',chr(139));
text := stringreplaceall (text,'&Atilde;',chr(204));
text := stringreplaceall (text,'&ccedil;',chr(141));
text := stringreplaceall (text,'&Ccedil;',chr(130));
text := stringreplaceall (text,'&eacute;',chr(142));
text := stringreplaceall (text,'&Eacute;',chr(131));
text := stringreplaceall (text,'&egrave;',chr(143));
text := stringreplaceall (text,'&Egrave;',chr(233));
text := stringreplaceall (text,'&ecirc;' ,chr(144));
text := stringreplaceall (text,'&Ecirc;' ,chr(230));
text := stringreplaceall (text,'&euml;'  ,chr(145));
text := stringreplaceall (text,'&Euml;'  ,chr(232));
text := stringreplaceall (text,'&icirc;' ,chr(148));
text := stringreplaceall (text,'&Icirc;' ,chr(235));
text := stringreplaceall (text,'&iacute;' ,chr(146));
text := stringreplaceall (text,'&Iacute;' ,chr(234));
text := stringreplaceall (text,'&igrave;' ,chr(147));
text := stringreplaceall (text,'&Igrave;' ,chr(237));
text := stringreplaceall (text,'&iuml;' ,chr(149));
text := stringreplaceall (text,'&Iuml;' ,chr(236));
text := stringreplaceall (text,'&ntilde;',chr(150));
text := stringreplaceall (text,'&Ntilde;',chr(132));
text := stringreplaceall (text,'&ograve;',chr(152));
text := stringreplaceall (text,'&Ograve;',chr(241));
text := stringreplaceall (text,'&oacute;',chr(151));
text := stringreplaceall (text,'&Oacute;',chr(238));
text := stringreplaceall (text,'&Ocirc;' ,chr(239));
text := stringreplaceall (text,'&ocirc;' ,chr(153));
text := stringreplaceall (text,'&oslash;',chr(191));
text := stringreplaceall (text,'&Oslash;',chr(175));
text := stringreplaceall (text,'&otilde;',chr(155));
text := stringreplaceall (text,'&Otilde;',chr(239));
text := stringreplaceall (text,'&ouml;',chr(154));
text := stringreplaceall (text,'&Ouml;',chr(133));
text := stringreplaceall (text,'&uuml;',chr(159));
text := stringreplaceall (text,'&Uuml;',chr(134));
text := stringreplaceall (text,'&uacute;',chr(156));
text := stringreplaceall (text,'&Uacute;',chr(242));
text := stringreplaceall (text,'&ucirc;' ,chr(158));
text := stringreplaceall (text,'&Ucirc;' ,chr(243));
text := stringreplaceall (text,'&Ugrave;',chr(244));
text := stringreplaceall (text,'&ugrave;',chr(157));
text := stringreplaceall (text,'&yacute;','y');
text := stringreplaceall (text,'&yuml;'  ,chr(216));
text := stringreplaceall (text,'&Yuml;'  ,chr(217));
text := stringreplaceall (text,'&nbsp;',' ');
text := stringreplaceall (text,'&amp;',chr(38));
result := text;
End;


Function sgml2rtf(text : string) : String;
{Funktion for att byta ut sgml-entiteter mot de koder som
galler i RTF-textrutorna.}
begin
text := stringreplaceall (text,'}','#]#');
text := stringreplaceall (text,'{','#[#');
text := stringreplaceall (text,'\','HSALSKCAB');
text := stringreplaceall (text,'HSALSKCAB','\\');
text := stringreplaceall (text,'&aelig;','\'+chr(39)+'c6');
text := stringreplaceall (text,'&Aelig;','\'+chr(39)+'e6');
text := stringreplaceall (text,'&aacute;','\'+chr(39)+'e1');
text := stringreplaceall (text,'&Aacute;','\'+chr(39)+'c1');
text := stringreplaceall (text,'&agrave;','\'+chr(39)+'e0');
text := stringreplaceall (text,'&Agrave;','\'+chr(39)+'c0');
text := stringreplaceall (text,'&aring;','\'+chr(39)+'e5');
text := stringreplaceall (text,'&Aring;','\'+chr(39)+'c5');
text := stringreplaceall (text,'&Acirc;','\'+chr(39)+'c2');
text := stringreplaceall (text,'&acirc;','\'+chr(39)+'e2');
text := stringreplaceall (text,'&atilde;','\'+chr(39)+'e3');
text := stringreplaceall (text,'&Atilde;','\'+chr(39)+'c3');
text := stringreplaceall (text,'&auml;','\'+chr(39)+'e4');
text := stringreplaceall (text,'&Auml;','\'+chr(39)+'c4');
text := stringreplaceall (text,'&ccedil;','\'+chr(39)+'e7');
text := stringreplaceall (text,'&Ccedil;','\'+chr(39)+'c7');
text := stringreplaceall (text,'&eacute;','\'+chr(39)+'e9');
text := stringreplaceall (text,'&Eacute;','\'+chr(39)+'c9');
text := stringreplaceall (text,'&egrave;','\'+chr(39)+'e8');
text := stringreplaceall (text,'&Egrave;','\'+chr(39)+'c8');
text := stringreplaceall (text,'&ecirc;','\'+chr(39)+'ea');
text := stringreplaceall (text,'&Ecirc;','\'+chr(39)+'ca');
text := stringreplaceall (text,'&euml;','\'+chr(39)+'eb');
text := stringreplaceall (text,'&Euml;','\'+chr(39)+'cb');
text := stringreplaceall (text,'&icirc;','\'+chr(39)+'ee');
text := stringreplaceall (text,'&Icirc;','\'+chr(39)+'ce');
text := stringreplaceall (text,'&iacute;','\'+chr(39)+'ed');
text := stringreplaceall (text,'&Iacute;','\'+chr(39)+'cd');
text := stringreplaceall (text,'&igrave;','\'+chr(39)+'ec');
text := stringreplaceall (text,'&Igrave;','\'+chr(39)+'cc');
text := stringreplaceall (text,'&iuml;'  ,'\'+chr(39)+'ef');
text := stringreplaceall (text,'&Iuml;'  ,'\'+chr(39)+'cf');
text := stringreplaceall (text,'&ntilde;','\'+chr(39)+'f1');
text := stringreplaceall (text,'&Ntilde;','\'+chr(39)+'d1');
text := stringreplaceall (text,'&ouml;','\'+chr(39)+'f6');
text := stringreplaceall (text,'&Ouml;','\'+chr(39)+'d6');
text := stringreplaceall (text,'&oacute;','\'+chr(39)+'f3');
text := stringreplaceall (text,'&Oacute;','\'+chr(39)+'d3');
text := stringreplaceall (text,'&ograve;','\'+chr(39)+'f2');
text := stringreplaceall (text,'&Ograve;','\'+chr(39)+'d2');
text := stringreplaceall (text,'&oslash;','\'+chr(39)+'f8');
text := stringreplaceall (text,'&Oslash;','\'+chr(39)+'d8');
text := stringreplaceall (text,'&Ocirc;','\'+chr(39)+'d4');
text := stringreplaceall (text,'&ocirc;','\'+chr(39)+'f4');
text := stringreplaceall (text,'&otilde;','\'+chr(39)+'f5');
text := stringreplaceall (text,'&Otilde;','\'+chr(39)+'d5');
text := stringreplaceall (text,'&uacute;','\'+chr(39)+'fa');
text := stringreplaceall (text,'&Uacute;','\'+chr(39)+'da');
text := stringreplaceall (text,'&ucirc;','\'+chr(39)+'fb');
text := stringreplaceall (text,'&Ucirc;','\'+chr(39)+'db');
text := stringreplaceall (text,'&Ugrave;','\'+chr(39)+'d9');
text := stringreplaceall (text,'&ugrave;','\'+chr(39)+'f9');
text := stringreplaceall (text,'&uuml;','\'+chr(39)+'fc');
text := stringreplaceall (text,'&Uuml;','\'+chr(39)+'dc');
text := stringreplaceall (text,'&yacute;','\'+chr(39)+'fd');
text := stringreplaceall (text,'&Yacute;','\'+chr(39)+'dd');
text := stringreplaceall (text,'&yuml;','\'+chr(39)+'ff');
text := stringreplaceall (text,'&#163;','\'+chr(39)+'a3');
text := stringreplaceall (text,'#]#','\}');
text := stringreplaceall (text,'#[#','\{');
text := stringreplaceall (text,'&nbsp;','|');
text := stringreplaceall (text,'&amp;','&');
result := text;
End;

function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
  temptext : string;
  start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&amp');
text := stringreplaceall (text,'\'+chr(39)+'c6','&aelig;');
text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;');
text := stringreplaceall (text,'\'+chr(39)+'e5','&aring;');
text := stringreplaceall (text,'\'+chr(39)+'c5','&Aring;');
text := stringreplaceall (text,'\'+chr(39)+'e4','&auml;');
text := stringreplaceall (text,'\'+chr(39)+'c4','&Auml;');
text := stringreplaceall (text,'\'+chr(39)+'e1','&aacute;');
text := stringreplaceall (text,'\'+chr(39)+'c1','&Aacute;');
text := stringreplaceall (text,'\'+chr(39)+'e0','&agrave;');
text := stringreplaceall (text,'\'+chr(39)+'c0','&Agrave;');
text := stringreplaceall (text,'\'+chr(39)+'c2','&Acirc;');
text := stringreplaceall (text,'\'+chr(39)+'e2','&acirc;');
text := stringreplaceall (text,'\'+chr(39)+'e3','&atilde;');
text := stringreplaceall (text,'\'+chr(39)+'c3','&Atilde;');
text := stringreplaceall (text,'\'+chr(39)+'e7','&ccedil;');
text := stringreplaceall (text,'\'+chr(39)+'c7','&Ccedil;');
text := stringreplaceall (text,'\'+chr(39)+'e9','&eacute;');
text := stringreplaceall (text,'\'+chr(39)+'c9','&Eacute;');
text := stringreplaceall (text,'\'+chr(39)+'e8','&egrave;');
text := stringreplaceall (text,'\'+chr(39)+'c8','&Egrave;');
text := stringreplaceall (text,'\'+chr(39)+'ea','&ecirc;');
text := stringreplaceall (text,'\'+chr(39)+'ca','&Ecirc;');
text := stringreplaceall (text,'\'+chr(39)+'eb','&euml;');
text := stringreplaceall (text,'\'+chr(39)+'cb','&Euml;');
text := stringreplaceall (text,'\'+chr(39)+'ee','&icirc;');
text := stringreplaceall (text,'\'+chr(39)+'ce','&Icirc;');
text := stringreplaceall (text,'\'+chr(39)+'ed','&iacute;');
text := stringreplaceall (text,'\'+chr(39)+'cd','&Iacute;');
text := stringreplaceall (text,'\'+chr(39)+'ec','&igrave;');
text := stringreplaceall (text,'\'+chr(39)+'cc','&Igrave;');
text := stringreplaceall (text,'\'+chr(39)+'ef','&iuml;');
text := stringreplaceall (text,'\'+chr(39)+'cf','&Iuml;');
text := stringreplaceall (text,'\'+chr(39)+'f1','&ntilde;');
text := stringreplaceall (text,'\'+chr(39)+'d1','&Ntilde;');
text := stringreplaceall (text,'\'+chr(39)+'f3','&oacute;');
text := stringreplaceall (text,'\'+chr(39)+'d3','&Oacute;');
text := stringreplaceall (text,'\'+chr(39)+'f2','&ograve;');
text := stringreplaceall (text,'\'+chr(39)+'d2','&Ograve;');
text := stringreplaceall (text,'\'+chr(39)+'d4','&Ocirc;');
text := stringreplaceall (text,'\'+chr(39)+'f4','&ocirc;');
text := stringreplaceall (text,'\'+chr(39)+'f5','&otilde;');
text := stringreplaceall (text,'\'+chr(39)+'d5','&Otilde;');
text := stringreplaceall (text,'\'+chr(39)+'f8','&oslash;');
text := stringreplaceall (text,'\'+chr(39)+'d8','&Oslash;');
text := stringreplaceall (text,'\'+chr(39)+'f6','&ouml;');
text := stringreplaceall (text,'\'+chr(39)+'d6','&Ouml;');
text := stringreplaceall (text,'\'+chr(39)+'fc','&uuml;');
text := stringreplaceall (text,'\'+chr(39)+'dc','&Uuml;');
text := stringreplaceall (text,'\'+chr(39)+'fa','&uacute;');
text := stringreplaceall (text,'\'+chr(39)+'da','&Uacute;');
text := stringreplaceall (text,'\'+chr(39)+'fb','&ucirc;');
text := stringreplaceall (text,'\'+chr(39)+'db','&Ucirc;');
text := stringreplaceall (text,'\'+chr(39)+'d9','&Ugrave;');
text := stringreplaceall (text,'\'+chr(39)+'f9','&ugrave;');
text := stringreplaceall (text,'\'+chr(39)+'fd','&yacute;');
text := stringreplaceall (text,'\'+chr(39)+'dd','&Yacute;');
text := stringreplaceall (text,'\'+chr(39)+'ff','&yuml;');
text := stringreplaceall (text,'|','&nbsp;');
text := stringreplaceall (text,'\'+chr(39)+'a3','&#163;');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
if (beginswith (text, '{\rtf1\')) or (beginswith (text, '{\colortbl\')) then
  begin
    result := '';
    exit;
  end;
//text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
//temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');
{Skall alltid tas bort}
//text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');
{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. 
Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); 
{Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');
{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. 
Norska o svenska ar olika}
text := stringreplaceall (text,'\ltrpar','');
text := stringreplaceall (text,'\ql','');
text := stringreplaceall (text,'\ltrch','');
{Har skall vi plocka bort fs och flera olika siffror 
beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
  begin
    //application.processmessages;
    start := pos ('\fs',text);
    Delete(text,start,5);
  end;
while pos ('\f',text) >0 do
  begin
    //application.processmessages;
    start := pos ('\f',text);
    Delete(text,start,3);
  end;
text := stringreplaceall (text,
'\pard\li200-200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+
  chr(39)+'b7}}\plain ','</P><UL>');
text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}','<LI>');
text := stringreplaceall (text, '\par <LI>','<LI>');
text := stringreplaceall (text, '\par <UL>','<UL>');
text := stringreplaceall (text,'\pard\plain ','<P>');
text := stringreplaceall (text,'\par \plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain','</MELLIS>');
text := stringreplaceall (text,'\par }','</P>');
if (pos ('\par \tab ',text)>0) or (pos ('<P>\tab ',text)>0) then
  begin
    text := stringreplaceall (text,'\par \tab ','<TR><TD>');
    text := stringreplaceall (text,'<P>\tab ','<TR><TD>');
    text := stringreplaceall (text,'\tab ','</TD><TD>');
  end
else
  begin
    text := stringreplaceall (text,'\tab ','');
  end;
text := stringreplaceall (text,'\par ','</P><P>');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
if pos('<TD>',text)>0 then text := text+'</TD></TR>';
if pos('<LI>',text)>0 then text := text+'</LI>';
result := text;
end;

end.

И еще: Как перевести RTF в HTML?
Здесь процедура, которую я использую для конвертации содержимого RichEdit в код SGML. Она не создает полноценный HTML-файл, но Вы можете расширить функциональность, указал, какие RTF-коды Вы желаете конвертировать в какие-либо HTML-тэги.

function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&amp');
text := stringreplaceall (text,'\'+chr(39)+'e5','&aring;');
text := stringreplaceall (text,'\'+chr(39)+'c5','&Aring;');
text := stringreplaceall (text,'\'+chr(39)+'e4','&auml;');
text := stringreplaceall (text,'\'+chr(39)+'c4','&Auml;');
text := stringreplaceall (text,'\'+chr(39)+'f6','&ouml;');
text := stringreplaceall (text,'\'+chr(39)+'d6','&Ouml;');
text := stringreplaceall (text,'\'+chr(39)+'e9','&eacute;');
text := stringreplaceall (text,'\'+chr(39)+'c9','&Eacute;');
text := stringreplaceall (text,'\'+chr(39)+'e1','&aacute;');
text := stringreplaceall (text,'\'+chr(39)+'c1','&Aacute;');
text := stringreplaceall (text,'\'+chr(39)+'e0','&agrave;');
text := stringreplaceall (text,'\'+chr(39)+'c0','&Agrave;');
text := stringreplaceall (text,'\'+chr(39)+'f2','&ograve;');
text := stringreplaceall (text,'\'+chr(39)+'d2','&Ograve;');
text := stringreplaceall (text,'\'+chr(39)+'fc','&uuml;');
text := stringreplaceall (text,'\'+chr(39)+'dc','&Uuml;');
text := stringreplaceall (text,'\'+chr(39)+'a3','&#163;');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');
{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');
{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');
{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');
{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');
{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog 
darfor bort det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och 
radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');
{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');
{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror 
beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
  begin
    application.processmessages;
    start := pos ('\fs',text);
    Delete(text,start,5);
  end;
text := stringreplaceall (text,'\pard\plain\f0 ','<P>');
text := stringreplaceall (text,'\par \plain\f0\b\ul ',
'</P><MELLIS>');
text := stringreplaceall (text,'\plain\f0\b\ul ',
'</P><MELLIS>');
text := stringreplaceall (text,'\plain\f0','</MELLIS>');
text := stringreplaceall (text,'\par }','</P>');
text := stringreplaceall (text,'\par ','</P><P>');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;

// This is cut directly from the middle of a fairly
// long save routine that calls the 
// above function. I know I could use streams 
// instead of going through a separate 
// file but I have not had the time to change this

        utfilnamn := mditted.exepath+stringreplace(stringreplace(
         extractfilename(pathname),'.TTT',''),'.ttt','') + 'ut.RTF';
         brodtext.lines.savetofile (utfilnamn);
         temptext := '';
         assignfile(tempF,utfilnamn);
         reset (tempF);
         try
           while not eof(tempF) do
             begin
                readln (tempF,temptext2);
                temptext2 := stringreplaceall (temptext2,'\'+
chr(39)+'b6','');
                temptext2 := rtf2sgml (temptext2);
                if temptext2 <>'' then temptext := temptext+
temptext2;
                application.processmessages;
              end;
         finally
               closefile (tempF);
         end;
         deletefile (utfilnamn);
        temptext := stringreplaceall (temptext,'</MELLIS> ',
'</MELLIS>');
        temptext := stringreplaceall (temptext,'</P> ',
'</P>');
        temptext := stringreplaceall (temptext,'</P>'+chr(0),
'</P>');
        temptext := stringreplaceall (temptext,'</MELLIS>
</P>','</MELLIS>');
        temptext := stringreplaceall (temptext,'<P><
/P>','');
        temptext := stringreplaceall (temptext,
       '</P><P></MELLIS>','</MELLIS>
<P>');
        temptext := stringreplaceall (temptext,'</MELLIS>',
'<#MELLIS><P>');
        temptext := stringreplaceall (temptext,'<#MELLIS>',
'</MELLIS>');
        temptext := stringreplaceall (temptext,'<P><
P>','<P>');
        temptext := stringreplaceall (temptext,'<P> ','<
P>');
        temptext := stringreplaceall (temptext,'<P>-','<
P>_');
        temptext := stringreplaceall (temptext,'<P>_','<
CITAT>_');
        while pos('<CITAT>_',temptext)>0 do
          begin
           application.processmessages;
           temptext2 := hamtastreng (temptext,'<CITAT>_','</P>');
           temptext := stringreplace (temptext,temptext2+'</P>
',temptext2+'</CITAT>');
           temptext := stringreplace (temptext,'<CITAT>_',
'<CITAT>-');
          end;
        writeln (F,'<BRODTEXT>'+temptext+'</BRODTEXT>');

Может пригодится:


Автор: johan@lindgren.pp.se
Прочитано: 6552
Рейтинг:
Оценить: 1 2 3 4 5

Комментарии: (1)

Прислал: Кирилл
Люди, а чего у меня пусто??? Где качать??

Добавить комментарий
Ваше имя*:
Ваш email:
URL Вашего сайта:
Ваш комментарий*:
Код безопастности*:

Рассылка новостей
Рейтинги
© 2007, Программирование Исходники.Ру