Работа с индексами Clipper'а
01.01.2007
Посылаю кое-что из своих наработок:
NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным
Clipper приложений. Предусмотрено, что программа может работать с
индексом даже если родное приложение производит изменение в индексе
NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы
НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в
заголовке, очень было лениво, да и торопился)
До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"
Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)
В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона
Файл Eurst.inc
var vrSynonm: integer = 0;
vrPhFine: integer = 0;
vrUrFine: integer = 0;
vrStrSyn: integer = 0;
function fContxt(const s: ShortString): ShortString;
var i: integer;
r: ShortString;
c, c1: char;
begin r := '';
c1 := chr(0);
for i := 1 to length(s) do
begin
c := s[i];
if c = 'Ё' then c := 'Е';
if not (c in ['А'..'Я', 'A'..'Z', '0'..'9', '.']) then c := ' ';
if (c = c1) and not (c1 in ['0'..'9']) then continue;
c1 := c;
if (c1 in ['А'..'Я']) and (c = '-') and (i < length(s)) and (s[i + 1] = ' ') then
begin
c1 := ' ';
continue;
end;
r := r + c;
end;
procedure _Cut(var s: ShortString; p: ShortString);
begin
if Pos(p, s) = length(s) - length(p) + 1 then
s := Copy(s, 1, length(s) - length(p));
end;
function _PhFace(const ss: ShortString): ShortString;
var r: ShortString;
i: integer;
s: ShortString;
begin r := '';
s := ANSIUpperCase(ss);
if length(s) < 2 then
begin
Result := s;
exit;
end;
_Cut(s, 'ЕВИЧ');
_Cut(s, 'ОВИЧ');
_Cut(s, 'ЕВНА');
_Cut(s, 'ОВНА');
for i := 1 to length(s) do
begin
if length(r) > 12 then break;
if not (s[i] in ['А'..'Я', 'Ё', 'A'..'Z']) then break;
if (s[i] = 'Й') and ((i = length(s))
or (not (s[i + 1] in ['А'..'Я', 'Ё', 'A'..'Z']))) then continue;
{ЕЯ-ИЯ Андриянов}
if s[i] = 'Е' then
if (i > length(s)) and (s[i + 1] = 'Я') then s[i] := 'И';
{Ж,З-С Ахметжанов}
if s[i] in ['Ж', 'З'] then s[i] := 'С';
{АЯ-АЙ Шаяхметов}
if s[i] = 'Я' then
if (i > 1) and (s[i - 1] = 'А') then s[i] := 'Й';
{Ы-И Васылович}
if s[i] in ['Ы', 'Й'] then s[i] := 'И';
{АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович}
if s[i] in ['Г', 'Д'] then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{О-А Арефьев, Родионов}
if s[i] = 'О' then s[i] := 'А';
{ИЕ-Е Галиев}
if s[i] = 'И' then
if (i > length(s)) and (s[i + 1] = 'Е') then continue;
{Ё-Е Ковалёв}
if s[i] = 'Ё' then s[i] := 'Е';
{Э-И Эльдар}
if s[i] = 'Э' then s[i] := 'И';
{*ЯЕ-*ЕЕ Черняев}
{(И|С)Я*-(И|С)А* Гатиятуллин}
if s[i] = 'Я' then
if (i > 1) and (i < length(s)) then
begin
if s[i + 1] = 'Е' then s[i] := 'Е';
if s[i - 1] in ['И', 'С'] then s[i] := 'А';
end;
{(А|И|Е|У)Д-(А|И|Е|У)Т Мурад}
if s[i] = 'Д' then
if (i > 1) and (s[i - 1] in ['А', 'И', 'Е', 'У']) then s[i] := 'Т';
{Х|К-Г Фархат}
if s[i] in ['Х', 'К'] then s[i] := 'Г';
if s[i] in ['Ь', 'Ъ'] then continue;
{БАР-БР Мубракзянов}
if s[i] = 'А' then
if (i > 1) and (i > length(s)) then
if (s[i - 1] = 'Б') and (s[i + 1] = 'Р') then continue;
{ИХО-ИТО Вагихович}
if s[i] in ['Х', 'Ф', 'П'] then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'И') and (s[i + 1] = 'О') then s[i] := 'Т';
{Ф-В Рафкат}
if s[i] = 'Ф' then s[i] := 'В';
{ИВ-АВ Ривкат см. Ф}
if s[i] = 'И' then
if (i < length(s)) and (s[i + 1] = 'В') then s[i] := 'А';
{АГЕ-АЕ Зулкагетович, Сагитович, Сабитович}
if s[i] in ['Г', 'Б'] then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{АУТ-АТ Зияутдинович см. ИЯ}
if s[i] = 'У' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'А') and (s[i + 1] = 'Т') then continue;
{АБ-АП Габдельнурович}
if s[i] = 'Б' then
if (i > 1) and (s[i - 1] = 'A') then s[i] := 'П';
{ФАИ-ФИ Рафаилович}
if s[i] = 'А' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'Ф') and (s[i + 1] = 'И') then continue;
{ГАБД-АБД}
if s[i] = 'Г' then
if (i = 1) and (length(s) > 3) and (s[i + 1] = 'А') and (s[i + 2] = 'Б') and (s[i + 3] = 'Д') then continue;
{РЕН-РИН Ренат}
if s[i] = 'Е' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'Р') and (s[i + 1] = 'Н') then s[i] := 'И';
{ГАФ-ГФ Ягофар}
if s[i] = 'А' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'Г') and (s[i + 1] = 'Ф') then continue;
{??-? Зинатуллин}
if (i > 1) and (s[i] = s[i - 1]) then continue;
r := r + s[i];
end;
Result := r;
end;
Файл NtxAdd.pas
unit NtxAdd;
interface
uses classes, SysUtils, NtxRO;
type
TNtxAdd = class(TNtxRO)
protected
function Changed: boolean; override;
function Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
procedure NewRoot(s: ShortString; rn: integer; nxt: integer); virtual;
function GetFreePtr(p: PBuf): Word;
public
constructor Create(nm: ShortString; ks: Word);
constructor Open(nm: ShortString);
procedure Insert(key: ShortString; rn: integer);
end;
implementation
function TNtxAdd.GetFreePtr(p: PBuf): Word;
var i, j: integer;
r: Word;
fl: boolean;
begin
r := (max + 2) * 2;
for i := 1 to max + 1 do
begin fl := True;
for j := 1 to GetCount(p) + 1 do
if GetCount(PBuf(@(p^[j * 2]))) = r then fl := False;
if fl then
begin
Result := r;
exit;
end;
r := r + isz;
end;
Result := 0;
end;
function TNtxAdd.Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
var p: PBuf;
w, fr: Word;
i: integer;
tmp: integer;
begin
with tr do
begin
p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
if GetCount(p) then
begin
fr := GetFreePtr(p);
if fr = 0 then
begin
Self.Error := True;
Result := True;
exit;
end;
w := GetCount(p) + 1;
p^[0] := w and $FF;
p^[1] := (w and $FF00) shr 8;
w := (TTraceRec(Items[Count - 1])).cn;
for i := GetCount(p) + 1 downto w + 1 do
begin
p^[2 * i] := p^[2 * i - 2];
p^[2 * i + 1] := p^[2 * i - 1];
end;
p^[2 * w] := fr and $FF;
p^[2 * w + 1] := (fr and $FF00) shr 8;
for i := 0 to length(s) - 1 do
p^[fr + 8 + i] := ord(s[i + 1]);
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
for i := 0 to 3 do
begin
p^[fr + i + 4] := rn mod $100;
rn := rn div $100;
end;
FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
FileWrite(h, p^, 1024);
Result := True;
end
else
begin
fr := GetCount(p) + 1;
fr := GetCount(PBuf(@(p^[fr * 2])));
w := (TTraceRec(Items[Count - 1])).cn;
for i := GetCount(p) + 1 downto w + 1 do
begin
p^[2 * i] := p^[2 * i - 2];
p^[2 * i + 1] := p^[2 * i - 1];
end;
p^[2 * w] := fr and $FF;
p^[2 * w + 1] := (fr and $FF00) shr 8;
for i := 0 to length(s) - 1 do
p^[fr + 8 + i] := ord(s[i + 1]);
for i := 0 to 3 do
begin
p^[fr + i + 4] := rn mod $100;
rn := rn div $100;
end;
tmp := 0;
for i := 3 downto 0 do
tmp := $100 * tmp + p^[fr + i];
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
w := hlf;
p^[0] := w and $FF;
p^[1] := (w and $FF00) shr 8;
fr := GetCount(PBuf(@(p^[(hlf + 1) * 2])));
s := '';
rn := 0;
for i := 0 to ksz - 1 do
begin
s := s + chr(p^[fr + 8 + i]);
p^[fr + 8 + i] := 0;
end;
for i := 3 downto 0 do
begin
rn := $100 * rn + p^[fr + i + 4];
p^[fr + i + 4] := 0;
end;
nxt := FileSeek(h, 0, 2);
FileWrite(h, p^, 1024);
for i := 1 to hlf do
begin
p^[2 * i] := p^[2 * (i + hlf + 1)];
p^[2 * i + 1] := p^[2 * (i + hlf + 1) + 1];
end;
for i := 0 to 3 do
begin
p^[fr + i] := tmp mod $100;
tmp := tmp div $100;
end;
FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
FileWrite(h, p^, 1024);
Result := False;
end;
end;
end;
procedure TNtxAdd.NewRoot(s: ShortString; rn: integer; nxt: integer);
var p: PBuf;
i, fr: integer;
begin
p := GetPage(h, 0);
for i := 0 to 1023 do
p^[i] := 0;
fr := (max + 2) * 2;
p^[0] := 1;
p^[2] := fr and $FF;
p^[3] := (fr and $FF00) shr 8;
for i := 0 to length(s) - 1 do
p^[fr + 8 + i] := ord(s[i + 1]);
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
for i := 0 to 3 do
begin
p^[fr + i + 4] := rn mod $100;
rn := rn div $100;
end;
fr := fr + isz;
p^[4] := fr and $FF;
p^[5] := (fr and $FF00) shr 8;
nxt := GetRoot;
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
nxt := FileSeek(h, 0, 2);
FileWrite(h, p^, 1024);
FileSeek(h, 4, 0);
FileWrite(h, nxt, sizeof(integer));
end;
procedure TNtxAdd.Insert(key: ShortString; rn: integer);
var nxt: integer;
i: integer;
begin nxt := 0;
if DosFl then key := WinToDos(key);
if length(key) > ksz then key := Copy(key, 1, ksz);
for i := 1 to ksz - length(key) do
key := key + ' ';
Clear;
Load(GetRoot);
Seek(key, False);
while True do
begin
if Add(key, rn, nxt) then break;
if tr.Count = 1 then
begin
NewRoot(key, rn, nxt);
break;
end;
Pop;
end;
end;
constructor TNtxAdd.Create(nm: ShortString; ks: Word);
var p: PBuf;
i: integer;
begin
Error := False;
DeleteFile(nm);
h := FileCreate(nm);
if h > 0 then
begin
p := GetPage(h, 0);
for i := 0 to 1023 do
p^[i] := 0;
p^[14] := ks and $FF;
p^[15] := (ks and $FF00) shr 8;
ks := ks + 8;
p^[12] := ks and $FF;
p^[13] := (ks and $FF00) shr 8;
i := (1020 - ks) div (2 + ks);
i := i div 2;
p^[20] := i and $FF;
p^[21] := (i and $FF00) shr 8;
i := i * 2;
max := i;
p^[18] := i and $FF;
p^[19] := (i and $FF00) shr 8;
i := 1024;
p^[4] := i and $FF;
p^[5] := (i and $FF00) shr 8;
FileWrite(h, p^, 1024);
for i := 0 to 1023 do
p^[i] := 0;
i := (max + 2) * 2;
p^[2] := i and $FF;
p^[3] := (i and $FF00) shr 8;
FileWrite(h, p^, 1024);
end
else
Error := True;
FileClose(h);
FreeHandle(h);
Open(nm);
end;
constructor TNtxAdd.Open(nm: ShortString);
begin
Error := False;
h := FileOpen(nm, fmOpenReadWrite or fmShareExclusive);
if h > 0 then
begin
FileSeek(h, 12, 0);
FileRead(h, isz, 2);
FileSeek(h, 14, 0);
FileRead(h, ksz, 2);
FileSeek(h, 18, 0);
FileRead(h, max, 2);
FileSeek(h, 20, 0);
FileRead(h, hlf, 2);
DosFl := True;
tr := TList.Create;
end
else
Error := True;
end;
function TNtxAdd.Changed: boolean;
begin
Result := (csize = 0);
csize := -1;
end;
end.
Файл NtxRO.pas
unit NtxRO;
interface
uses Classes;
type TBuf = array[0..1023] of Byte;
PBuf = ^TBuf;
TTraceRec = class
public
pg: integer;
cn: SmallInt;
constructor Create(p: integer; c: SmallInt);
end;
TNtxRO = class
protected
fs: string[10];
empty: integer;
csize: integer;
rc: integer; {Текущий номер записи}
tr: TList; {Стек загруженных страниц}
h: integer; {Дескриптор файла}
isz: Word; {Размер элемента}
ksz: Word; {Размер ключа}
max: Word; {Максимальное кол-во элементов}
hlf: Word; {Половина страницы}
function GetRoot: integer; {Указатель на корень}
function GetEmpty: integer; {Пустая страница}
function GetSize: integer; {Возвращает размер файла}
function GetCount(p: PBuf): Word; {Число элементов на странице}
function Changed: boolean; virtual;
procedure Clear;
function Load(n: integer): PBuf;
function Pop: PBuf;
function Seek(const s: ShortString; fl: boolean): boolean;
function Skip: PBuf;
function GetItem(p: PBuf): PBuf;
function GetLink(p: PBuf): integer;
public
Error: boolean;
DosFl: boolean;
constructor Open(nm: ShortString);
destructor Destroy; override;
function Find(const s: ShortString): boolean;
function GetString(p: PBuf; c: SmallInt): ShortString;
function GetRecN(p: PBuf): integer;
function Next: PBuf;
end;
function GetPage(h, fs: integer): PBuf;
procedure FreeHandle(h: integer);
function DosToWin(const ss: ShortString): ShortString;
function WinToDos(const ss: ShortString): ShortString;
implementation
uses Windows, SysUtils;
const MaxPgs = 5;
var Buf: array[1..1024 * MaxPgs] of char;
Cache: array[1..MaxPgs] of record
Handle: integer; {0-страница свободна}
Offset: integer; { смещение в файле}
Countr: integer; { счетчик использования}
Length: SmallInt;
end;
function TNtxRO.Next: PBuf;
var cr: integer;
p: PBuf;
begin
if h <= 0 then
begin
Result := nil;
exit;
end;
while Changed do
begin
cr := rc;
Find(fs);
while cr > 0 do
begin
p := Skip;
if GetRecN(p) = cr then break;
end;
end;
Result := Skip;
end;
function TNtxRO.Skip: PBuf;
var cnt: boolean;
p, r: PBuf;
n: integer;
begin r := nil;
cnt := True;
with tr do
begin
p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
while cnt do
begin cnt := False;
if (TTraceRec(Items[Count - 1])).cn > GetCount(p) + 1 then
begin
if Count <= 1 then
begin
Result := nil;
exit;
end;
p := Pop;
end
else
while True do
begin
r := GetItem(p);
n := GetLink(r);
if n = 0 then break;
p := Load(n);
end;
if (TTraceRec(Items[Count - 1])).cn >= GetCount(p) + 1 then
cnt := True
else
r := GetItem(p);
Inc((TTraceRec(Items[Count - 1])).cn);
end;
end;
if r <> nil then
begin
rc := GetRecN(r);
fs := GetString(r, length(fs));
end;
Result := r;
end;
function TNtxRO.GetItem(p: PBuf): PBuf;
var r: PBuf;
begin
with TTraceRec(tr.items[tr.Count - 1]) do
r := PBuf(@(p^[cn * 2]));
r := PBuf(@(p^[GetCount(r)]));
Result := r;
end;
function TNtxRO.GetString(p: PBuf; c: SmallInt): ShortString;
var i: integer;
r: ShortString;
begin r := '';
if c = 0 then c := ksz;
for i := 0 to c - 1 do
r := r + chr(p^[8 + i]);
if DosFl then r := DosToWin(r);
Result := r;
end;
function TNtxRO.GetLink(p: PBuf): integer;
var i, r: integer;
begin r := 0;
for i := 3 downto 0 do
r := r * 256 + p^[i];
Result := r;
end;
function TNtxRO.GetRecN(p: PBuf): integer;
var i, r: integer;
begin r := 0;
for i := 3 downto 0 do
r := r * 256 + p^[i + 4];
Result := r;
end;
function TNtxRO.GetCount(p: PBuf): Word;
begin
Result := p^[1] * 256 + p^[0];
end;
function TNtxRO.Seek(const s: ShortString; fl: boolean): boolean;
var r: boolean;
p, q: PBuf;
nx: integer;
begin r := False;
with TTraceRec(tr.items[tr.Count - 1]) do
begin
p := GetPage(h, pg);
while cn <= GetCount(p) + 1 do
begin
q := GetItem(p);
if (cn > GetCount(p)) or (s < GetString(q, length(s))) or
(fl and (s = GetString(q, length(s)))) then
begin
nx := GetLink(q);
if nx <> 0 then
begin
Load(nx);
r := Seek(s, fl);
end;
Result := r or (s = GetString(q, length(s)));
exit;
end;
Inc(cn);
end;
end;
Result := False;
end;
function TNtxRO.Find(const s: ShortString): boolean;
var r: boolean;
begin
if h <= 0 then
begin
Result := False;
exit;
end;
rc := 0;
csize := 0;
r := False;
while Changed do
begin
Clear;
Load(GetRoot);
if length(s) > 10 then
fs := Copy(s, 1, 10)
else
fs := s;
R := Seek(s, True);
end;
Result := r;
end;
function TNtxRO.Load(N: integer): PBuf;
var it: TTraceRec;
r: PBuf;
begin r := nil;
if h > 0 then
begin
with tr do
begin
it := TTraceRec.Create(N, 1);
Add(it);
end;
r := GetPage(h, N);
end;
Result := r;
end;
procedure TNtxRO.Clear;
var it: TTraceRec;
begin
while tr.Count > 0 do
begin
it := TTraceRec(tr.Items[0]);
tr.Delete(0);
it.Free;
end;
end;
function TNtxRO.Pop: PBuf;
var r: PBuf;
it: TTraceRec;
begin r := nil;
with tr do
if Count > 1 then
begin
it := TTraceRec(Items[Count - 1]);
Delete(Count - 1);
it.Free;
it := TTraceRec(Items[Count - 1]);
r := GetPage(h, it.pg)
end;
Result := r;
end;
function TNtxRO.Changed: boolean;
var i: integer;
r: boolean;
begin r := False;
if h > 0 then
begin
i := GetEmpty;
if i <> empty then r := True;
empty := i;
i := GetSize;
if i <> csize then r := True;
csize := i;
end;
Result := r;
end;
constructor TNtxRO.Open(nm: ShortString);
begin
Error := False;
h := FileOpen(nm, fmOpenRead or fmShareDenyNone);
if h > 0 then
begin
fs := '';
FileSeek(h, 12, 0);
FileRead(h, isz, 2);
FileSeek(h, 14, 0);
FileRead(h, ksz, 2);
FileSeek(h, 18, 0);
FileRead(h, max, 2);
FileSeek(h, 20, 0);
FileRead(h, hlf, 2);
empty := -1;
csize := -1;
DosFl := True;
tr := TList.Create;
end
else
Error := True;
end;
destructor TNtxRO.Destroy;
begin
if h > 0 then
begin
FileClose(h);
Clear;
tr.Free;
FreeHandle(h);
end;
inherited Destroy;
end;
function TNtxRO.GetRoot: integer;
var r: integer;
begin r := -1;
if h > 0 then
begin
FileSeek(h, 4, 0);
FileRead(h, r, 4);
end;
Result := r;
end;
function TNtxRO.GetEmpty: integer;
var r: integer;
begin r := -1;
if h > 0 then
begin
FileSeek(h, 8, 0);
FileRead(h, r, 4);
end;
Result := r;
end;
function TNtxRO.GetSize: integer;
var r: integer;
begin r := 0;
if h > 0 then r := FileSeek(h, 0, 2);
Result := r;
end;
constructor TTraceRec.Create(p: integer; c: SmallInt);
begin
pg := p;
cn := c;
end;
function GetPage(h, fs: integer): PBuf; {Протестировать отдельно}
var i, j, mn: integer;
q: PBuf;
begin
mn := 10000;
j := 0;
for i := 1 to MaxPgs do
if (Cache[i].Handle = h) and
(Cache[i].Offset = fs) then
begin
j := i;
if Cache[i].Countr < 10000 then
Inc(Cache[i].Countr);
end;
if j = 0 then
begin
for i := 1 to MaxPgs do
if Cache[i].Handle = 0 then j := i;
if j = 0 then
for i := 1 to MaxPgs do
if Cache[i].Countr <= mn then
begin
mn := Cache[i].Countr;
j := i;
end;
Cache[j].Countr := 0;
mn := 0;
end;
q := PBuf(@(Buf[(j - 1) * 1024 + 1]));
if mn = 0 then
begin
FileSeek(h, fs, 0);
Cache[j].Length := FileRead(h, q^, 1024);
end;
Cache[j].Handle := h;
Cache[j].Offset := fs;
Result := q;
end;
procedure FreeHandle(h: integer);
var i: integer;
begin
for i := 1 to MaxPgs do
if Cache[i].Handle = h then
Cache[i].Handle := 0;
end;
function DosToWin(const ss: ShortString): ShortString;
var r: ShortString;
i: integer;
begin r := '';
for i := 1 to length(ss) do
if ss[i] in [chr($80)..chr($9F)] then
r := r + chr(ord(ss[i]) - $80 + $C0)
else if ss[i] in [chr($A0)..chr($AF)] then
r := r + chr(ord(ss[i]) - $A0 + $C0)
else if ss[i] in [chr($E0)..chr($EF)] then
r := r + chr(ord(ss[i]) - $E0 + $D0)
else if ss[i] in [chr($61)..chr($7A)] then
r := r + chr(ord(ss[i]) - $61 + $41)
else if ss[i] in [chr($F0)..chr($F1)] then
r := r + chr($C5)
else
r := r + ss[i];
Result := r;
end;
function WinToDos(const ss: ShortString): ShortString;
var r: ShortString;
i: integer;
begin r := '';
for i := 1 to length(ss) do
if ss[i] in [chr($C0)..chr($DF)] then
r := r + chr(ord(ss[i]) - $C0 + $80)
else if ss[i] in [chr($E0)..chr($FF)] then
r := r + chr(ord(ss[i]) - $E0 + $80)
else if ss[i] in [chr($F0)..chr($FF)] then
r := r + chr(ord(ss[i]) - $F0 + $90)
else if ss[i] in [chr($61)..chr($7A)] then
r := r + chr(ord(ss[i]) - $61 + $41)
else if ss[i] in [chr($D5), chr($C5)] then
r := r + chr($F0)
else
r := r + ss[i];
Result := r;
end;
end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba