Strings
  1. Equivalent of Trim$(),Mid$(), etc?
  2. String Pattern matching
  3. GetToken
  4. Replacing substrings
  5. Capitalize the first letter of each word in a string
  6. How do I determine if two strings sound alike?
  7. What are the values for the virtual keys?
  8. Delphi currency amount converter [NEW]
  9. Remove Unwanted from String from String[NEW]
  10. String Parsing?[NEW]

Equivalent of Trim$(),Mid$(), etc?

Solution 1

From: bobs@dragons.nest.nl (Bob Swart)


 unit TrimStr;
 {$B-}
 {
      File: TrimStr
    Author: Bob Swart [100434,2072]
   Purpose: routines for removing leading/trailing spaces from strings,
            and to take parts of left/right of string (a la Basic).
   Version: 2.0

   LTrim()    - Remove all spaces from the left side of a string
   RTrim()    - Remove all spaces from the right side of a string
   Trim()     - Remove all extraneous spaces from a string
   RightStr() - Take a certain portion of the right side of a string
   LeftStr()  - Take a certain portion of the left side of a string
   MidStr()   - Take the middle portion of a string

 }
 interface
 Const
   Space = #$20;

   function LTrim(Const Str: String): String;
   function RTrim(Str: String): String;
   function Trim(Str: String):  String;
   function RightStr(Const Str: String; Size: Word): String;
   function LeftStr(Const Str: String; Size: Word): String;
   function MidStr(Const Str: String; Size: Word): String;

 implementation

   function LTrim(Const Str: String): String;
   var len: Byte absolute Str;
       i: Integer;
   begin
     i := 1;
     while (i <= len) and (Str[i] = Space) do Inc(i);
     LTrim := Copy(Str,i,len)
   end {LTrim};

   function RTrim(Str: String): String;
   var len: Byte absolute Str;
   begin
     while (Str[len] = Space) do Dec(len);
     RTrim := Str
   end {RTrim};

   function Trim(Str: String): String;
   begin
     Trim := LTrim(RTrim(Str))
   end {Trim};

   function RightStr(Const Str: String; Size: Word): String;
   var len: Byte absolute Str;
   begin
     if Size > len then Size := len;
     RightStr := Copy(Str,len-Size+1,Size)
   end {RightStr};

   function LeftStr(Const Str: String; Size: Word): String;
   begin
     LeftStr := Copy(Str,1,Size)
   end {LeftStr};

   function MidStr(Const Str: String; Size: Word): String;
   var len: Byte absolute Str;
   begin
     if Size > len then Size := len;
     MidStr := Copy(Str,((len - Size) div 2)+1,Size)
   end {MidStr};
 end.

Solution 2

From: jbui@scd.hp.com (Joseph Bui)

For Mid$, use Copy(S: string; start, length: byte): string;
You can make copy perform Right$ and Left$ as well by doing:
Copy(S, 1, Length) for left$ and
Copy(S, Start, 255) for right$
Note: Start and Length are the byte positions of your starting point, get these with Pos().

Here are some functions I wrote that come in handy for me. Way down at the bottom is a trim() function that you can modify into TrimRight$ and TrimLeft$. Also, they all take pascal style strings, but you can modify them to easily null terminated.


const
   BlackSpace = [#33..#126];

{
   squish() returns a string with all whitespace not inside single
quotes deleted.
}
function squish(const Search: string): string;
var
   Index: byte;
   InString: boolean;
begin
   InString:=False;
   Result:='';
   for Index:=1 to Length(Search) do
   begin
      if InString or (Search[Index] in BlackSpace) then
         AppendStr(Result, Search[Index]);
      InString:=((Search[Index] = '''') and (Search[Index - 1] <> '\'))
            xor InString;
   end;
end;

{
   before() returns everything before the first occurance of
Find in Search. If Find does not occur in Search, Search is
returned.
}
function before(const Search, Find: string): string;
var
   index: byte;
begin
   index:=Pos(Find, Search);
   if index = 0 then
      Result:=Search
   else
      Result:=Copy(Search, 1, index - 1);
end;

{
   after() returns everything after the first occurance of
Find in Search. If Find does not occur in Search, a null
string is returned.
}
function after(const Search, Find: string): string;
var
   index: byte;
begin
   index:=Pos(Find, Search);
   if index = 0 then
      Result:=''
   else
      Result:=Copy(Search, index + Length(Find), 255);
end;

{
   RPos() returns the index of the first character of the last
occurance of Find in Search. Returns 0 if Find does not occur
in Search. Like Pos() but searches in reverse.
}
function RPos(const Find, Search: string): byte;
var
   FindPtr, SearchPtr, TempPtr: PChar;
begin
   FindPtr:=StrAlloc(Length(Find)+1);
   SearchPtr:=StrAlloc(Length(Search)+1);
   StrPCopy(FindPtr,Find);
   StrPCopy(SearchPtr,Search);
   Result:=0;
   repeat
      TempPtr:=StrRScan(SearchPtr, FindPtr^);
      if TempPtr <> nil then
         if (StrLComp(TempPtr, FindPtr, Length(Find)) = 0) then
         begin
            Result:=TempPtr - SearchPtr + 1;
            TempPtr:=nil;
         end
         else
            TempPtr:=#0;
   until TempPtr = nil;
end;

{
   inside() returns the string between the most inside nested
Front ... Back pair.
}
function inside(const Search, Front, Back: string): string;
var
   Index, Len: byte;
begin
   Index:=RPos(Front, before(Search, Back));
   Len:=Pos(Back, Search);
   if (Index > 0) and (Len > 0) then
      Result:=Copy(Search, Index + 1, Len - (Index + 1))
   else
      Result:='';
end;

{
   leftside() returns what is to the left of inside() or Search.
}
function leftside(const Search, Front, Back: string): string;
begin
   Result:=before(Search, Front + inside(Search, Front, Back) + Back);
end;

{
   rightside() returns what is to the right of inside() or Null.
}
function rightside(const Search, Front, Back: string): string;
begin
   Result:=after(Search, Front + inside(Search, Front, Back) + Back);
end;

{
   trim() returns a string with all right and left whitespace removed.
}
function trim(const Search: string): string;
var
   Index: byte;
begin
   Index:=1;
   while (Index <= Length(Search)) and not (Search[Index] in BlackSpace) do
      Index:=Index + 1;
   Result:=Copy(Search, Index, 255);
   Index:=Length(Result);
   while (Index > 0) and not (Result[Index] in BlackSpace) do
      Index:=Index - 1;
   Result:=Copy(Result, 1, Index);
end;

String Pattern matching

From: stidolph@magnet.com (David Stidolph)

There are many times when you need to compare two strings, but want to use wild cards in the match - all last names that begin with 'St', etc. The following is a piece of code I got from Sean Stanley in Tallahassee Florida in C. I translated it into Delphi an am uploading it here for all to use. I have not tested it extensivly, but the original function has been tested quite thoughly.

I would love feedback on this routine - or peoples changes to it. I want to forward them to Sean to get him to release more tidbits like this.


{
  This function takes two strings and compares them.  The first string
  can be anything, but should not contain pattern characters (* or ?).
  The pattern string can have as many of these pattern characters as you want.
  For example: MatchStrings('David Stidolph','*St*') would return True.

  Orignal code by Sean Stanley in C
  Rewritten in Delphi by David Stidolph
}
function MatchStrings(source, pattern: String): Boolean;
var
  pSource: Array [0..255] of Char;
  pPattern: Array [0..255] of Char;

  function MatchPattern(element, pattern: PChar): Boolean;

    function IsPatternWild(pattern: PChar): Boolean;
    var
      t: Integer;
    begin
      Result := StrScan(pattern,'*') <> nil;
      if not Result then Result := StrScan(pattern,'?') <> nil;
    end;

  begin
    if 0 = StrComp(pattern,'*') then
      Result := True
    else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
      Result := False
    else if element^ = Chr(0) then
      Result := True
    else begin
      case pattern^ of
      '*': if MatchPattern(element,@pattern[1]) then
             Result := True
           else
             Result := MatchPattern(@element[1],pattern);
      '?': Result := MatchPattern(@element[1],@pattern[1]);
      else
        if element^ = pattern^ then
          Result := MatchPattern(@element[1],@pattern[1])
        else
          Result := False;
      end;
    end;
  end;

begin
  StrPCopy(pSource,source);
  StrPCopy(pPattern,pattern);
  Result := MatchPattern(pSource,pPattern);
end;

GetToken

Thomas Scheffczyk <SCHEFFCZYK@islay.verwaltung.uni-mainz.de>

I don't know if this will help you, but the following (simple) functions helped me handling substrings. Perhaps you can use them to seperate the text for each field (for i := 1 to NumToken do ...) and store it seperatly in the database-fields.


function GetToken(aString, SepChar: String; TokenNum: Byte):String;
{
parameters: aString : the complete string
            SepChar : a single character used as separator 
                      between the substrings
            TokenNum: the number of the substring you want
result    : the substring or an empty string if the are less then
            'TokenNum' substrings
}
var
   Token     : String;
   StrLen    : Byte;
   TNum      : Byte;
   TEnd      : Byte;

begin
     StrLen := Length(aString);
     TNum   := 1;
     TEnd   := StrLen;
     while ((TNum <= TokenNum) and (TEnd <> 0)) do
     begin
          TEnd := Pos(SepChar,aString);
          if TEnd <> 0 then
          begin
               Token := Copy(aString,1,TEnd-1);
               Delete(aString,1,TEnd);
               Inc(TNum);
          end
          else
          begin
               Token := aString;
          end;
     end;
     if TNum >= TokenNum then
     begin
          GetToken1 := Token;
     end
     else
     begin
          GetToken1 := '';
     end;
end;

function NumToken(aString, SepChar: String):Byte;
{
parameters: aString : the complete string
            SepChar : a single character used as separator 
                      between the substrings
result    : the number of substrings
}

var
   RChar     : Char;
   StrLen    : Byte;
   TNum      : Byte;
   TEnd      : Byte;

begin
     if SepChar = '#' then
     begin
          RChar := '*'
     end
     else
     begin
         RChar := '#'
     end;
     StrLen := Length(aString);
     TNum   := 0;
     TEnd   := StrLen;
     while TEnd <> 0 do
     begin
          Inc(TNum);
          TEnd := Pos(SepChar,aString);
          if TEnd <> 0 then
          begin
               aString[TEnd] := RChar;
          end;
     end;
     NumToken1 := TNum;
end;

"Hrvoje Brozovic" <Hrvoje.Brozovic@ring.hr>
function CopyColumn( const s_string: string; c_fence: char; i_index: integer ): string;
var i, i_left: integer;
begin
    result := EmptyStr;
    if i_index = 0 then begin
        exit;
    end;
    i_left := 0;
    for i := 1 to Length( s_string ) do begin
        if s_string[ i ] = c_fence then begin
            Dec( i_index );
            if i_index = 0 then begin
                result := Copy( s_string, i_left + 1, i - i_left - 1 );
                exit;
            end else begin
                i_left := i;
            end;
        end;
    end;
    Dec( i_index );
    if i_index = 0 then begin
        result := Copy( s_string, i_left + 1, Length( s_string ));
    end;
end;

I know that in GetToken SepChar parameter ( c_fence in my case ) is string, not char, but comment says that he is expecting single char in that string, and it is obvious that if you send more than one char, it won't work correctly. ( Delete(aString,1,TEnd) is buggy if Length( SepChar ) > 1 ).

Replacing substrings

From: michael@quinto.ruhr.de (Michael Bialas)

 Does anyone know a fast algorithm that replaces all occurences of any
substring sub1 to any string sub2 in any string str.
This should do the job:


  function ReplaceSub(str, sub1, sub2: String): String;
  var
    aPos: Integer;
    rslt: String;
  begin
    aPos := Pos(sub1, str);
    rslt := '';
    while (aPos <> 0) do begin
      rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
      Delete(str, 1, aPos + Length(sub1));
      aPos := Pos(sub1, str);
    end;
    Result := rslt + str;
  end;

Capitalize the first letter of each word in a string

Erik Sperling Johansen <erik@info-pro.no>


function LowCase(ch : CHAR) : CHAR;
begin
  case ch of
    'A'..'Z' : LowCase := CHR (ORD(ch)+31);
  else
    LowCase := ch;
  end;
end;

function Proper (source, separators : STRING) : STRING;
var
  LastWasSeparator : BOOLEAN;
  ndx              : INTEGER;
begin
  LastWasSeparator := TRUE;  
  ndx := 1;
  while (ndx<=Length(source)) do begin
    if LastWasSeparator
    then source[ndx] := UpCase(source[ndx])
    else source[ndx] := LowCase(source[ndx]);
    LastWasSeparator := Pos(source[ndx], separators)>0;
    inc(ndx);
  end;
  Result := source;
end;

From: "Cleon T. Bailey" <baileyct@ionet.net>


Function  TfrmLoadProtocolTable.ToMixCase(InString: String): String;
Var I: Integer;
Begin
  Result := LowerCase(InString);
  Result[1] := UpCase(Result[1]);
  For I := 1 To Length(InString) - 1 Do Begin
    If (Result[I] = ' ') Or (Result[I] = '''') Or (Result[I] = '"')
    Or (Result[I] = '-') Or (Result[I] = '.')  Or (Result[I] = '(') Then
      Result[I + 1] := UpCase(Result[I + 1]);
  End;
End;

From: "Paul Motyer" <paulm@linuxserver.pccity.com.au>

Both Tim Stannard's and Cleon T. Bailey's functions will bomb in D2 if sent an empty string (where accessing InString[1] causes an access violation, the second attempt will do the same if the last character is in the set.

try this instead:


function proper(s:string):string;
var t:string;
    i:integer;
    newWord:boolean;
begin
if s='' then exit;
s:=lowercase(s);
t:=uppercase(s);
newWord:=true;
for i:=1 to length(s) do
    begin
    if newWord and (s[i] in ['a'..'z']) then
       begin s[i]:=t[i]; newWord:=false; continue; end;
    if s[i] in ['a'..'z',''''] then continue;
    newWord:=true;
    end;
result:=s;
end;

How do I determine if two strings sound alike?

{ This code came from Lloyd's help file! }

Soundex function--determines whether two words sound alike. Written after reading an article in PC Magazine about the Soundex algorithm. Pass the function a string. It returns a Soundex value string. This value can be saved in a database or compared to another Soundex value. If two words have the same Soundex value, then they sound alike (more or less).

Note that the Soundex algorithm ignores the first letter of a word. Thus, "won" and "one" will have different Soundex values, but "Won" and "Wunn" will have the same values.

Soundex is especially useful in databases when one does not know how to spell a last name.


Function Soundex(OriginalWord: string): string;
var
  Tempstring1, Tempstring2: string;
  Count: integer;
begin
  Tempstring1 := '';
  Tempstring2 := '';
  OriginalWord := Uppercase(OriginalWord); {Make original word uppercase}
  Appendstr(Tempstring1, OriginalWord[1]); {Use the first letter of the word}
  for Count := 2 to length(OriginalWord) do
    {Assign a numeric value to each letter, except the first}

    case OriginalWord[Count] of
      'B','F','P','V': Appendstr(Tempstring1, '1');
      'C','G','J','K','Q','S','X','Z': Appendstr(Tempstring1, '2');
      'D','T': Appendstr(Tempstring1, '3');
      'L': Appendstr(Tempstring1, '4');
      'M','N': Appendstr(Tempstring1, '5');
      'R': Appendstr(Tempstring1, '6');
      {All other letters, punctuation and numbers are ignored}
    end;
  Appendstr(Tempstring2, OriginalWord[1]);
  {Go through the result removing any consecutive duplicate numeric values.}

  for Count:=2 to length(Tempstring1) do
    if Tempstring1[Count-1]<>Tempstring1[Count] then
        Appendstr(Tempstring2,Tempstring1[Count]);
  Soundex:=Tempstring2; {This is the soundex value}
end;

SoundAlike--pass two strings to this function. It returns True if they sound alike, False if they don't. Simply calls the Soundex function.


Function SoundAlike(Word1, Word2: string): boolean;
begin
  if (Word1 = '') and (Word2 = '') then result := True
  else
  if (Word1 = '') or (Word2 = '') then result := False
  else
  if (Soundex(Word1) = Soundex(Word2)) then result := True
  else result := False;
end;


What are the values for the virtual keys?

  vk_LButton   = $01;
  vk_RButton   = $02;
  vk_Cancel    = $03;
  vk_MButton   = $04;   { NOT contiguous with L & RBUTTON }
  vk_Back      = $08;
  vk_Tab       = $09;
  vk_Clear     = $0C;
  vk_Return    = $0D;
  vk_Shift     = $10;
  vk_Control   = $11;
  vk_Menu      = $12;
  vk_Pause     = $13;
  vk_Capital   = $14;
  vk_Escape    = $1B;
  vk_Space     = $20;
  vk_Prior     = $21;
  vk_Next      = $22;

  vk_End       = $23;
  vk_Home      = $24;
  vk_Left      = $25;
  vk_Up        = $26;
  vk_Right     = $27;
  vk_Down      = $28;
  vk_Select    = $29;
  vk_Print     = $2A;
  vk_Execute   = $2B;
  vk_SnapShot  = $2C;
{ vk_Copy      = $2C not used by keyboards }
  vk_Insert    = $2D;
  vk_Delete    = $2E;
  vk_Help      = $2F;
{ vk_A thru vk_Z are the same as their ASCII equivalents: 'A' thru 'Z' }
{ vk_0 thru vk_9 are the same as their ASCII equivalents: '0' thru '9' }

  vk_NumPad0   = $60;
  vk_NumPad1   = $61;
  vk_NumPad2   = $62;
  vk_NumPad3   = $63;
  vk_NumPad4   = $64;
  vk_NumPad5   = $65;
  vk_NumPad6   = $66;
  vk_NumPad7   = $67;
  vk_NumPad8   = $68;
  vk_NumPad9   = $69;
  vk_Multiply  = $6A;
  vk_Add       = $6B;
  vk_Separator = $6C;
  vk_Subtract  = $6D;
  vk_Decimal   = $6E;
  vk_Divide    = $6F;
  vk_F1        = $70;
  vk_F2        = $71;
  vk_F3        = $72;
  vk_F4        = $73;
  vk_F5        = $74;

  vk_F6        = $75;
  vk_F7        = $76;
  vk_F8        = $77;
  vk_F9        = $78;
  vk_F10       = $79;
  vk_F11       = $7A;
  vk_F12       = $7B;
  vk_F13       = $7C;
  vk_F14       = $7D;
  vk_F15       = $7E;
  vk_F16       = $7F;
  vk_F17       = $80;
  vk_F18       = $81;
  vk_F19       = $82;
  vk_F20       = $83;
  vk_F21       = $84;
  vk_F22       = $85;
  vk_F23       = $86;
  vk_F24       = $87;
  vk_NumLock   = $90;
  vk_Scroll    = $91;

{ This code came from Lloyd's help file! }

Delphi currency amount converter [NEW]

From: "Donald Johnson" <binary@computerbargain.com>


Function  HundredAtATime(TheAmount:Integer):String;
var
  TheResult : String;
Begin
  TheResult := '';
  TheAmount := Abs(TheAmount);
  While TheAmount > 0 do Begin
    If TheAmount >= 900 Then Begin
      TheResult := TheResult + 'Nine hundred ';
      TheAmount := TheAmount - 900;
    End;
    If TheAmount >= 800 Then Begin
      TheResult := TheResult + 'Eight hundred ';
      TheAmount := TheAmount - 800;
    End;
    If TheAmount >= 700 Then Begin
      TheResult := TheResult + 'Seven hundred ';
      TheAmount := TheAmount - 700;
    End;
    If TheAmount >= 600 Then Begin
      TheResult := TheResult + 'Six hundred ';
      TheAmount := TheAmount - 600;
    End;
    If TheAmount >= 500 Then Begin
      TheResult := TheResult + 'Five hundred ';
      TheAmount := TheAmount - 500;
    End;
    If TheAmount >= 400 Then Begin
      TheResult := TheResult + 'Four hundred ';
      TheAmount := TheAmount - 400;
    End;
    If TheAmount >= 300 Then Begin
      TheResult := TheResult + 'Three hundred ';
      TheAmount := TheAmount - 300;
    End;
    If TheAmount >= 200 Then Begin
      TheResult := TheResult + 'Two hundred ';
      TheAmount := TheAmount - 200;
    End;
    If TheAmount >= 100 Then Begin
      TheResult := TheResult + 'One hundred ';
      TheAmount := TheAmount - 100;
    End;
    If TheAmount >= 90 Then Begin
      TheResult := TheResult + 'Ninety ';
      TheAmount := TheAmount - 90;
    End;
    If TheAmount >= 80 Then Begin
      TheResult := TheResult + 'Eighty ';
      TheAmount := TheAmount - 80;
    End;
    If TheAmount >= 70 Then Begin
      TheResult := TheResult + 'Seventy ';
      TheAmount := TheAmount - 70;
    End;
    If TheAmount >= 60 Then Begin
      TheResult := TheResult + 'Sixty ';
      TheAmount := TheAmount - 60;
    End;
    If TheAmount >= 50 Then Begin
      TheResult := TheResult + 'Fifty ';
      TheAmount := TheAmount - 50;
    End;
    If TheAmount >= 40 Then Begin
      TheResult := TheResult + 'Fourty ';
      TheAmount := TheAmount - 40;
    End;
    If TheAmount >= 30 Then Begin
      TheResult := TheResult + 'Thirty ';
      TheAmount := TheAmount - 30;
    End;
    If TheAmount >= 20 Then Begin
      TheResult := TheResult + 'Twenty ';
      TheAmount := TheAmount - 20;
    End;
    If TheAmount >= 19 Then Begin
      TheResult := TheResult + 'Nineteen ';
      TheAmount := TheAmount - 19;
    End;
    If TheAmount >= 18 Then Begin
      TheResult := TheResult + 'Eighteen ';
      TheAmount := TheAmount - 18;
    End;
    If TheAmount >= 17 Then Begin
      TheResult := TheResult + 'Seventeen ';
      TheAmount := TheAmount - 17;
    End;
    If TheAmount >= 16 Then Begin
      TheResult := TheResult + 'Sixteen ';
      TheAmount := TheAmount - 16;
    End;
    If TheAmount >= 15 Then Begin
      TheResult := TheResult + 'Fifteen ';
      TheAmount := TheAmount - 15;
    End;
    If TheAmount >= 14 Then Begin
      TheResult := TheResult + 'Fourteen ';
      TheAmount := TheAmount - 14;
    End;
    If TheAmount >= 13 Then Begin
      TheResult := TheResult + 'Thirteen ';
      TheAmount := TheAmount - 13;
    End;
    If TheAmount >= 12 Then Begin
      TheResult := TheResult + 'Twelve ';
      TheAmount := TheAmount - 12;
    End;
    If TheAmount >= 11 Then Begin
      TheResult := TheResult + 'Eleven ';
      TheAmount := TheAmount - 11;
    End;
    If TheAmount >= 10 Then Begin
      TheResult := TheResult + 'Ten ';
      TheAmount := TheAmount - 10;
    End;
    If TheAmount >= 9 Then Begin
      TheResult := TheResult + 'Nine ';
      TheAmount := TheAmount - 9;
    End;
    If TheAmount >= 8 Then Begin
      TheResult := TheResult + 'Eight ';
      TheAmount := TheAmount - 8;
    End;
    If TheAmount >= 7 Then Begin
      TheResult := TheResult + 'Seven ';
      TheAmount := TheAmount - 7;
    End;
    If TheAmount >= 6 Then Begin
      TheResult := TheResult + 'Six ';
      TheAmount := TheAmount - 6;
    End;
    If TheAmount >= 5 Then Begin
      TheResult := TheResult + 'Five ';
      TheAmount := TheAmount - 5;
    End;
    If TheAmount >= 4 Then Begin
      TheResult := TheResult + 'Four ';
      TheAmount := TheAmount - 4;
    End;
    If TheAmount >= 3 Then Begin
      TheResult := TheResult + 'Three ';
      TheAmount := TheAmount - 3;
    End;
    If TheAmount >= 2 Then Begin
      TheResult := TheResult + 'Two ';
      TheAmount := TheAmount - 2;
    End;
    If TheAmount >= 1 Then Begin
      TheResult := TheResult + 'One ';
      TheAmount := TheAmount - 1;
    End;
  End;
  HundredAtATime := TheResult;
End;

Function  Real2CheckAmount(TheAmount:Real):String;
Var
  IntVal  : LongInt;
  TmpVal  : Integer;
  TmpStr,
  RetVal  : String;
begin
  TheAmount := Abs(TheAmount);

  { cents}
  TmpVal    := Round(Frac(TheAmount) * 100);
  IntVal    := Trunc(TheAmount);
  TmpStr    := HundredAtATime(TmpVal);
  If TmpStr  = '' Then TmpStr := 'Zero ';
  RetVal    := TmpStr + 'cents';
  If IntVal > 0 Then RetVal := 'dollars and ' + RetVal;

  { hundreds }
  TmpVal    := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal    := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr    := HundredAtATime(TmpVal);
  RetVal    := TmpStr + RetVal;

  { thousands }
  TmpVal    := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal    := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr    := HundredAtATime(TmpVal);
  If TmpStr <> '' Then
    RetVal    := TmpStr + 'Thousand ' + RetVal;

  { millions }
  TmpVal    := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal    := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr    := HundredAtATime(TmpVal);
  If TmpStr <> '' Then
    RetVal    := TmpStr + 'Million ' + RetVal;

  { billions }
  TmpVal    := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal    := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr    := HundredAtATime(TmpVal);
  If TmpStr <> '' Then
    RetVal    := TmpStr + 'Billion ' + RetVal;

  Real2CheckAmount := RetVal;
end;

From: azizan@gto.net.om (Nazar Aziz)

Hmmm... What about this.... and some nice recursion too!!!..:)))


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    num: TEdit;
    spell: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    function trans9(num: integer): string;
    function trans19(num: integer): string;
    function trans99(num: integer): string;
    function IntToSpell(num: integer): string;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
function TForm1.IntToSpell(num: integer): string;
var
   spell: string;
   hspell: string;
   hundred: string;
   thousand: string;
   tthousand: string;
   hthousand: string;
   million: string;
begin
   if num ≶ 10 then
      spell := trans9(num);
   {endif}
   if (num < 20) and (num > 10) then
      spell := trans19(num);
   {endif}
   if (((num < 100) and (num > 19)) or (num = 10)) then
   begin
      hspell := copy(IntToStr(num),1,1) + '0';
      spell := trans99(StrToInt(hspell));
      hspell := copy(IntToStr(num),2,1);
      spell := spell + ' ' + IntToSpell(StrToInt(hspell));
   end;

   if (num < 1000) and (num > 100) then
   begin
      hspell := copy(IntToStr(num),1,1);
      hundred := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num),2,2);
      hundred := hundred + ' hundred and ' + IntToSpell(StrToInt(hspell));
      spell := hundred;
   end;

   if (num < 10000) and (num > 1000) then
   begin
      hspell := copy(IntToStr(num),1,1);
      thousand := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num),2,3);
      thousand := thousand + ' thousand ' + IntToSpell(StrToInt(hspell));
      spell := thousand;
   end;

   if (num < 100000) and (num > 10000) then
   begin
      hspell := copy(IntToStr(num),1,2);
      tthousand := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num),3,3);
      tthousand := tthousand + ' thousand ' + IntToSpell(StrToInt(hspell));
      spell := tthousand;
   end;

   if (num < 1000000) and (num > 100000) then
   begin
      hspell := copy(IntToStr(num),1,3);
      hthousand := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num),4,3);
      hthousand := hthousand + ' thousand and ' + 
IntToSpell(StrToInt(hspell));
      spell := hthousand;
   end;

   if (num < 10000000) and (num > 1000000) then
   begin
      hspell := copy(IntToStr(num),1,1);
      million := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num),2,6);
      million := million + ' million and ' + IntToSpell(StrToInt(hspell));
      spell := million;
   end;

   IntToSpell := spell;

end;

function TForm1.trans99(num: integer): string;
var
   spell: string;
begin
   case num of
     10 : spell := 'ten';
     20 : spell := 'twenty';
     30 : spell := 'thirty';
     40 : spell := 'fourty';
     50 : spell := 'fifty';
     60 : spell := 'sixty';
     70 : spell := 'seventy';
     80 : spell := 'eighty';
     90 : spell := 'ninty';
   end;
   trans99 := spell;
end;
function TForm1.trans19(num: integer): string;
var
   spell: string;
begin
   case num of
     11 : spell := 'eleven';
     12 : spell := 'twelve';
     13 : spell := 'thirteen';
     14 : spell := 'fourteen';
     15 : spell := 'fifteen';
     16 : spell := 'sixteen';
     17 : spell := 'seventeen';
     18 : spell := 'eighteen';
     19 : spell := 'nineteen';
   end;
   trans19 := spell;
end;
function TForm1.trans9(num: integer): string;
var
   spell : string;
begin
   case num of
     1 : spell := 'one';
     2 : spell := 'two';
     3 : spell := 'three';
     4 : spell := 'four';
     5 : spell := 'five';
     6 : spell := 'six';
     7 : spell := 'seven';
     8 : spell := 'eight';
     9 : spell := 'nine';
   end;
   trans9 := spell;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
   numb: integer;
begin
   spell.text := IntToSpell(StrToInt(num.text));
end;

Remove Unwanted from String from String[NEW]

"Joseph Y. Wong" <jywong@concentric.net>


procedure RemoveInvalid(what, where: string): string;
// what is the string to be removed, where is the string to be removed from
var
  tstr: string;
begin
  tstr:=where;
  while pos(what, tstr)>0 do
    tstr:=copy(tstr,1,pos(what,tstr)-1) +
       copy(tstr,pos(what,tstr)+length(tstr),length(tstr));
  Result:=tstr;
end;

Use:
  NewStr:=RemoveInvalid('<invalid>','This <invalid> is my string and I wan to
       remove the word <invalid>');

"Laurie Bisman" <lbisman@ihug.co.nz>

Use Pascal's DELETE...
using your example string, you could use code like....


Target:='<invalid>';
While POS(Target,string)>0 do
     begin
         P := POS(Target,string);
        DELETE(string,P,Length(Target));
     end;

String Parsing?[NEW]

From: johan@lindgren.pp.se

This is a unit where I have gathered lots of this type of routines.
Some of the function names are in swedish, but maybe you can figure out what they are doing.

The one you need is called stringreplaceall which takes three parameters, the string, what to search for and what to replace with and it return the changed string. But beware if you are changing something to something that contains the first. You must do it in two passes or you will end up in an endless loop.

So if you have text containing the word Joe and you like all occurances to be changed to Joey you need to first do something like: text := stringreplaceall (text,'Joe','Joeey'); and then 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 := '';
  //Öppna angiven fil och läs in den
  try
    assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname
    reset (infil);             //Öppna filen
    while not eof(infil) do begin    //Så länge vi inte nått slutet
      readln (infil,temptext); //Läs in en rad
      filtext := filtext+temptext; //Lägg den till variabeln SGMLTEXT
    end; // while
  finally  //slutligen
    closefile (infil); //Stäng 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 för att byta ut alla förekomster av en sträng mot en
annan sträng in en sträng. Den konverterade strängen returneras.
Om byt finns i mot måste vi gå via en temporär 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 för att byta ut den första förekomsten av en sträng mot en
annan sträng in en sträng. Den konverterade strängen 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 för att hämta ut en delsträng ur en annan sträng.
Om start och slut finns i text så returneras en sträng där start
ingår i början och fram till tecknet före 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 för att hämta ut en delsträng ur en annan sträng.
Om start och slut finns i text så returneras en sträng där start
ingår i början och fram till tecknet före 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 sträng slutar med en annan sträng.
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 för att kolla om text börjar 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 för att ta fram sista meningen i en sträng. Söker på !?.
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 färdiga texten returneras.}
begin
  text := stringreplaceall (text,'&','##amp;');
  text := stringreplaceall (text,'##amp','&amp');
  text := stringreplaceall (text,'å','&aring;');
  text := stringreplaceall (text,'Å','&Aring;');
  text := stringreplaceall (text,'ä','&auml;');
  text := stringreplaceall (text,'Ä','&Auml;');
  text := stringreplaceall (text,'á','&aacute;');
  text := stringreplaceall (text,'Á','&Aacute;');
  text := stringreplaceall (text,'à','&agrave;');
  text := stringreplaceall (text,'À','&Agrave;');
  text := stringreplaceall (text,'æ','&aelig;');
  text := stringreplaceall (text,'Æ','&Aelig;');
  text := stringreplaceall (text,'Â','&Acirc;');
  text := stringreplaceall (text,'â','&acirc;');
  text := stringreplaceall (text,'ã','&atilde;');
  text := stringreplaceall (text,'Ã','&Atilde;');
  text := stringreplaceall (text,'ç','&ccedil;');
  text := stringreplaceall (text,'Ç','&Ccedil;');
  text := stringreplaceall (text,'é','&eacute;');
  text := stringreplaceall (text,'É','&Eacute;');
  text := stringreplaceall (text,'ê','&ecirc;');
  text := stringreplaceall (text,'Ê','&Ecirc;');
  text := stringreplaceall (text,'ë','&euml;');
  text := stringreplaceall (text,'Ë','&Euml;');
  text := stringreplaceall (text,'è','&egrave;');
  text := stringreplaceall (text,'È','&Egrave;');
  text := stringreplaceall (text,'î','&icirc;');
  text := stringreplaceall (text,'Î','&Icirc;');
  text := stringreplaceall (text,'í','&iacute;');
  text := stringreplaceall (text,'Í','&Iacute;');
  text := stringreplaceall (text,'ì','&igrave;');
  text := stringreplaceall (text,'Ì','&Igrave;');
  text := stringreplaceall (text,'ï','&iuml;');
  text := stringreplaceall (text,'Ï','&Iuml;');
  text := stringreplaceall (text,'ñ','&ntilde;');
  text := stringreplaceall (text,'Ñ','&Ntilde;');
  text := stringreplaceall (text,'ö','&ouml;');
  text := stringreplaceall (text,'Ö','&Ouml;');
  text := stringreplaceall (text,'ò','&ograve;');
  text := stringreplaceall (text,'Ò','&Ograve;');
  text := stringreplaceall (text,'ó','&oacute;');
  text := stringreplaceall (text,'Ó','&Oacute;');
  text := stringreplaceall (text,'ø','&oslash;');
  text := stringreplaceall (text,'Ø','&Oslash;');
  text := stringreplaceall (text,'Ô','&Ocirc;');
  text := stringreplaceall (text,'ô','&ocirc;');
  text := stringreplaceall (text,'õ','&otilde;');
  text := stringreplaceall (text,'Õ','&Otilde;');
  text := stringreplaceall (text,'ü','&uuml;');
  text := stringreplaceall (text,'Ü','&Uuml;');
  text := stringreplaceall (text,'ú','&uacute;');
  text := stringreplaceall (text,'Ú','&Uacute;');
  text := stringreplaceall (text,'Ù','&Ugrave;');
  text := stringreplaceall (text,'ù','&ugrave;');
  text := stringreplaceall (text,'û','&ucirc;');
  text := stringreplaceall (text,'Û','&Ucirc;');
  text := stringreplaceall (text,'ý','&yacute;');
  text := stringreplaceall (text,'Ý','&Yacute;');
  text := stringreplaceall (text,'ÿ','&yuml;');
  text := stringreplaceall (text,'|','&nbsp;');
  result := text;
End;

Function sgml2win(text : String) : String;
{Funktion som ersätter alla entiteter mot deras tecken i
windows. Den färdiga strängen returneras.}
begin
text := stringreplaceall (text,'&aacute;','á');
text := stringreplaceall (text,'&Aacute;','Á');
text := stringreplaceall (text,'&aelig;','æ');
text := stringreplaceall (text,'&Aelig;','Æ');
text := stringreplaceall (text,'&agrave;','à');
text := stringreplaceall (text,'&Agrave;','À');
text := stringreplaceall (text,'&aring;','å');
text := stringreplaceall (text,'&Aring;','Å');
text := stringreplaceall (text,'&auml;','ä');
text := stringreplaceall (text,'&Auml;','Ä');
text := stringreplaceall (text,'&Acirc;' ,'Â');
text := stringreplaceall (text,'&acirc;' ,'â');
text := stringreplaceall (text,'&atilde;','ã');
text := stringreplaceall (text,'&Atilde;','Ã');
text := stringreplaceall (text,'&ccedil;','ç');
text := stringreplaceall (text,'&Ccedil;','Ç');
text := stringreplaceall (text,'&eacute;','é');
text := stringreplaceall (text,'&Eacute;','É');
text := stringreplaceall (text,'&egrave;','è');
text := stringreplaceall (text,'&Egrave;','È');
text := stringreplaceall (text,'&ecirc;' ,'ê');
text := stringreplaceall (text,'&Ecirc;' ,'Ê');
text := stringreplaceall (text,'&euml;'  ,'ë');
text := stringreplaceall (text,'&Euml;'  ,'Ë');
text := stringreplaceall (text,'&icirc;' ,'î');
text := stringreplaceall (text,'&Icirc;' ,'Î');
text := stringreplaceall (text,'&iacute;','í');
text := stringreplaceall (text,'&Iacute;','Í');
text := stringreplaceall (text,'&igrave;','ì');
text := stringreplaceall (text,'&Igrave;','Ì');
text := stringreplaceall (text,'&iuml;'  ,'ï');
text := stringreplaceall (text,'&Iuml;'  ,'Ï');
text := stringreplaceall (text,'&ntilde;','ñ');
text := stringreplaceall (text,'&Ntilde;','Ñ');
text := stringreplaceall (text,'&ograve;','ò');
text := stringreplaceall (text,'&Ograve;','Ò');
text := stringreplaceall (text,'&oacute;','ó');
text := stringreplaceall (text,'&Oacute;','Ó');
text := stringreplaceall (text,'&ouml;','ö');
text := stringreplaceall (text,'&Ouml;','Ö');
text := stringreplaceall (text,'&oslash;','ø');
text := stringreplaceall (text,'&Oslash;','Ø');
text := stringreplaceall (text,'&Ocirc;' ,'Ô');
text := stringreplaceall (text,'&ocirc;' ,'ô');
text := stringreplaceall (text,'&otilde;','õ');
text := stringreplaceall (text,'&Otilde;','Õ');
text := stringreplaceall (text,'&uuml;','ü');
text := stringreplaceall (text,'&Uuml;','Ü');
text := stringreplaceall (text,'&uacute;','ú');
text := stringreplaceall (text,'&Uacute;','Ú');
text := stringreplaceall (text,'&ucirc;' ,'û');
text := stringreplaceall (text,'&Ucirc;' ,'Û');
text := stringreplaceall (text,'&Ugrave;','Ù');
text := stringreplaceall (text,'&ugrave;','ù');
text := stringreplaceall (text,'&yacute;','ý');
text := stringreplaceall (text,'&Yacute;','Ý');
text := stringreplaceall (text,'&yuml;'  ,'ÿ');
text := stringreplaceall (text,'&nbsp;','|');
text := stringreplaceall (text,'&amp;','&');
result := text;
End;

Function sgml2mac(text : String) : String;
{Funktion som ersätter alla entiteter mot deras tecken i
mac. Den färdiga strängen 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 för att byta ut sgml-entiteter mot de koder som
gäller 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 för 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 därför bort
det efter \fs16 och la istället en egen tvätt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hämta och radera allt från start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka från deflang till pard för att få }
text := stringreplace (text,temptext,'');{oavsett vilken lang det är. Norska o svenska är olika}
text := stringreplaceall (text,'\ltrpar','');
text := stringreplaceall (text,'\ql','');
text := stringreplaceall (text,'\ltrch','');
{Här skall vi plocka bort fs och flera olika siffror beroende på vilka alternativ vi godkänner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu städar vi istället bort alla tvåsiffriga 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.


Please email me and tell me if you liked this page.