Меню сайта
Мини-чат
Чтобы добавить сообщение, необходимо авторизоваться.
Главная » Статьи » Не стандартные примеры на Delphi » Базы Данных

Работа с индексами Clipper'а

Посылаю кое-что из своих наработок:

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
Категория: Базы Данных | Добавил: DelphiAiX (20.05.2012)
Просмотров: 286 | Рейтинг: 0.0/0
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]