[BBBCat]

Сорри, обнаружил баг - цикл нужно сделать не до 0, а до 1. Ну и выкинул кое-что...

Код:

function FindCharSet(const Data:string):integer;
const
  CodePages: array[0..10] of string = ('windows-1251','utf-8','utf-16','windows-1252',
  'koi8-r','iso-8859-1','iso-8859-2','iso-8859-3','iso-8859-4','iso-8859-5','iso-8859-15');
  ResArray: array[0..10] of Word = (1251,65001,65001,1252,20866,28591,28592,28593,
  28594,28595,28605);

var CharSet:string;
begin
  Result:=Pos('charset=',Data);   
  CharSet:=Copy(Data, Result,(PosEx('>',Data,Result)-Result));
  if Result > 0 then
    for Result := Length(CodePages)-1 downto 1 do
      if Pos(CodePages[Result],CharSet) > 0 then
        Break;
  Result := ResArray[Result];
end;