unit
PrintForm;
interface
uses SysUtils;
{Процедура, осуществляющая запись формы, определенной
пользователем.
Данные для заполнения этой формы берутся из архива
FormData.
FormFile - файл с шаблоном формы, оформленным особым образом
(см. файл printform.frm)
OutFile - файл, в котором будет
сохранена заполненная форма
Пример использования функции:
var
FormData: array [0..6] of String;
begin
FormData[1] := '03';
FormData[2] := 'Потники сушеные в контейнерах';
CharToOem(PChar(FormData[2]), PChar(FormData[2]));
FormData[3] := '10000'; FormData[4] := '9';
FormData[5] := '90000'; FormData[6] := '69,23';
PrnForm(FormData, 'D:\MyProg\Forms\fillform.frm',
'D:\MyProg\Forms\_out.frm');
end.
}
function
PrnForm(FormData: array of String; FormFile, OutFile: String):
Integer;
implementation
{Автор: Slava
Kostin}
{Возвращаемые значения:
0 - все в порядке
1 - не найден файл формы
2 - обнаружена неизвестная команда
3 - неверный числовой параметр
4 - некорректный символ выравнивания
-255 - произошла какая-то непонятная ошибка
}
function PrnForm(FormData: array of String;
FormFile, OutFile: String): Integer;
const COMMENT = ';'; //Символ
комментария
const INT_MASK = 0; //Внутренний (для функции) символ, считающийся
//маской. Шаблон формы не должен содержать
//ни одного символа с кодом, равным
INT_MASK.
const COMMANDS_QUANTITY = 3; //Количество обрабатываемых
команд
//Массив имен обрабатываемых команд в теле
шаблона формы:
const COMMANDS: array [0..COMMANDS_QUANTITY - 1] of
String = (
'!DEFINE',
'!FORM',
'!FIELD'
);
var frm_f, out_f: TextFile;
i, fld_idx: Integer;
isDigit: Boolean;
msg, str, param: String;
Mask: Char;
outform, flds: array of String;
align: array of Char;
//Функция, возвращающая подстроку строки str, заключенную
между
//последовательностями символов LeftDelim слева и RightDelim
справа
function GetWordLimited(str: String; LeftDelim,
RightDelim: String): String;
begin
Result := Copy(str, Pos(LeftDelim, str) + 1, LastDelimiter(RightDelim, str) - Pos(LeftDelim, str) -
1);
end;
//Данная
процедура заменяет текущие символы маски в строке str
//на внутренние символы
маски для дальнейшей обработки
procedure ReplaceMask(var
str: String; Mask: Char);
var i: Integer;
begin
for i := 1 to Length(str)
do
if str[i] = Mask then str[i] :=
Char(INT_MASK);
end;
//Центрирование строки str. Длина
строки, которая должна быть //получена, задается параметром w. function
CenterString(str: String; w: Integer): String;
var i:
Integer;
begin
Result := str;
if w <= Length(str) then Exit;
for i := 1 to (Trunc(w /
2)) do
begin
Insert(' ', str, 1);
str := str + ' ';
end;
if Length(str) > w then
SetLength(str, w);
Result := str;
end;
//Функция, осуществляющая выравнивание содержимого поля
//в
соответствии с типом выравнивания:
// L - по левому краю,
// R - по
правому краю,
// C - по центру
function
AlignField(fld_idx, w: Integer): String;
begin
Result := '';
if fld_idx >= Length(flds) then Exit;
case align[fld_idx] of
'L': Result := Format('%-' + IntToStr(w) + 's',
[flds[fld_idx]]);
'R': Result := Format('%' + IntToStr(w) + 's',
[flds[fld_idx]]);
'C': Result :=
CenterString(flds[fld_idx], w);
else Exception.Create('1');
end;
end;
//Данная
функция заменяет первую маску в строке на значение
//соответствующего поля.
Если строка не содержит маски,
//функция возвращает false. При успешной
замене - true
function PutOneField(var str:
String; fld_idx: Integer): Boolean;
var first, last:
Integer;
begin
Result := false;
first := Pos(Char(INT_MASK), str);
if (fld_idx >= Length(flds)) or (first = 0) then Exit;
last := first;
while (last < Length(str)) and (str[last] =
Char(INT_MASK)) do
Inc(last);
str := Copy(str, 1, first - 1) +
AlignField(fld_idx, last - first) +
Copy(str, last, Length(str) - last + 1);
Result := true;
end;
//Тело
основной функции
begin
Result := 0;
Mask := Char(INT_MASK);
try
if not FileExists(FormFile) then Exception.Create('1');
AssignFile(frm_f, FormFile);
Reset(frm_f);
AssignFile(out_f, OutFile);
if not FileExists(OutFile) then
Rewrite(out_f)
else
Append(out_f);
while not Eof(frm_f) do
begin
ReadLn(frm_f, str);
if Pos(COMMENT, str) <> 0
then //Обрубаем комментарии
SetLength(str, Pos(COMMENT, str) - 1);
str := Trim(str);
if Length(str) > 0 then
begin
i := 0;
while i < COMMANDS_QUANTITY do //Определение команды
begin
if UpperCase(Copy(str, 1,
Length(COMMANDS[i]))) = COMMANDS[i] then
Break;
Inc(i);
end;
param := '';
//Когда команда определена, совершаем
необходимые действия,
//выбор которых производится в зависимости от порядкового
//номера данной команды в массиве команд
case i of
0: begin //Обработка команды !DEFINE
param := UpperCase(Trim(Copy(str, Length(COMMANDS[i]) + 1, Pos('=', str) -
Length(COMMANDS[i]) - 1)));
if param = 'MASK'
then
Mask := GetWordLimited(str, '"', '"')[1];
end;
1: begin //Обработка команды !FORM
Delete(str, 1,
Length(COMMANDS[i]));
ReplaceMask(str, Mask);
SetLength(outform, Length(outform) + 1);
outform[Length(outform) - 1] :=
str;
end;
2: begin //Обработка команды !FIELD
Delete(str, 1,
Length(COMMANDS[i]));
SetLength(flds, Length(flds) + 1);
flds[Length(flds) - 1] :=
FormData[StrToInt(GetWordLimited(str, '[', ']'))];
SetLength(align, Length(align) + 1);
align[Length(align) - 1] :=
UpperCase(GetWordLimited(str, '(', ')'))[1];
end;
else Exception.Create('2'); //Если код команды не опознан - выходим с исключением
end;
end;
end;
//Шаблон формы и значения полей в том порядке,
в котором
//они встречаются в шаблоне, считаны целиком.
//Далее производится подстановка значений полей на места
масок
//в шаблоне формы и запись формы в выходной файл:
fld_idx := 0;
for i := 0 to
Length(outform) - 1 do
begin
while PutOneField(outform[i], fld_idx) do
Inc(fld_idx);
WriteLn(out_f, outform[i]);
end;
Close(out_f);
Close(frm_f);
except //Обработка ошибок, возникших
при работе функции
on E: EConvertError do //Ошибка
преобразования типов
begin
Result := 3;
end;
//Все остальные типы ошибок идентифицируются
по номеру.
//Функция по окончании работы возвращает номер ошибки
//(или 0, если в процессе работы не было ошибок)
on E: Exception do
begin
msg := String(E.Message);
isDigit := true;
for i := 1 to Length(msg)
do
if not (msg[i] in [Char('0')..Char('9')]) then
begin
isDigit := false;
Break;
end;
if not isDigit then
begin
Result := -255;
Exit;
end;
Result := StrToInt(msg);
end;
end;
end;
end. 
