//Можно ли код Delphi превратить в VBA Excel

[ocean_regata]

//оговорюсь сразу я не программер вопрос:
//есть код на делфи, можно ли его превратить в код ВБА, а то не хочется //эту ДЛЛ-ку подключать к Экселю

unit sik;

interface

procedure MyTestData(sData: string; var Ric: string);
procedure MyTestRic(var Ric: string);

implementation

uses SysUtils, Dialogs;

const
T2: array [0..127] of byte =
($06,$0C,$08,$04,$0F,$01,$09,$02,$0 A,$0E,$05,$07,$00,$0B,$03,$0D,
$05,$0F,$04,$0D,$00,$07,$0A,$03,$0E ,$0C,$01,$02,$08,$06,$0B,$09,
$0A,$08,$01,$0E,$0B,$02,$03,$00,$0F ,$06,$04,$09,$07,$0C,$05,$0D,
$07,$0F,$0A,$0B,$03,$01,$0D,$08,$04 ,$05,$0C,$09,$00,$0E,$02,$06,
$03,$0C,$07,$0E,$0D,$01,$05,$0F,$09 ,$04,$08,$02,$0B,$00,$06,$0A,
$09,$0E,$0B,$02,$0D,$00,$0C,$0F,$01 ,$06,$08,$04,$03,$0A,$07,$05,
$0C,$03,$06,$09,$05,$08,$0A,$02,$00 ,$0D,$0F,$07,$01,$0E,$0B,$04,
$0F,$09,$07,$08,$01,$0E,$04,$06,$0B ,$00,$0C,$02,$0D,$03,$0A,$05);

CharValue = '0123456789ABCDEFGHJKMNPRSTUVWXYZ';

var
T1: array[0..31] of byte;
Data: array[0..127] of byte;
WorkByte: array[0..7] of byte;
Kd8: integer;
M1: array[0..63] of byte;

function ConvertValue1(Value: longword): longword;
var
Bv: array [0..7] of byte;
I: integer;
Tv: longword;
Tb: byte;
begin
Tv := Value;
for I := 0 to 3 do
begin
Bv[0+(I*2)] := Tv and $0F;
Bv[1+(I*2)] := (Tv and $F0) shr 4;
Tv := Tv shr 8;
end;
for I := 0 to 7 do
begin
Tb := Bv[I];
Bv[I] := T2[Tb + (I * 16)];
end;
Tv := 0;
for I := 3 downto 0 do
begin
Tv := Tv shl 8;
Tv := Tv or Bv[0+(I*2)];
Tv := Tv or (Bv[1+(I*2)] shl 4);
end;
Result := Tv;
end;

function ConvertValue2(Value: longword): longword;
var
I: word;
Tv: longword;
begin
Tv := Value;
for I := 0 to 10 do
begin
if (Tv and $80000000) = 0 then
Tv := Tv + Tv
else
begin
Tv := Tv + Tv;
Tv := Tv or 1;
end;
end;
Result := Tv;
end;
procedure MyTestData(sData: string; var Ric: string);
var
Main, I, J: integer;
Ost, Temp: word;
V1, V2: longword;
B, C: byte;
begin
Ric := '000000000000000T';
FillChar(WorkByte, sizeof(WorkByte), 0);
FillChar(T1, sizeof(T1), $F0);

// Занесение фамилии, имени, отчетсва и даты рождения
// в массив заполненный пробелами. Длина массива должна
// быть 64 байта.
FillChar(Data, sizeof(Data), 32);
for I := 1 to Length(sData) do
Data[I - 1] := Ord(sData[I]);

B := Length(sData) div 32;
if (Length(sData) mod 32) <> 0 then B := B + 1;
// Проходим первую часть массива Data
for J := 1 to B do
begin
Ost := 0;
for I := 31 downto 0 do
begin
Temp := T1[I] + Data[I+((J-1)*32)] + Ost;
T1[I] := Temp and $FF;
if Temp > $FF then
Ost := 1
else
Ost := 0;
end;
end;

Kd8 := Length(sData) div 8;
if (Length(sData) mod 8) <> 0 then Kd8 := Kd8 + 1;

// Основной цикл заполнения рабочего массива
for Main := 0 to Kd8 - 1 do
begin
// Берем очередные 8 байт из массива Data и xorим
// их с рабочим массивом
for I := 0 to 7 do
WorkByte[i] := WorkByte[I] xor Data[I + (8 * Main)];

// Первый цикл генерации рабочего массива
for I := 0 to 7 do
begin
// Берем певые 4 байт из рабочего массива
V1 := WorkByte[0] + (WorkByte[1] shl 8) + (WorkByte[2] shl 16) + (WorkByte[3] shl 24);
// Берем очередные 4 байта из преобразованной строки
V2 := T1[0+(I*4)] + (T1[1+(I*4)] shl 8) + (T1[2+(I*4)] shl 16) + (T1[3+(I*4)] shl 24);
V1 := V1 + V2;
// Преобзразуем результат сложения
V1 := ConvertValue1(V1);
// Преобзразуем по другому способу
V1 := ConvertValue2(V1);
// Берем вторые 4 байта из рабочего массива
V2 := WorkByte[4] + (WorkByte[5] shl 8) + (WorkByte[6] shl 16) + (WorkByte[7] shl 24);
// Xorим результат и вторые 4 байта
V1 := V1 xor V2;
// Первый 4 байта в рабочем массиве сдвигаем на место вторых 4 байт
for J := 0 to 3 do
WorkByte[4 + J] := WorkByte[J];
// На место первых 4 байт заносим результат
WorkByte[0] := V1 and $FF;
WorkByte[1] := (V1 shr 8) and $FF;
WorkByte[2] := (V1 shr 16) and $FF;
WorkByte[3] := (V1 shr 24) and $FF;
end;

[ocean_regata]

//продолжение


// Данный цикл аналогичен первому
for I := 0 to 6 do
begin
V1 := WorkByte[0] + (WorkByte[1] shl 8) + (WorkByte[2] shl 16) + (WorkByte[3] shl 24);
V2 := T1[0+(I*4)] + (T1[1+(I*4)] shl 8) + (T1[2+(I*4)] shl 16) + (T1[3+(I*4)] shl 24);
V1 := V1 + V2;
V1 := ConvertValue1(V1);
V1 := ConvertValue2(V1);
V2 := WorkByte[4] + (WorkByte[5] shl 8) + (WorkByte[6] shl 16) + (WorkByte[7] shl 24);
V1 := V1 xor V2;
for J := 0 to 3 do
WorkByte[4 + J] := WorkByte[J];
WorkByte[0] := V1 and $FF;
WorkByte[1] := (V1 shr 8) and $FF;
WorkByte[2] := (V1 shr 16) and $FF;
WorkByte[3] := (V1 shr 24) and $FF;
end;

V1 := WorkByte[0] + (WorkByte[1] shl 8) + (WorkByte[2] shl 16) + (WorkByte[3] shl 24);
V2 := T1[28] + (T1[29] shl 8) + (T1[30] shl 16) + (T1[31] shl 24);
V1 := V1 + V2;
V1 := ConvertValue1(V1);
V1 := ConvertValue2(V1);
V2 := WorkByte[4] + (WorkByte[5] shl 8) + (WorkByte[6] shl 16) + (WorkByte[7] shl 24);
V1 := V1 xor V2;
WorkByte[4] := V1 and $FF;
WorkByte[5] := (V1 shr 8) and $FF;
WorkByte[6] := (V1 shr 16) and $FF;
WorkByte[7] := (V1 shr 24) and $FF;
end;

FillChar(M1, sizeof(M1), 0);
// Заполняем его битами из значений рабочего массива
for I := 0 to 7 do
begin
B := WorkByte[I];
C := $80;
for J := 0 to 7 do
begin
if (B and C) = 0 then
M1[J+(I*8)] := 0
else
M1[J+(I*8)] := 1;
C := C shr 1;
end;
end;

// Берем по 5 бит и получаем индекс в таблице символов.
// По этому индексу получаем символ.
for I := 0 to 11 do
begin
B := M1[0+(I*5)]+(M1[1+(I*5)] shl 1)+(M1[2+(I*5)] shl 2)+(M1[3+(I*5)] shl 3)+(M1[4+(I*5)] shl 4);
Ric[I+1] := CharValue[B+1];
end;
// Последний 13 символ состоит из 4 битов.
B := (M1[60] shl 1)+(M1[61] shl 2)+(M1[62] shl 3)+(M1[63] shl 4);

// Данный цикл подсчитывает количество единичных битов.
J := 0;
for I := 0 to 63 do
if M1[I] = 1 then J := J + 1;
// Выделяем первый бит из полученной суммы.
J := J and 1;
// Заносим его на место первого бита 13 символа.
B := B or J;
// Получаем последний символ.
Ric[13] := CharValue[B+1];
end;

Продолжение далее...

Продолжение
Код
procedure MyTestRic(var Ric: string);
var
I: integer;
V, F: longword;
begin
// Получаем сумму символов помноженных на позицию в строке.
F := 0;
for I := 1 to 15 do
begin
V := Ord(Ric[I]) * I;
F := F + V;
end;
// Выделяем остаток отделения на 31.
F := F mod 31;
// Заполняем контрольный символ.
Ric[16] := CharValue[F+1];
end;

end.


//Код для использования.

uses sik;

var
Data, Ric: string;

procedure TForm1.Button1Click(Sender: TObject);
begin
Data := Edit1.Text;
Ric := '000000000000000T';
MyTestData(Data, Ric);
MyTestRic(Ric);
Edit3.Text := Ric;
end;


//В Edit1 должен быть текст большими буквами вида
//ИВАНОВИВАНИВАНОВИЧ23091955
//То есть он родился 23 сентября 1955 года.

[ocean_regata]

код откопал здесь: http://bb.ct.kz/index.php?showtopic=...&#entry2753873

[KORN]

конечно можно, берешь первую функцию/процедуру и смотря что она делает переписываешь ее под VBA... все так портируется

[ocean_regata]

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!