UDF под Windows 2003 терминал

library T2lib;
uses
  SysUtils,
  Windows,
  Messages,
  math;

const
// Чтобы не было проблем с распознаванием кодировок на разных платформах
  rus_chars:pChar = #197#210#211#206#208#192#205#202#213#209
                +#194#204#229#243#232#238#240#224#234#245#241#236;
  lat_chars:pChar = 'ETYOPAHKXCBMeyuopakxcm';
  small_chars:pChar =
#113#119#101#114#116#121#117#105#111#112#97#115#100#102#103
+#104#106#107#108#122#120#99#118#98#110#109#233#246#243#234
+#229#237#227#248#249#231#245#250#244#251#226#224#239#240#238
+#235#228#230#253#255#247#241#236#232#242#252#225#254#184;
  cap_chars:pChar =
#81#87#69#82#84#89#85#73#79#80#65#83#68#70#71#72#74#75#76#90
+#88#67#86#66#78#77#201#214#211#202#197#205#195#216#217#199
+#213#218#212#219#194#192#207#208#206#203#196#198#221#223#215
+#209#204#200#210#220#193#222#168;
   cp1251:pChar =
#233#246#243#234#229#237#227#248#249#231#245#250#244#251#226
+#224#239#240#238#235#228#230#253#255#247#241#236#232#242#252
+#225#254#184#201#214#211#202#197#205#195#216#217#199#213#218
+#212#219#194#192#207#208#206#203#196#198#221#223#215#209#204
+#200#210#220#193#222#168;
   cp866:pChar =
#169#230#227#170#165#173#163#232#233#167#229#234#228#235#162
+#160#175#224#174#171#164#166#237#239#231#225#172#168#226#236
+#161#238#241#137#150#147#138#133#141#131#152#153#135#149#154
+#148#155#130#128#143#144#142#139#132#134#157#159#151#145#140
+#136#146#156#129#158#240;
    koi8:pChar =
 #202#195#213#203#197#206#199#219#221#218#200#223#198#217#215#193
+#208#210#207#204#196#214#220#209#222#211#205#201#212#216#194#192
+#163
+#234#227#245#235#229#238#231#251#253#250#232#255#230#249#247#225
+#240#242#239#236#228#246#252#241#254#243#237#233#244#248#226#224
+#179;

function IB_ROUND(var n:double;var t: smallint):DOUBLE;CDECL;
begin
  if t < 0.0 then
    Result := Int( n * IntPower(10, t) - 0.5000000000001) / IntPower(10, t)
  else
    Result := Int( n * IntPower(10, t) + 0.5000000000001) / IntPower(10, t);
end;

function IB_IIF_FLOAT(var L:integer; var A1 : double; var A2 : double):double;CDECL;
begin
  if (l=0) then result := A2
           else result := A1;
end;

function IB_IIF_INT(var L:integer; var A1 : integer; var A2 : integer):integer;CDECL;
begin
  if (l=0) then result := A2
           else result := A1;
end;

function IB_BIT_AND(var A1:integer; var A2:integer):integer;CDECL;
begin
  result := A1 and A2;
end;

function IB_BIT_OR(var A1:integer; var A2:integer):integer;CDECL;
begin
  result := A1 or A2;
end;

function IB_BIT_NOT(var A:integer):integer;CDECL;
begin
  result := not A;
end;

function IB_INT_LO(var A:LongRec):smallint;CDECL;
begin
  result := A.Lo;
end;

function IB_INT_HI(var A:LongRec):smallint;CDECL;
begin
  result := A.Hi;
end;

function IB_INT_SET(var int_HI:smallint; var int_LO:smallint):LongRec;CDECL;
begin
  result.Hi := int_HI;
  result.Lo := int_LO;
end;

function replace_it(CString: PChar;scr: PChar;dest: PChar):PChar;

var i,j:integer;
begin
  i:=0;
  while (CString[i]<>#0) do
  begin
    j:=0;
    while (scr[j]<>#0) do
    begin
       if CString[i]=scr[j]
       then
       begin
         CString[i]:=dest[j];
         Break;
       end;
       inc(j);
    end;
    inc(i);
  end;

  result:=CString;
end;

function latrus(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,lat_chars,rus_chars);
end;

function rupper(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,small_chars,cap_chars);
end;

function rlower(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,cap_chars,small_chars);
end;

function dos2win(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,cp866,cp1251);
end;

function win2dos(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,cp1251,cp866);
end;

function koi82win(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,koi8,cp1251);
end;

function koi82dos(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,koi8,cp866);
end;

function dos2koi8(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,cp866,koi8);
end;

function win2koi8(CString: PChar): PChar;stdcall;export;
begin
  result:=replace_it(CString,cp1251,koi8);
end;

function IB_Trunc(var d:double):Integer;CDECL;
begin
  Result := Trunc(d);
end;

function UDF_strcat(dest,source : pchar) : pchar; stdcall;export;
begin
  result:=strcat(dest,source);
end;

function RoundFloat(var Value, RoundPrecision: DOUBLE):DOUBLE;CDECL;
  const delta = 0.001;
  var x : Int64;
begin
  if Value > 0 then
    x := Trunc(Value/RoundPrecision*10 + delta) - Trunc(Value/RoundPrecision)*10
  else
    x := Trunc(Value/RoundPrecision*10 - delta) - Trunc(Value/RoundPrecision)*10;
  result := Round(Value/RoundPrecision) * RoundPrecision;
  if x = 5 then result := Trunc(Value/RoundPrecision + 1) * RoundPrecision;
end;

function IB_Pos(subs, source : pchar):integer;CDECL;
var l,i,j,k,PosSubs : integer;
begin
  PosSubs := 0;
  l := 0;
  while (subs[l] <> #0) do begin
    l := l + 1;
  end;

  i := 0;
  while (source[i] <> #0) do begin
    j := 0;
    k := i;
    while ((j < l) and (source[k] <> #0)) do begin
      if (subs[j] <> source[k]) then break;
      j := j + 1;
      k := k + 1;
    end;
    if (j = l) then begin
      PosSubs := i;
      break;
    end;
    i := i + 1;
  end;

  IB_Pos := PosSubs;
end;

exports
  IB_ROUND       index  1,

  IB_IIF_FLOAT   index  2,
  IB_IIF_INT     index  3,

  IB_BIT_AND     index  4,
  IB_BIT_OR      index  5,
  IB_BIT_NOT     index  6,

  IB_INT_HI      index  7,
  IB_INT_LO      index  8,
  IB_INT_SET     index  9,

  latrus         index  10,
// преобразование латинских бук, похожих на кирилличесике
// в кириллические 1251. Иногда надо при переделке существующих
// баз данных, в которых некоторые русские буквы по ошибке
// набраны латинницей

  rupper         index  11,   // перевод русских в верхний и нижний регистры
  rlower         index  12,

  dos2win        index  13, // перевод различных кодировок кириллицы
  win2dos        index  14,

  koi82win       index  15,
  koi82dos       index  16,

  dos2koi8       index  17,
  win2koi8       index  18,
  IB_Trunc       index  19,
  RoundFloat     index  20,
  IB_Pos         index  21;
begin
 IsMultiThread:=True;
end.