Автор: Alx2
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование Unicode строк в DFM файлах Delphi 6 в Ansi строки.

При попытке открыть проект созданный в Delphi 6 из Delphi 5 возникает
проблема с чтением DFM-файла. Проблема заключается в том, что Delphi5
не может прочитать строки, записанные в формате Unicode (WideString).

Данная функция переводит строки из DFM файла в формат ANSI, после чего
DFM файл читается в D5. Но при этом может возникнуть проблема, связанная
с незнакомыми для D5 свойствами компонентов, которая, в свою очередь,
решается игнорированием этих свойств.

Зависимости: Classes
Автор:       Радионов Алексей (Alx2), alx@argo.mv.ru, ICQ:113442587, Ульяновск
Copyright:   Alx2
Дата:        31 мая 2002 г.
***************************************************** }

procedure RemoveUnicodeFromDFM(const Filename: string);
  function isChanges(const S: string; var Res: string): Boolean;
  var
    len: Integer;
    function LexemSharp(var K: Integer): Boolean;
    begin
      Result := (K < len) and (S[K] = '#');
      if Result then
      begin
        inc(K);
        while (K <= len) and (S[K] in ['0'..'9']) do
          inc(K);
      end;
    end;
    function LexemAp(var K: Integer): Boolean;
    begin
      Result := (K < len) and (S[K] = '''');
      if Result then
      begin
        inc(K);
        while (K <= len) and (S[K] <> '''') do
          inc(K);
        if K <= len then
          inc(K);
      end;
    end;

    function Lexem(var K: Integer; var Str: string): Boolean;
    var
      Start: Integer;
      ValS: string;
    begin
      Result := False;
      Start := K;
      if LexemSharp(K) then
      begin
        ValS := Copy(S, Start + 1, K - Start - 1);
        Str := WideChar(StrToInt(ValS));
        Result := True;
      end
      else if LexemAp(K) then
      begin
        Str := Copy(S, Start + 1, K - Start - 2);
        Result := True;
      end;
    end;

    function Prepare(var K: Integer): string;
    var
      Str: string;
      WasLexem: Boolean;
    begin
      Result := '';
      WasLexem := False;
      while Lexem(K, Str) do
      begin
        Result := Result + Str;
        WasLexem := True;
      end;
      if Result <> '' then
        Result := '''' + Result + '''' + Copy(S, K, Length(S))
      else if not WasLexem then
        Result := S
      else
        Result := '''''';
    end;
    function Min(A, B: Integer): Integer;
    begin
      if A = 0 then
        Result := B
      else if B = 0 then
        Result := A
      else if A > B then
        Result := B
      else
        Result := A;
    end;

  var
    StartIdx: Integer;
  begin
    Result := False;
    StartIdx := Min(Pos('#', S), Pos('''', S));
    if StartIdx > 0 then
    begin
      len := Length(S);
      while (StartIdx <= len) and (not (S[StartIdx] in ['#', ''''])) do
        inc(StartIdx);
      if StartIdx < len then
      begin
        Res := Copy(S, 1, StartIdx - 1) + Prepare(StartIdx);
        Result := True;
      end;
    end;
  end;

var
  SList: TStringList;
  K: Integer;
  Res: string;
begin
  SList := TStringList.Create;
  try
    SList.LOADFROMFILE(Filename);
    for K := 0 to SList.Count - 1 do
      if isChanges(SList[K], Res) then
        SList[K] := Res;
    SList.SaveToFile(Filename);
  finally
    SList.Free;
  end;
end;

Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
var
  K: Integer;
begin
  if OpenDialog1.Execute then
    for K := 0 to OpenDialog1.Files.Count - 1 do
      RemoveUnicodeFromDFM(OpenDialog1.Files[K]);
end;