Copying only Upercase

Oops, better put in a Trim(Result) at the end

You could also use a regular expression parser, which is perfectly suited  for this task.

http://users.adelphia.net/~rllibby/downloads/regexprex.zip

eg:

procedure TForm1.Button1Click(Sender: TObject);
var  reParse:       TRegExpr;
     listMatches:   TStringList;
     szText:        String;
     dwIndex:       Integer;
begin

  reParse:=TRegExpr.Create;
  try
     reParse.CaseSensitive:=True;
     reParse.Pattern:='\b[A-Z]+\b'; // <- this is all it takes to parse the data
     reParse.Source:='Delphi is a GREATER TOOL to develop and very CHEAP';
     if reParse.MatchFirst then
     begin
        listMatches:=TStringList.Create;
        try
           repeat
              listMatches.Add(reParse.MatchString);
           until not(reParse.MatchNext);
           for dwIndex:=0 to Pred(listMatches.Count) do
           begin
              listMatches[dwIndex]:=listMatches[dwIndex][1]+Copy(LowerCase(listMatches[dwIndex]), 2, MaxInt);
           end;
           szText:=StringReplace(Trim(listMatches.Text), #13#10, #32, [rfReplaceAll]);
           ShowMessage(szText);
        finally
           listMatches.Free;
        end;
     end;
  finally
     reParse.Free;
  end;

end;

---

Regards,
Russell

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := ReturnString(Edit1.Text);
end;

function ReturnString(sTemp: string): string;
var
     sl: TStringList;
     i, j: Integer;
begin
     Result := '';
     Trim(sTemp);
     sl := TStringList.Create;
     try
          sl.Delimiter := ' ';
          sl.DelimitedText := sTemp;
          for i := sl.Count - 1 downto 0 do
          begin
               for j := 1 to Length( sl.Strings[ i]) do
                    if not ( (sl.Strings[ i])[ j] in ['A'..'Z']) then
                    begin
                         sl.Delete(i);
                         break;
                    end;
          end;
          for i := 0 to sl.count - 1 do
               Result := Result + ' ' + sl.Strings[ i][ 1] + Lowercase( Copy( sl.Strings[ i], 2, Length( sl.Strings[ i])))

     finally
          FreeAndNil(sl)
     end;
     Result := Trim(Result);
end;

Slightly smaller and quicker

function ReturnString(sTemp: string): string;
var
  sl: TStringList;
  i, j: Integer;
begin
  Result := '';
  sl := TStringList.Create;
  try
    sl.Delimiter := ' ';
    sl.DelimitedText := sTemp;
      for i := sl.Count - 1 downto 0 do
      begin
        for j := 1 to Length( sl.Strings[ i]) do
          if not ( (sl.Strings[ i])[ j] in ['A'..'Z']) then
          begin
            sl.Delete(i);
            break;
          end;
      end;
    Result := sl.Text;
    Result := Trim( StringReplace(Result, #13#10, ' ', [rfReplaceAll]));
  finally
    FreeAndNil(sl)
  end;
end;

They worked well.

But has a problem, if the string contains Ã Â Í Á Ó É the string in upercase is ignored, i.e.:
 'Delphi is a GREATER TOOL to develop and very CHEAP then JOÃO' it's only returns 'Greater Tool Cheap' and not 'Greater Tool Cheap João'

Ok, here's one that does that also, but remember that the answers provided by the other experts had alredy fully answered the original request :)
If you want to experiment, you could combine two or more solutions (Or simply use widestrings with one of the previous solutions)


ShowMessage(ReturnString('Delphi is a GREATER TOOL to develop and very CHEAP then JOÃO'));

function ReturnString(const OrigStr: Widestring): WideString;
const
Allowed=[WideChar('A')..WideChar('Z'),
              WideChar('Ã'),
              WideChar('Â'),
              WideChar('Í'),
              WideChar('Á'),
              WideChar('Ó'),
              WideChar('É')];
var
  i, j: Integer;
  First:Boolean;
  tempStr,Str:WideString;
begin
  Result:='';
  i:=1;
  if Length(OrigStr)>0 then begin
    Str:=OrigStr+' ';  //life made easy, I know ;)
    while i < Length(Str) do begin
       try
         tempStr:=WideString('');
         if Str[i] in Allowed then begin
           First:=True;
           while Str[i]<>' ' do begin
             if Str[i] in Allowed then
               if First then
                 tempStr:=tempStr+Str[i]
               else
                 tempStr:=tempStr+AnsiLowerCase(Str[i])
             else
               tempStr:='';
             inc(i);
             First:=False;
           end;
           Result:=Result+tempStr;
           if i<Length(Str) then
             Result:=Result+' ';
         end;
       finally
         inc(i);
       end;
    end;
  end;
end;

oh, and you don't need j (j: Integer).