UUE кодирование

//UUE кодирование
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtDlgs, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure Edit1DblClick(Sender: TObject);
    procedure Edit2DblClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const

  ssz = (High(Cardinal) - $F) div sizeof(byte);
  //эта константа используется при выделении памяти

  p: string = '0123456789ABCDEF';
  //эта константа используется функцией toanysys

  //выбор входного файла

procedure TForm1.Edit1DblClick(Sender: TObject);
begin

  if opendialog1.execute then
    edit1.text := opendialog1.filename;
end;

//выбор выходного (UUE) файла

procedure TForm1.Edit2DblClick(Sender: TObject);
begin

  if savedialog1.execute then
    edit2.text := savedialog1.filename;
end;

//выделение подстроки

function mid(s: string; fromc, toc: byte): string;
var
  s1: string;

  i: byte;
begin

  s1 := '';
  for i := fromc to toc do
    s1 := s1 + s[i];
  mid := s1;
end;

//перевод числа (a) из десятичной системы в другую
//с основанием (r)

function toanysys(a, r: byte): string;
var
  s,

  k: string;
  n,
    m,
    i: byte;
begin

  s := '';
  m := 1;
  while m <> 0 do
  begin
    m := a div r;
    n := a - m * r + 1;
    k := p[n];
    s := k + s;
    a := m;
  end;
  //добавляет незначащие нули
  for i := 1 to 8 - length(s) do
    s := '0' + s;
  toanysys := s;
end;

//перевод 6-разрядного числа из двоичной системы в десятичную
//двоичное число подставляется в виде строки символов

function frombin(s: string): byte;
var
  i,

  e,
    b: byte;
begin

  b := 0;
  for i := 1 to 6 do
  begin
    e := 1 shl (6 - i);
    if s[i] = '1' then
      b := b + e;
  end;
  frombin := b;
end;

//непосредственно кодирование
type
  tcoola = array[1..1] of byte;
  pcoola = ^tcoola;

procedure TForm1.Button1Click(Sender: TObject);
var
  inf: file of byte;

  ouf: textfile;
  uue: pcoola;
  b: array[1..4] of byte;
  bin,
    t: string;
  szf,
    oum,
    szl,
    szh,
    sxl,
    sxh,
    i,
    j: longint;
begin

{$I-}
  assignfile(inf, edit1.text); //входной файл
  reset(inf);
  szf := filesize(inf); //
  szh := (szf * 8) div 6; //
  if szf * 8 - szh * 6 = 0 then
    szl := 0
  else
    szl := 1; //
  getmem(uue, szh + szl); //выделение памяти
  oum := 1;
  while not (eof(inf)) do
  begin
    b[1] := 0;
    b[2] := 0;
    b[3] := 0;
    b[4] := 0;
    //чтение должно быть сделано посложнее,
    //дабы избежать "read beyond end of file"
    read(inf, b[1], b[2], b[3]);
    //читаем 3 байта из входного файла
    //и формируем "двоичную" строку
    bin := toanysys(b[1], 2) +
      toanysys(b[2], 2) +
      toanysys(b[3], 2);
    //разбиваем строку на куски по 6 бит и добавляем 32
    t := mid(bin, 19, 24);
    b[4] := frombin(t) + 32;
    t := mid(bin, 13, 18);
    b[3] := frombin(t) + 32;
    t := mid(bin, 07, 12);
    b[2] := frombin(t) + 32;
    t := mid(bin, 01, 06);
    b[1] := frombin(t) + 32;
    //запихиваем полученнные байты во временный массив
    uue[oum] := b[1];
    oum := oum + 1;
    uue[oum] := b[2];
    oum := oum + 1;
    uue[oum] := b[3];
    oum := oum + 1;
    uue[oum] := b[4];
    oum := oum + 1;
  end;
  //входной файл больше не нужен - закрываем его
  closefile(inf);
  //формируем выходной файл
  assignfile(ouf, edit2.text); //выходной файл
  rewrite(ouf);
  oum := 1;
  sxh := (szh + szl) div 60; //число строк в UUE файле
  sxl := (szh + szl) - sxh * 60;
  //заголовок UUE-файла
  writeln(ouf, 'begin 644 ' + extractfilename(edit1.text));
  //записываем строки в файл
  for i := 1 to sxh do
  begin
    write(ouf, 'M');
    // 'M' значит, что в строке 60 символов
    for j := 1 to 60 do
    begin
      write(ouf, chr(uue[oum]));
      oum := oum + 1;
    end;
    writeln(ouf);
  end;
  //записываем последнюю строку, которая
  //обычно короче 60 символов
  sxh := (sxl * 6) div 8;
  write(ouf, chr(sxh + 32));
  for i := 1 to sxl do
  begin
    write(ouf, chr(uue[oum]));
    oum := oum + 1;
  end;
  // "добиваем" строку незначащими символами
  for i := sxl + 1 to 60 do
    write(ouf, '`');
  //записываем последние строки файла
  writeln(ouf);
  writeln(ouf, '`');
  writeln(ouf, 'end');
  closefile(ouf);
  freemem(uue, szh + szl); //освобождаем память
  showmessage('DONE.'); //Готово. Забирайте!
end;

end.