﻿# PIVOVAR11 — AI context / технический паспорт проекта

**Назначение файла:** сохранить полный рабочий контекст проекта Access/VBA «Пивовар», чтобы через длительное время можно было загрузить этот файл вместе с базой `ПИВОВАР11.accdb` и продолжить модернизацию без восстановления истории переписки.

**Файл базы:** `ПИВОВАР11.accdb`  
**Размер ACCDB:** `15695872` байт  
**SHA256 ACCDB на момент создания паспорта:** `f5811c2cf7537c7bb16365033365453cdf9d3b19f760bb7eab859eb044287cb8`  
**Дата создания паспорта:** 2026-06-09 19:15:22

> Важное правило: фактическое состояние базы при будущей работе нужно проверять по загруженному ACCDB. Этот файл является архитектурной картой, контекстом решений, описанием логики и страховочным снимком кода.

---

## 1. Как использовать этот файл через год

1. Загрузить в ChatGPT/AI:
   - актуальный файл базы `.accdb`;
   - этот файл `PIVOVAR11_AI_CONTEXT_FOR_FUTURE.md`;
   - при наличии — ZIP `PIVOVAR11_AI_HANDOFF_BUNDLE.zip`.
2. Дать такой запрос:

```text
Ты работаешь с проектом Microsoft Access/VBA «Пивовар» / «ХАЛТУРА».
Я загрузил(а) ACCDB-файл базы и контекстный файл `PIVOVAR11_AI_CONTEXT_FOR_FUTURE.md`.
Сначала прочитай контекстный файл целиком и считай его исходной документацией проекта.
Затем проанализируй текущую ACCDB как фактическое состояние базы.
Если между ACCDB и документацией есть расхождения, считай ACCDB источником факта, но используй документацию для понимания архитектуры, бизнес-логики, договоренностей, терминов и анти-регрессионных правил.
Не предлагай переписывать приложение с нуля без отдельной причины.
Работай итерационно: сначала диагностика и план, потом конкретные изменения в VBA/формах/таблицах/запросах.

```

3. Сначала попросить AI:
   - сверить фактические объекты ACCDB с этим паспортом;
   - найти расхождения;
   - предложить план изменений;
   - только потом менять VBA/SQL/структуру.

---

## 2. Суть проекта

`Пивовар` — Microsoft Access/VBA-приложение для учета движения пива на мини-пивоварне.

Главная технологическая цепочка:

```text
Варка -> ЦКТ -> Форфас -> Розлив -> Журналы -> Отчеты
```

Приложение ведет:
- факт варки;
- отправку объема в ЦКТ;
- состояние ЦКТ и форфасов;
- движения между емкостями;
- фильтрацию и потери;
- розлив в универсальную тару;
- корректировки объемов;
- журналы и Excel-отчеты;
- лицензионное ограничение Alpha-версии.

---

## 3. Главные термины

### Номер варки

Факт приготовления продукта на варке. Отвечает на вопрос: **когда и какая варка была произведена**.

### Номер брожения

Главный учетный идентификатор партии после отправки продукта в ЦКТ.

Простое объяснение для заказчика:

> Номер брожения — это паспорт партии пива. Емкость может меняться: ЦКТ, форфас, розлив, но номер брожения остается с продуктом и позволяет восстановить всю историю движения партии.

Используется для:
- текущего состояния емкостей;
- журналов движения;
- сверки остатков;
- отчетов по партиям;
- контроля розлива;
- контроля потерь.

### Емкость

Универсальный объект хранения продукта: ЦКТ или форфас. Хранится в `tЕмкости`.

### Текущее состояние емкости

Оперативный снимок: сколько литров в емкости, какой номер брожения, сорт, дата, занятость. Хранится в `tСостояниеЕмкостей`.

### Журнал движения

Историческая запись операции. После первичной отправки Варка -> ЦКТ все основные операции пишутся в `tДвиженияЕмкостей`.

---

## 4. Принципы архитектуры

| Принцип | Описание |
| --- | --- |
| Единая модель емкостей | ЦКТ и форфасы учитываются через справочник tЕмкости и текущее состояние tСостояниеЕмкостей. Это лучше, чем отдельная логика под каждую емкость. |
| Журнал операций плюс текущее состояние | История фиксируется в журналах tИсточникиЦКТ и tДвиженияЕмкостей. Панели работают по tСостояниеЕмкостей. Журнал нужен для аудита, состояние - для оперативной работы. |
| Номер брожения как паспорт партии | Номер брожения сопровождает продукт от ЦКТ до форфаса и розлива. По нему можно собрать историю партии, остатки, потери и розлив. |
| Одна операция розлива - один вид тары | Если партия разливается в разные виды тары, это фиксируется отдельными операциями. Так отчеты по таре остаются однозначными. |
| Мягкая очистка рабочих данных | Служебная очистка должна удалять/обнулять рабочие движения и состояния, но не справочники рецептов, тары и емкостей. |
| Лицензия блокирует действия, а не данные | При окончании лицензии данные не удаляются. Блокируются только управляющие элементы с Дополнительные сведения = RequiresLicense. |
| Dev и Prod должны быть раздельны | В Dev остаются исходники, генератор лицензий и служебные кнопки. В Prod опасные элементы удаляются, а база собирается в ACCDE. |

Дополнительные договоренности:

- Универсальная модель емкостей предпочтительнее отдельных таблиц под каждую емкость.
- ЦКТ и форфасы должны обслуживаться одной логикой через `Код емкости`.
- История операций не заменяется текущим состоянием: нужны и журнал, и состояние.
- Одна операция розлива — один вид тары.
- Если партия разливается в разные виды тары, создаются отдельные операции.
- Форфасов в текущей модели 2.
- Функциональность «перенос остатка котла» исключена/не используется.
- В Access/VBA строках операций не использовать Unicode-стрелки. Использовать обычные ASCII-обозначения.
- Большие VBA-модули желательно хранить отдельными `.bas/.txt` файлами.
- В Prod/ACCDE опасные dev-кнопки лучше удалить вручную, а Dev-версию оставить полной.

---

## 5. Бизнес-процесс

### 5.1 Варка

1. Пользователь создает/ведет запись варки.
2. Указывает дату, номер варки, рецепт, объемы.
3. Из формы `fВарка` объем отправляется в выбранный ЦКТ.
4. Первичная отправка фиксируется в `tИсточникиЦКТ`.
5. Обновляется `tСостояниеЕмкостей` для выбранного ЦКТ.

### 5.2 ЦКТ

Состояние ЦКТ отображается на `fЦКТ_Панель`.

Основные операции:
- ЦКТ -> Форфас после фильтрации;
- ЦКТ -> Розлив;
- корректировка ЦКТ;
- снятие дрожжей / дата снятия дрожжей.

Операции выполняются через `fОперацияЦКТ` и модуль `mVesselMovement`.

### 5.3 Форфас

Состояние форфасов отображается на `fФорфас_Панель`.

Основные операции:
- Форфас -> Розлив;
- корректировка форфаса.

Дата форфаса должна отражать дату первого наполнения текущего цикла, а не сбрасываться при каждой частичной операции.

### 5.4 Розлив

Розлив фиксируется как операция списания продукта в тару.

Правило:

```text
Одна операция розлива = один вид тары
```

Тара берется из справочника `tТара`.

### 5.5 Отчеты

Отчеты формируются в Excel через отдельные шаблоны из папки `Templates`, готовые файлы сохраняются в `Reports`.

---

## 6. Объекты базы

### 6.1 Таблицы

| Объект | Назначение | Ключевые поля | Роль в системе |
| --- | --- | --- | --- |
| tВарка | Учет факта варки: дата, номер варки, рецепт, вход/выход котла, текущая варка, признаки учета/брака. | Код; Номер варки; Дата варки; Рецепт; На входе в котел(л); На выходе из котла(л); Текущая варка; Учитывать; Брак; Комментарий | Стартовая точка партии. Из нее объем отправляется в ЦКТ. |
| tИсточникиЦКТ | Журнал первичного поступления продукта из варки в ЦКТ. | Код; Код варки; Номер варки; Дата операции; Код емкости приемника; Объем из источника(л); Сорт; Номер брожения; Тип операции; Отменена; Комментарий | Связывает варку и начальное брожение в ЦКТ. |
| tДвиженияЕмкостей | Универсальный журнал всех последующих движений: ЦКТ, фильтрация, форфас, розлив, корректировки. | Код; Дата операции; Этап операции; Тип операции; Код емкости источника; Код емкости приемника; Объем из источника(л); Объем в приемник(л); Потери(л); Номер брожения; Номера варок; Сорт; Код тары; Тип тары; Название тары; Количество тары; Объем единицы тары(л); Отменена; Комментарий | Главный исторический регистр после этапа Варка -> ЦКТ. |
| tЕмкости | Справочник технологических емкостей. | Код; Тип емкости; Номер емкости; Название; Максимальный объем(л); Активна | Позволяет работать с ЦКТ/форфасами через единую модель. |
| tСостояниеЕмкостей | Текущее состояние каждой емкости. | Код емкости; Объем(л); Номер брожения; Номера варок; Сорт; Дата; Дата последней варки; Снятие дрожжей; Дата снятия дрожжей; Занят | Используется для панелей состояния и оперативной работы. |
| tТара | Справочник тары для розлива. | Код; тип/название тары; объем единицы | Нужен для универсального розлива по видам тары. |
| tРецепт | Справочник рецептов. | Код; Имя рецепта; Единицы измерения параметра | Используется на форме варки и в отчетах по составу. |
| tСоставВарки | Состав/параметры рецепта. | Имя параметра рецепта; Единицы измерения параметра; Учитывать в расходе | Основа для блока состава рецепта. |
| tПараметр | Справочник параметров рецептов. | Имя/код параметра | Служебный справочник рецептурного блока. |
| tЕдиницыИзмерения | Справочник единиц измерения. | Единица измерения | Используется в рецептах и составе варки. |
| tAppLicense | Таблица активных/исторических лицензий. | Код; ProductName; LicenseType; MachineCode; LicenseKey; ExpireDate; CreatedDate; UpdatedDate; IsActive; Comment | Используется модулем mLicense. |
| tAppState | Служебное состояние приложения. | Код; StateName; StateValue; UpdatedDate; Comment | Хранит LastRunDate и другие служебные значения. |
| tЦКТ1..tЦКТ6 | Старые таблицы ЦКТ, оставшиеся в файле. | Зависит от старой версии | Скорее всего, legacy-совместимость. Перед удалением проверить зависимости. |

### 6.2 Запросы

| Группа запросов | Назначение |
| --- | --- |
| qЦКТ_ТекущееСостояние; qФорфас_ТекущееСостояние; qФорфасы_ТекущееСостояние; qЕмкости_ТекущееСостояние | Запросы текущего состояния емкостей для панелей. |
| qЦКТ_Журнал; qФорфас_Журнал; qИсточникиЦКТ_Журнал | Журналы технологических операций. |
| qПартии_Движение; qПартии_Свод; qПартии_Состояние; qПартии_ТекущиеОстатки; qПартии_СверкаОстатков | Отчеты и контроль партий по номеру брожения. |
| qРозлив_Свод; qРозлив_ИтогиПоПартиям; qРозлив_ИтогиПоСортам; qРозлив_ИтогиПоТаре; qРозлив_ИтогиПоИсточникам | Отчеты по розливу. |
| qФильтрация_Потери; qФильтрация_Потери_Итоги | Контроль потерь на фильтрации. |
| qРецепты_Список; qРецепты_Состав; qИменаРецепты; qСоставВарки_РасходИнгредиентов | Справочники и отчеты рецептурного блока. |
| qИсточникиЦКТ_ИтогоПоВарке; qИсточникиЦКТ_ИтогоПоВаркеИЕмкости | Итоги отправки объема из варки в ЦКТ. |

### 6.3 Формы

| Форма | Назначение |
| --- | --- |
| fГлавная | Основная оболочка приложения с вкладками. Содержит подформы Варка, ЦКТ, Форфасы, Отчеты, Справочники, Настройки. |
| fВарка | Ввод и сопровождение текущей варки, отправка объема в ЦКТ. |
| fЦКТ_Панель | Оперативная панель ЦКТ. |
| fОперацияЦКТ | Операции из ЦКТ: фильтрация в форфас, розлив, корректировка. |
| fЦКТ_Журнал | Журнал операций ЦКТ. |
| fФорфас_Панель | Оперативная панель форфасов. |
| fОперацияФорфас | Операции форфаса: розлив и корректировка. |
| fФорфас_Журнал | Журнал операций форфаса. |
| fОтчеты_Параметры | Параметры формирования Excel-отчетов. |
| fРецепт | Форма рецептов и состава варки. |
| fЖурнал_ДвижениеПродукта; fЖурнал_Розлив; fЖурнал_ФильтрацияПотери; fЖурнал_СверкаПартий | Общие журналы и контрольные формы. |
| fLicenseGenerator | Служебная форма генератора лицензий. В Prod-версии лучше удалить. |

### 6.4 Модули

| Модуль | Назначение |
| --- | --- |
| mBeerMovement | Логика этапа варки и первичной отправки объема в ЦКТ. |
| mVesselMovement | Основная бизнес-логика движения продукта между емкостями, розлива, корректировок и пересчета состояния. |
| mDatabaseMaintenance | Сервисные процедуры обслуживания и мягкой очистки рабочих данных. |
| mFormNavigation | Универсальная навигация, счетчики записей, вспомогательные процедуры форм. |
| mExcelReports | Формирование Excel-отчетов по шаблонам из папки Templates. |
| mLicense | Лицензирование Alpha: MachineCode, ключ, срок, защита от отката даты, блокировка RequiresLicense. |
| mAppShell | Alpha-оболочка Access: автозапуск fГлавная, скрытие стандартного интерфейса, настройки безопасности интерфейса. |
| mAlphaRelease | Служебные процедуры подготовки Alpha/Prod-копии. Для первого показа можно не использовать, если опасные кнопки удаляются вручную. |
| mPivovarLicenseGenerator | Служебный генератор ключей. Не должен передаваться заказчику в Prod/ACCDE. |

---

## 7. Главная форма `fГлавная`

`fГлавная` — основная оболочка приложения.

Ключевые элементы подформ:
- `subBrew` -> `fВарка`
- `subCctPanel` -> `fЦКТ_Панель`
- `subForfasPanel` -> `fФорфас_Панель`

Набор вкладок:
- `НаборВкладок0`

Рабочие вкладки:
- `Варка`
- `ЦКТ`
- `Форфасы`
- `Общие журналы`
- `Отчеты`
- `Справочники`
- `Настройки`
- `О программе`

Критичное анти-регрессионное правило:

```vb
RefreshBrewPanel должен вызывать RefreshEmbeddedForm(SUBFORM_BREW, "RefreshPanel")
```

После успешного вызова специального метода подформы `RefreshEmbeddedForm` не должен дополнительно делать `Requery`, иначе `fВарка` может сбрасываться на первую запись.

---

## 8. Форма `fВарка`

Критичная логика:
- при открытии должна переходить на последнюю варку;
- в режиме подформы внутри `fГлавная` нужен `RefreshPanel`;
- `GoToLastBrew` определяет последнюю запись по максимальному `[Номер варки]`, при равенстве — по максимальному `[Код]`;
- после успешной операции Варка -> ЦКТ вызывается обновление главной формы.

---

## 9. Логика движения продукта

Основной модуль: `mVesselMovement`.

Контракт:
- операции должны обновлять журнал и состояние;
- исторические записи пишутся в `tДвиженияЕмкостей`;
- текущее состояние пишется/пересчитывается в `tСостояниеЕмкостей`;
- отмененные операции должны учитываться аккуратно;
- мягкая очистка не должна удалять справочники.

Ключевые операции:
- ЦКТ -> Форфас;
- ЦКТ -> Розлив;
- Форфас -> Розлив;
- корректировка ЦКТ;
- корректировка форфаса;
- пересчет состояния емкостей.

---

## 10. Лицензирование Alpha

Модуль: `mLicense`.

Таблицы:
- `tAppLicense`
- `tAppState`

Кнопки/поля на вкладке `Настройки`:
- `txtLicenseStatus`
- `txtLicenseExpireDate`
- `txtMachineCode`
- `cmdCopyMachineCode`
- `cmdEnterLicenseKey`
- `cmdCheckLicense`

Dev-кнопки, которые не должны попадать в Prod:
- `cmdCreateAlphaTrialLicense`
- `cmdResetLicense`
- генератор лицензий;
- кнопки включения/возврата оболочки Access.

### 10.1 MachineCode

Формат:

```text
PV-XXXX-YYYY
```

Формируется по аппаратному отпечатку:
- имя компьютера;
- домен;
- Windows MachineGuid;
- BIOS serial;
- BaseBoard serial;
- VolumeSerialNumber диска C:.

### 10.2 Формат ключа

```text
PV1-ALPHA-YYYYMMDD-XXXX-YYYY-SIGNATURE
```

Где:
- `YYYYMMDD` — дата окончания;
- `XXXX-YYYY` — часть MachineCode;
- `SIGNATURE` — подпись.

### 10.3 Окончание лицензии

Когда лицензия закончится:
- кнопки с `Дополнительные сведения = RequiresLicense` блокируются;
- просмотр и ввод ключа остаются доступны;
- новый корректный ключ должен снова разблокировать кнопки без обязательного перезапуска.

Кнопки продления лицензии **нельзя** помечать `RequiresLicense`:
- `cmdCheckLicense`
- `cmdCopyMachineCode`
- `cmdEnterLicenseKey`

---

## 11. Alpha / Prod / Dev

Для первого показа заказчику принято простое решение:

### Dev-версия

Хранит:
- полный ACCDB;
- весь VBA;
- генератор лицензий;
- сброс лицензии;
- кнопки управления оболочкой;
- служебные формы.

### Prod-версия

Отдельная копия:
- опасные кнопки удаляются вручную;
- генератор лицензий удаляется;
- остается только ввод/проверка лицензии;
- собирается ACCDE.

Перед первым показом не обязательно отключать `AllowBypassKey` жестко. Строгий режим можно оставить на следующий этап.

---

## 12. Access security / доверенные расположения

Если при открытии ACCDE появляется предупреждение безопасности Microsoft Access, это не исправляется VBA-кодом.

Решение:
- добавить папку с приложением в доверенные расположения Access;
- либо снять блокировку Windows с файла, если он скачан/получен из архива.

Рекомендуемая папка для заказчика:

```text
C:\Pivovar
```

---

## 13. USysRibbons / скрытие Ribbon

Была попытка скрывать Ribbon через `USysRibbons` и `CustomRibbonID`.

Важное замечание:
- ошибочный XML с пустым `<tabs></tabs>` вызывает ошибку Access;
- если ошибка появилась, удалить запись:

```sql
DELETE FROM USysRibbons
WHERE RibbonName = 'PivovarHiddenRibbon';
```

Для первого показа безопаснее не усложнять, а:
- использовать ACCDE;
- скрыть область навигации;
- отключить полные меню;
- удалить опасные кнопки в Prod.

---

## 14. Отчеты Excel

Папки:
- `Templates` — шаблоны;
- `Reports` — готовые выгрузки.

Подход:
- отдельный шаблон Excel под каждый отчет;
- в готовом файле не должно быть пустых лишних листов;
- фильтры пишутся в отдельные ячейки, а не одной общей строкой.

---

## 15. Мягкая очистка

Модуль: `mDatabaseMaintenance`.

Назначение:
- очистить рабочие движения и состояния;
- не удалять справочники.

Не удалять:
- `tЕмкости`
- `tТара`
- `tРецепт`
- `tСоставВарки`

---

## 16. Legacy-объекты

В базе могут присутствовать старые объекты:
- `tЦКТ1..tЦКТ6`
- `fЦКТ1`
- старые поля кег.

Перед первым показом их лучше не удалять, если не проверены зависимости. Лучше скрыть из интерфейса и оставить до отдельной чистки.

---

## 17. Рекомендации по будущей модернизации

| Тема | Рекомендация |
| --- | --- |
| Перед первым показом | Собрать отдельную Prod-копию ACCDE; вручную удалить опасные кнопки; удалить генератор лицензий; оставить ввод/проверку лицензии. |
| Перед промышленной эксплуатацией | Разделить frontend/backend, если работать будут несколько пользователей или база будет лежать на сетевом ресурсе. |
| Для сопровождения | Вести версионирование ACCDB: Dev, Release Candidate, Prod. Для каждого релиза фиксировать список изменений. |
| Для качества данных | Не удалять legacy-объекты до проверки зависимостей. Лучше сначала пометить их как устаревшие и исключить из интерфейса. |
| Для документации | Дополнительно подготовить пользовательскую инструкцию: запуск, ввод лицензии, Варка -> ЦКТ -> Форфас -> Розлив, отчеты. |

Дополнительно:
- перед крупной доработкой делать копию ACCDB;
- вести версии: `Dev`, `Release Candidate`, `Prod`;
- выгружать VBA-модули в `.bas` перед изменениями;
- после изменения формы/модуля выполнять `Отладка -> Компилировать`;
- перед передачей заказчику делать ACCDE;
- если база станет многопользовательской, разделить frontend/backend.

---

## 18. Анти-регрессионный список

При любой будущей доработке проверить:

1. `fГлавная`:
   - вкладка Варка открывается на последней записи;
   - переходы на ЦКТ/Форфасы обновляют панели;
   - после операций подформы обновляются без переоткрытия базы.

2. `fВарка`:
   - не сбрасывается на первую запись;
   - `RefreshPanel` работает в режиме подформы.

3. `mLicense`:
   - истекшая лицензия блокирует только `RequiresLicense`;
   - ввод нового ключа разблокирует операции;
   - кнопки ввода/проверки лицензии не блокируются;
   - защита от отката даты не ломает обычный запуск.

4. `mVesselMovement`:
   - ЦКТ -> Форфас сохраняет дату первого наполнения форфаса;
   - розлив работает по одному виду тары за операцию;
   - корректировки не ломают остатки.

5. Отчеты:
   - шаблоны находятся в `Templates`;
   - выгрузки пишутся в `Reports`;
   - нет пустых лишних листов.

6. Prod:
   - генератор лицензий удален;
   - dev-кнопки удалены;
   - ACCDE открывается у заказчика из доверенной папки.

---

## 19. Рекомендуемый комплект будущего запроса к AI

Загрузить:
- `ПИВОВАР11.accdb` или актуальную версию базы;
- `PIVOVAR11_AI_CONTEXT_FOR_FUTURE.md`;
- если есть — `PIVOVAR11_AI_HANDOFF_BUNDLE.zip`.

Запрос:

```text
Ты работаешь с проектом Microsoft Access/VBA «Пивовар» / «ХАЛТУРА».
Я загрузил(а) ACCDB-файл базы и контекстный файл `PIVOVAR11_AI_CONTEXT_FOR_FUTURE.md`.
Сначала прочитай контекстный файл целиком и считай его исходной документацией проекта.
Затем проанализируй текущую ACCDB как фактическое состояние базы.
Если между ACCDB и документацией есть расхождения, считай ACCDB источником факта, но используй документацию для понимания архитектуры, бизнес-логики, договоренностей, терминов и анти-регрессионных правил.
Не предлагай переписывать приложение с нуля без отдельной причины.
Работай итерационно: сначала диагностика и план, потом конкретные изменения в VBA/формах/таблицах/запросах.

```

---

# Приложение A. Снимок VBA-кода

Назначение приложения:
- дать будущей AI-модели кодовый контекст даже если она не сможет извлечь VBA из ACCDB;
- сохранить последние известные версии ключевых модулей;
- отделить рекомендуемые финальные версии от экспериментальных.

> Важно: если фактический код в ACCDB отличается, при будущей работе считать ACCDB источником факта, а этот снимок — историческим ориентиром.

### fMain_Final_AlphaRelease_Full_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fГлавная — полная версия с лицензией, Alpha-оболочкой, delayed hide и кнопками Alpha Release. PersistentMode не считать обязательным.  
**SHA256:** `e97fbd7da4af58e367aa2c34d2e327bbb4f12e6d1be3896315798cba9dddaf84`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fГлавная
'
' Назначение:
'   Главная форма приложения "Пивовар".
'
' В этом коде:
'   - открытие общих журналов;
'   - мягкая очистка рабочих данных;
'   - автоматическое обновление встроенных рабочих форм:
'       fВарка;
'       fЦКТ_Панель;
'       fФорфас_Панель.
'
' Текущие имена элементов подчиненных форм на fГлавная:
'   subBrew
'   subCctPanel
'   subForfasPanel
'
' Текущее имя набора вкладок:
'   НаборВкладок0
'
' Рабочие вкладки:
'   Варка
'   ЦКТ
'   Форфасы
'
' Важно:
'   Имена SUBFORM_* должны совпадать именно с именами элементов
'   подчиненных форм на fГлавная, а не только с объектами-источниками.
' ============================================================


Private Const SUBFORM_BREW As String = "subBrew"
Private Const SUBFORM_CCT_PANEL As String = "subCctPanel"
Private Const SUBFORM_FORFAS_PANEL As String = "subForfasPanel"

Private Const MAIN_TAB_CONTROL As String = "НаборВкладок0"

Private Const TAB_BREW As String = "Варка"
Private Const TAB_CCT As String = "ЦКТ"
Private Const TAB_FORFAS As String = "Форфасы"
Private Const TAB_SETTINGS As String = "Настройки"

Private mLastMainAutoRefresh As Date
Private mShellHideRetryCount As Long


' ============================================================
' Alpha-оболочка Access / вкладка "Настройки"
'
' Поддерживаются имена кнопок как без хвостового "_",
' так и с хвостовым "_", потому что Access в этом случае
' создает обработчик с двойным "__Click".
' ============================================================

Private Sub cmdEnableAlphaShell_Click()
    Call DoEnableAlphaShell
End Sub

Private Sub cmdEnableAlphaShell__Click()
    Call DoEnableAlphaShell
End Sub

Private Sub cmdEnableAlphaShellStrict_Click()
    Call DoEnableAlphaShellStrict
End Sub

Private Sub cmdEnableAlphaShellStrict__Click()
    Call DoEnableAlphaShellStrict
End Sub

Private Sub cmdRestoreDeveloperShell_Click()
    Call DoRestoreDeveloperShell
End Sub

Private Sub cmdRestoreDeveloperShell__Click()
    Call DoRestoreDeveloperShell
End Sub

Private Sub cmdHideAccessInterface_Click()
    Call DoHideAccessInterface
End Sub

Private Sub cmdHideAccessInterface__Click()
    Call DoHideAccessInterface
End Sub

Private Sub cmdShowAccessInterface_Click()
    Call DoShowAccessInterface
End Sub

Private Sub cmdShowAccessInterface__Click()
    Call DoShowAccessInterface
End Sub

Private Sub cmdShowAlphaPackagingChecklist_Click()
    Call DoShowAlphaPackagingChecklist
End Sub

Private Sub cmdShowAlphaPackagingChecklist__Click()
    Call DoShowAlphaPackagingChecklist
End Sub


Private Sub DoEnableAlphaShell()

    Call ConfigurePivovarAlphaShell

End Sub


Private Sub DoEnableAlphaShellStrict()

    Call ConfigurePivovarAlphaShellStrict

End Sub


Private Sub DoRestoreDeveloperShell()

    Call RestorePivovarDeveloperShell

End Sub


Private Sub DoHideAccessInterface()

    Call HideAccessInterface

End Sub


Private Sub DoShowAccessInterface()

    Call ShowAccessInterface

End Sub


Private Sub DoShowAlphaPackagingChecklist()

    Call PreparePivovarAlphaAccdeChecklist

End Sub



' ============================================================
' Загрузка, активация и переключение вкладок
' ============================================================

Private Sub Form_Load()

    ' При открытии главной формы:
    '   1. инициализируем лицензионный блок;
    '   2. скрываем стандартный интерфейс Access;
    '   3. включаем отложенное повторное скрытие интерфейса;
    '   4. обновляем поля лицензии;
    '   5. привязываем событие вкладок;
    '   6. обновляем активную вкладку.
    '
    ' Почему нужен отложенный таймер:
    '   при автозапуске формы Access иногда дорисовывает Ribbon уже после
    '   Form_Load. Если вызвать HideAccessInterface только в Form_Load,
    '   часть меню может остаться видимой.
    '
    '   Кнопка "Скрыть интерфейс сейчас" работает, потому что к этому моменту
    '   интерфейс Access уже полностью загружен.
    '
    ' Поэтому при старте несколько раз повторяем HideAccessInterface
    ' через Form_Timer.

    Call InitializeLicenseSystem
    Call HideAccessInterface
    Call StartDelayedAccessInterfaceHide

    Call RefreshLicenseControls

    Call WireMainFormEvents
    Call RefreshSelectedMainTab("Form_Load")

End Sub

Private Sub Form_Activate()

    ' При возврате на главную форму после операций / журналов
    ' обновляем только текущую активную вкладку.
    '
    ' Дополнительно повторно скрываем интерфейс Access.
    ' Это защищает от ситуаций, когда Ribbon снова появляется
    ' после открытия/закрытия других окон Access.

    Call HideAccessInterface

    If DateDiff("s", mLastMainAutoRefresh, Now) < 1 Then
        Exit Sub
    End If

    mLastMainAutoRefresh = Now

    Call RefreshSelectedMainTab("Form_Activate")

End Sub

Private Sub НаборВкладок0_Change()

    ' Событие набора вкладок.
    '
    ' В свойствах элемента НаборВкладок0 должно быть:
    '   При изменении = [Процедура обработки событий]
    '
    ' При смене вкладки сбрасываем защиту от частого обновления,
    ' потому что это явное действие пользователя.

    mLastMainAutoRefresh = 0

    DoEvents

    Call RefreshSelectedMainTab("Tab_Change")

End Sub


Private Sub WireMainFormEvents()

    ' Принудительно привязывает событие смены вкладки.
    '
    ' В русской версии Access в свойствах будет отображаться:
    '   При изменении = [Процедура обработки событий]
    '
    ' В VBA нужно использовать английское значение:
    '   [Event Procedure]

    On Error Resume Next

    If ControlExists(MAIN_TAB_CONTROL) Then
        Me.Controls(MAIN_TAB_CONTROL).OnChange = "[Event Procedure]"
    End If

End Sub



Private Sub Form_Timer()

    ' Отложенное повторное скрытие стандартного интерфейса Access.
    '
    ' Нужен именно при автозапуске базы:
    ' Access может показать Ribbon уже после Form_Load формы fГлавная.
    '
    ' Делаем несколько повторов, затем выключаем таймер.

    On Error Resume Next

    mShellHideRetryCount = mShellHideRetryCount + 1

    Call HideAccessInterface

    If mShellHideRetryCount >= 6 Then
        Me.TimerInterval = 0
    End If

End Sub


Private Sub StartDelayedAccessInterfaceHide()

    ' Запускает короткий одноразово-многоразовый таймер скрытия интерфейса.
    '
    ' 6 повторов по 300 мс обычно достаточно, чтобы Access успел
    ' полностью загрузить интерфейс и после этого Ribbon был скрыт.

    On Error Resume Next

    mShellHideRetryCount = 0
    Me.TimerInterval = 300

End Sub


' ============================================================
' Открытие общих журналов
' ============================================================

Private Sub cmdOpenBatchCheckJournal_Click()

    Call OpenFormSafe("fЖурнал_СверкаПартий")

End Sub


Private Sub cmdOpenFillingJournal_Click()

    Call OpenFormSafe("fЖурнал_Розлив")

End Sub


Private Sub cmdOpenFiltrationLossesJournal_Click()

    Call OpenFormSafe("fЖурнал_ФильтрацияПотери")

End Sub


Private Sub cmdOpenProductMovementJournal_Click()

    Call OpenFormSafe("fЖурнал_ДвижениеПродукта")

End Sub


Private Sub OpenFormSafe(ByVal formName As String)

    ' Безопасно открывает форму.
    '
    ' Если форма уже открыта — переводит на нее фокус.

    On Error GoTo ErrorHandler

    If CurrentProject.AllForms(formName).IsLoaded Then

        DoCmd.SelectObject acForm, formName, False
        Forms(formName).SetFocus

    Else

        DoCmd.OpenForm formName, acNormal

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть форму:" & vbCrLf & _
           formName & vbCrLf & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Открытие формы"

End Sub


' ============================================================
' Мягкая очистка рабочих данных
' ============================================================

Private Sub cmdSoftClearDatabase_Click()

    ' Мягкая очистка рабочих данных:
    '   - варки;
    '   - отправки Варка - ЦКТ;
    '   - движения по емкостям;
    '   - текущее состояние емкостей.
    '
    ' Справочники не удаляются.
    '
    ' После очистки обновляем все встроенные рабочие формы.

    On Error GoTo ErrorHandler

    Call SoftClearWorkingData
    Call RefreshEmbeddedWorkingForms

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить мягкую очистку рабочих данных." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbCritical, _
           "Мягкая очистка"

End Sub


Private Sub cmdRefreshAll_Click()

    ' Ручное обновление всех встроенных рабочих форм.
    '
    ' Кнопка необязательная.
    ' Ее можно оставить на вкладке "Настройки" как служебную.

    Call RefreshEmbeddedWorkingForms

End Sub


' ============================================================
' Автообновление встроенных рабочих форм
' ============================================================

Public Sub RefreshEmbeddedWorkingForms()

    ' Полное обновление встроенных рабочих форм:
    '   - fВарка;
    '   - fЦКТ_Панель;
    '   - fФорфас_Панель.
    '
    ' После обновления заново применяем лицензионный режим,
    ' чтобы кнопки внутри подформ не включались случайно после Requery.

    Debug.Print "RefreshEmbeddedWorkingForms:", Now()

    Call RefreshBrewPanel
    Call RefreshCctPanelEmbedded
    Call RefreshForfasPanelEmbedded

    Call ApplyLicenseToForm(Me)

End Sub

Private Sub RefreshSelectedMainTab(Optional ByVal reason As String = "")

    ' Обновляет только активную рабочую вкладку.
    '
    ' Проверяем и Caption, и Name страницы вкладок,
    ' чтобы не зависеть от того, где именно задано:
    '   Варка
    '   ЦКТ
    '   Форфасы
    '   Настройки
    '
    ' После обновления активной вкладки повторно применяем лицензионный режим.
    ' Это важно для кнопок внутри подформ.

    On Error GoTo ErrorHandler

    Dim tabControl As Object
    Dim currentCaption As String
    Dim currentName As String

    If ControlExists(MAIN_TAB_CONTROL) = False Then
        Debug.Print "Не найден набор вкладок: " & MAIN_TAB_CONTROL
        Exit Sub
    End If

    Set tabControl = Me.Controls(MAIN_TAB_CONTROL)

    If GetCurrentTabPageInfo(tabControl, currentName, currentCaption) = False Then
        Debug.Print "Не удалось определить активную вкладку."
        Exit Sub
    End If

    Debug.Print "Активная вкладка:", _
                "Name=[" & currentName & "]", _
                "Caption=[" & currentCaption & "]", _
                "Reason=[" & reason & "]", _
                Now()

    If IsTabPage(currentName, currentCaption, TAB_BREW) Then

        Call RefreshBrewPanel

    ElseIf IsTabPage(currentName, currentCaption, TAB_CCT) Then

        Call RefreshCctPanelEmbedded

    ElseIf IsTabPage(currentName, currentCaption, TAB_FORFAS) Then

        Call RefreshForfasPanelEmbedded

    ElseIf IsTabPage(currentName, currentCaption, TAB_SETTINGS) Then

        Call RefreshLicenseControls

    Else

        ' Для вкладок "Общие журналы", "Отчеты", "Справочники",
        ' "О программе" автоматическое обновление рабочих форм не требуется.

    End If

    Call ApplyLicenseToForm(Me)

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка автообновления активной вкладки fГлавная: " & Err.Description

End Sub

Private Function GetCurrentTabPageInfo( _
    ByVal tabControl As Object, _
    ByRef pageName As String, _
    ByRef pageCaption As String _
) As Boolean

    ' Возвращает имя и подпись активной страницы набора вкладок.
    '
    ' Не полагаемся только на Pages(tabControl.Value), потому что
    ' в Access значение вкладки может быть связано с PageIndex.
    ' Поэтому дополнительно перебираем Pages.

    On Error GoTo ErrorHandler

    Dim pageItem As Object

    pageName = ""
    pageCaption = ""

    For Each pageItem In tabControl.Pages

        If CLng(pageItem.PageIndex) = CLng(tabControl.value) Then

            pageName = Nz(pageItem.Name, "")
            pageCaption = Nz(pageItem.Caption, "")

            GetCurrentTabPageInfo = True
            Exit Function

        End If

    Next pageItem

    ' Запасной вариант.
    pageName = Nz(tabControl.Pages(tabControl.value).Name, "")
    pageCaption = Nz(tabControl.Pages(tabControl.value).Caption, "")

    GetCurrentTabPageInfo = True

    Exit Function

ErrorHandler:

    GetCurrentTabPageInfo = False

End Function


Private Function IsTabPage( _
    ByVal pageName As String, _
    ByVal pageCaption As String, _
    ByVal expectedText As String _
) As Boolean

    ' Проверяет страницу вкладок по имени и подписи.
    '
    ' Сравнение сделано не только точным, но и через InStr,
    ' чтобы не ломаться от случайных пробелов или значков в подписи.

    Dim normalizedName As String
    Dim normalizedCaption As String
    Dim normalizedExpected As String

    normalizedName = NormalizeTabText(pageName)
    normalizedCaption = NormalizeTabText(pageCaption)
    normalizedExpected = NormalizeTabText(expectedText)

    If StrComp(normalizedName, normalizedExpected, vbTextCompare) = 0 Then
        IsTabPage = True
        Exit Function
    End If

    If StrComp(normalizedCaption, normalizedExpected, vbTextCompare) = 0 Then
        IsTabPage = True
        Exit Function
    End If

    If InStr(1, normalizedName, normalizedExpected, vbTextCompare) > 0 Then
        IsTabPage = True
        Exit Function
    End If

    If InStr(1, normalizedCaption, normalizedExpected, vbTextCompare) > 0 Then
        IsTabPage = True
        Exit Function
    End If

    IsTabPage = False

End Function


Private Function NormalizeTabText(ByVal sourceText As String) As String

    ' Нормализует текст вкладки для сравнения.

    Dim resultText As String

    resultText = Nz(sourceText, "")
    resultText = Replace(resultText, Chr$(160), " ")
    resultText = Trim$(resultText)

    NormalizeTabText = resultText

End Function


Private Sub RefreshBrewPanel()

    ' Обновляет встроенную форму Варка.
    '
    ' Для fВарка нельзя ограничиваться обычным Requery:
    ' в режиме подформы это может вернуть форму на первую запись.
    '
    ' Поэтому вызываем Public Sub RefreshPanel внутри fВарка,
    ' а там уже выполняется переход на последнюю варку.

    Call RefreshEmbeddedForm(SUBFORM_BREW, "RefreshPanel")

End Sub

Private Sub RefreshCctPanelEmbedded()

    ' Обновляет встроенную панель ЦКТ.
    '
    ' На форме fЦКТ_Панель должна быть процедура:
    '   Public Sub RefreshCctPanel()

    Call RefreshEmbeddedForm(SUBFORM_CCT_PANEL, "RefreshCctPanel")

End Sub


Private Sub RefreshForfasPanelEmbedded()

    ' Обновляет встроенную панель форфасов.
    '
    ' На форме fФорфас_Панель должна быть процедура:
    '   Public Sub RefreshForfasPanel()

    Call RefreshEmbeddedForm(SUBFORM_FORFAS_PANEL, "RefreshForfasPanel")

End Sub


Private Sub RefreshEmbeddedForm( _
    ByVal subformControlName As String, _
    ByVal refreshMethodName As String _
)

    ' Безопасно обновляет подчиненную форму.
    '
    ' Если refreshMethodName указан:
    '   1. пытаемся вызвать эту публичную процедуру внутри подформы;
    '   2. если не получилось — пытаемся вызвать универсальный RefreshPanel;
    '   3. если не получилось — выполняем стандартный Requery/Refresh.
    '
    ' Важно:
    '   После успешного вызова специального метода НЕ делаем дополнительный
    '   Requery из fГлавная.
    '
    ' Причина:
    '   Для fВарка метод RefreshPanel сам делает Requery и переходит
    '   на последнюю запись. Если после этого fГлавная снова выполнит
    '   Requery, подформа может вернуться на первую запись.

    On Error GoTo ErrorHandler

    If ControlExists(subformControlName) = False Then
        Debug.Print "Не найден элемент подчиненной формы: " & subformControlName
        Exit Sub
    End If

    If Nz(Me.Controls(subformControlName).SourceObject, "") = "" Then
        Debug.Print "У элемента подчиненной формы не задан SourceObject: " & subformControlName
        Exit Sub
    End If

    Debug.Print "Обновление подчиненной формы:", subformControlName, _
                "Method=[" & refreshMethodName & "]", _
                Now()

    If Len(refreshMethodName) > 0 Then

        If TryCallSubformMethod(subformControlName, refreshMethodName) Then
            Exit Sub
        Else
            Debug.Print "Не удалось вызвать метод " & refreshMethodName & _
                        " у подчиненной формы " & subformControlName
        End If

    End If

    If TryCallSubformMethod(subformControlName, "RefreshPanel") Then
        Exit Sub
    End If

    Call RequerySubform(subformControlName)

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка обновления подчиненной формы " & subformControlName & ": " & Err.Description

End Sub

Private Function TryCallSubformMethod( _
    ByVal subformControlName As String, _
    ByVal methodName As String _
) As Boolean

    ' Пытается вызвать публичный метод внутри подчиненной формы.

    On Error GoTo ErrorHandler

    Err.Clear

    CallByName Me.Controls(subformControlName).Form, methodName, VbMethod

    TryCallSubformMethod = True

    Exit Function

ErrorHandler:

    Debug.Print "CallByName не выполнил " & methodName & _
                " для " & subformControlName & _
                ". Ошибка: " & Err.Description

    TryCallSubformMethod = False

End Function


Private Sub RequerySubform(ByVal subformControlName As String)

    ' Выполняет стандартное обновление подчиненной формы.

    On Error Resume Next

    Me.Controls(subformControlName).Form.Requery
    Me.Controls(subformControlName).Form.Refresh
    Me.Controls(subformControlName).Form.Recalc
    Me.Controls(subformControlName).Form.Repaint

End Sub



' ============================================================
' Лицензия / вкладка "Настройки"

' ============================================================
' Alpha-оболочка Access / вкладка "Настройки"
' ============================================================

' ============================================================

Private Sub RefreshLicenseControls()

    ' Обновляет поля лицензионного блока на вкладке "Настройки"
    ' и применяет режим доступа к кнопкам с Tag = RequiresLicense.

    On Error Resume Next

    Call RefreshLicenseInfoOnForm(Me)
    Call ApplyLicenseToForm(Me)

End Sub

Private Sub cmdCheckLicense_Click()

    ' Проверяет лицензию, обновляет поля на форме
    ' и применяет режим доступа к открытым формам.

    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

    MsgBox "Проверка лицензии выполнена." & vbCrLf & vbCrLf & _
           "Статус: " & GetLicenseStatusText(), _
           vbInformation, _
           "Лицензия"

End Sub

Private Sub cmdCopyMachineCode_Click()

    ' Копирует код компьютера в буфер обмена.

    Call CopyMachineCodeToClipboard
    Call RefreshLicenseControls

End Sub


Private Sub cmdEnterLicenseKey_Click()

    ' Заготовка для будущего ввода лицензионного ключа.
    '
    ' На следующем этапе сюда подключим реальную проверку ключа,
    ' сохранение лицензии и повторное применение режима доступа.

    Call EnterLicenseKeyPlaceholder
    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

End Sub

Private Sub cmdCreateAlphaTrialLicense_Click()

    ' Временная тестовая кнопка.
    '
    ' Создает локальную Alpha-лицензию на 60 дней
    ' для проверки интерфейса и логики статуса.
    '
    ' Перед передачей заказчику эту кнопку нужно скрыть или удалить.

    Call CreateAlphaTrialLicense
    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

End Sub


Private Sub cmdResetLicense_Click()

    ' Временная служебная кнопка для тестов.
    '
    ' Сбрасывает активную лицензию и повторно применяет блокировку
    ' кнопок с Tag = RequiresLicense.
    '
    ' Перед передачей заказчику эту кнопку нужно скрыть или удалить.

    If MsgBox("Сбросить активную лицензию для теста?", _
              vbQuestion + vbYesNo + vbDefaultButton2, _
              "Сброс лицензии") <> vbYes Then
        Exit Sub
    End If

    Call ResetActiveLicenseForDebug(False)

    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

    MsgBox "Лицензия сброшена." & vbCrLf & _
           "Управляющие кнопки должны перейти в заблокированное состояние.", _
           vbInformation, _
           "Сброс лицензии"

End Sub


' ============================================================
' Подготовка клиентской Alpha-копии / вкладка "Настройки"
' ============================================================

Private Sub cmdPrepareAlphaClientCopy_Click()

    ' Скрывает служебные кнопки разработчика и оставляет
    ' только клиентские элементы лицензии.
    '
    ' Требуется стандартный модуль:
    '   mAlphaRelease

    Call PrepareAlphaClientCopy(Me)

End Sub


Private Sub cmdRestoreDeveloperUi_Click()

    ' Возвращает служебные кнопки разработчика на вкладку "Настройки".
    '
    ' Использовать только в dev-копии.

    Call RestoreDeveloperUiOnForm(Me)

End Sub


Private Sub cmdShowAlphaReleaseChecklist_Click()

    ' Показывает чек-лист перед сборкой клиентской Alpha-версии.

    Call ShowAlphaReleaseChecklist

End Sub


Private Sub cmdCheckAlphaFolders_Click()

    ' Проверяет наличие папок Templates и Reports рядом с базой.

    Call CheckAlphaFolders

End Sub

' ============================================================
' Вспомогательные процедуры
' ============================================================

Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.
    '
    ' Используем перебор с Trim, чтобы случайный пробел
    ' в имени элемента не ломал проверку.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    For Each ctl In Me.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExists = True
            Exit Function
        End If

    Next ctl

    ControlExists = False

    Exit Function

ErrorHandler:

    ControlExists = False

End Function


Private Sub cmdCloseApplication_Click()

    ' Закрывает приложение.
    '
    ' Кнопка необязательная.
    ' Если на форме нет cmdCloseApplication, процедура не используется.

    DoCmd.Quit acQuitSaveAll

End Sub






```

### mLicense_Alpha_FinalClipboardReset_Code.bas

**Группа:** `final_preferred`  
**Назначение:** mLicense — реальный ключ, MachineCode, защита от отката даты, блокировка RequiresLicense, Windows Clipboard API, сброс лицензии для dev.  
**SHA256:** `64a10b312829a97bef88ca6bfd6bf5301d3919c768c0958dc19d3bf4cc861df8`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Windows Clipboard API
'
' Нужен как надежная замена MSForms.DataObject.
' В некоторых установках Access CreateObject("MSForms.DataObject")
' не работает или не копирует текст в буфер.
' ============================================================

#If VBA7 Then

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr

Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr

#Else

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

#End If

Private Const GMEM_MOVEABLE As Long = &H2
Private Const CF_UNICODETEXT As Long = 13


' ============================================================
' Модуль: mLicense
'
' Назначение:
'   Базовый лицензионный блок для Alpha-версии проекта "Пивовар".
'
' Текущий этап:
'   - создает служебные таблицы лицензии;
'   - получает MachineCode компьютера;
'   - хранит FirstRunDate / LastRunDate;
'   - проверяет наличие лицензии;
'   - проверяет срок действия;
'   - проверяет откат системной даты;
'   - показывает диагностический статус лицензии.
'
' Важно:
'   На этом этапе модуль НЕ блокирует управляющие кнопки.
'   Блокировку через Tag = RequiresLicense подключим следующим этапом,
'   когда убедимся, что статус и MachineCode работают корректно.
'
' Таблицы:
'   tAppLicense
'   tAppState
'
' Формы:
'   Планируемые элементы на вкладке "Настройки" формы fГлавная:
'       txtLicenseStatus
'       txtLicenseExpireDate
'       txtMachineCode
'
'       cmdCopyMachineCode
'       cmdEnterLicenseKey
'       cmdCheckLicense
' ============================================================

Private Const PRODUCT_NAME As String = "Pivovar"
Private Const LICENSE_TYPE_ALPHA As String = "Alpha"
Private Const DEFAULT_ALPHA_DAYS As Long = 60

Private Const TABLE_LICENSE As String = "tAppLicense"
Private Const TABLE_STATE As String = "tAppState"

Private Const STATE_FIRST_RUN_DATE As String = "FirstRunDate"
Private Const STATE_LAST_RUN_DATE As String = "LastRunDate"
Private Const STATE_LAST_MACHINE_CODE As String = "LastMachineCode"
Private Const STATE_LAST_LICENSE_STATUS As String = "LastLicenseStatus"

Private Const LICENSE_STATUS_ACTIVE As String = "Лицензия активна"
Private Const LICENSE_STATUS_NOT_FOUND As String = "Лицензия не найдена"
Private Const LICENSE_STATUS_EXPIRED As String = "Срок лицензии истек"
Private Const LICENSE_STATUS_WRONG_MACHINE As String = "Лицензия выдана для другого компьютера"
Private Const LICENSE_STATUS_DATE_ROLLBACK As String = "Некорректная системная дата"
Private Const LICENSE_STATUS_ERROR As String = "Ошибка проверки лицензии"
Private Const LICENSE_STATUS_INVALID As String = "Лицензионный ключ некорректен"


' ============================================================
' Публичные процедуры первого этапа
' ============================================================

Public Sub InitializeLicenseSystem()

    ' Создает служебные таблицы, если их нет,
    ' и инициализирует состояние первого запуска.
    '
    ' LastRunDate здесь намеренно не перезаписывается до проверки лицензии,
    ' иначе защита от отката даты не сможет сравнить текущую дату
    ' с предыдущим запуском.

    On Error GoTo ErrorHandler

    Call EnsureLicenseTables
    Call EnsureFirstRunState

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось инициализировать лицензионный блок." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Лицензия"

End Sub

Public Function GetLicenseStatusText() As String

    ' Возвращает текстовый статус лицензии.
    '
    ' Проверяет:
    '   - наличие активной записи;
    '   - подпись лицензионного ключа;
    '   - привязку к текущему компьютеру;
    '   - срок действия;
    '   - откат системной даты.
    '
    ' Эта функция сама ничего не блокирует.
    ' Блокировка выполняется через ApplyLicenseToForm / ApplyLicenseToOpenForms.

    On Error GoTo ErrorHandler

    Dim currentMachineCode As String
    Dim keyMachineCode As String
    Dim keyLicenseType As String
    Dim keyExpireDate As Date
    Dim licenseKey As String
    Dim errorText As String
    Dim lastRunDate As Variant

    Call EnsureLicenseTables
    Call EnsureFirstRunState

    currentMachineCode = GetMachineCode()

    lastRunDate = GetAppStateValue(STATE_LAST_RUN_DATE)

    If IsDate(lastRunDate) Then

        If Date < CDate(lastRunDate) Then
            GetLicenseStatusText = LICENSE_STATUS_DATE_ROLLBACK
            Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "Статус последней проверки лицензии")
            Exit Function
        End If

    End If

    If HasActiveLicenseRecord() = False Then
        GetLicenseStatusText = LICENSE_STATUS_NOT_FOUND
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "Статус последней проверки лицензии")
        Call CommitCurrentRunDate
        Exit Function
    End If

    licenseKey = Nz(DLookup("[LicenseKey]", TABLE_LICENSE, "[IsActive] = True"), "")

    If ParseAndValidateLicenseKey(licenseKey, keyLicenseType, keyMachineCode, keyExpireDate, errorText) = False Then
        GetLicenseStatusText = LICENSE_STATUS_INVALID
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText & ": " & errorText, "Статус последней проверки лицензии")
        Call CommitCurrentRunDate
        Exit Function
    End If

    If StrComp(Trim$(keyMachineCode), Trim$(currentMachineCode), vbTextCompare) <> 0 Then
        GetLicenseStatusText = LICENSE_STATUS_WRONG_MACHINE
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "Статус последней проверки лицензии")
        Call CommitCurrentRunDate
        Exit Function
    End If

    If Date > keyExpireDate Then
        GetLicenseStatusText = LICENSE_STATUS_EXPIRED
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "Статус последней проверки лицензии")
        Call CommitCurrentRunDate
        Exit Function
    End If

    GetLicenseStatusText = LICENSE_STATUS_ACTIVE

    Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "Статус последней проверки лицензии")
    Call CommitCurrentRunDate

    Exit Function

ErrorHandler:

    GetLicenseStatusText = LICENSE_STATUS_ERROR & ": " & Err.Description

End Function

Public Function IsLicenseValid() As Boolean

    ' Возвращает True, если лицензия активна.
    '
    ' На следующем этапе эту функцию будем использовать
    ' для блокировки управляющих кнопок.

    IsLicenseValid = (StrComp(GetLicenseStatusText(), LICENSE_STATUS_ACTIVE, vbTextCompare) = 0)

End Function


Public Function GetLicenseExpireDateText() As String

    ' Возвращает дату окончания лицензии текстом.

    On Error GoTo ErrorHandler

    Dim expireDate As Variant

    Call EnsureLicenseTables

    expireDate = DLookup("[ExpireDate]", TABLE_LICENSE, "[IsActive] = True")

    If IsDate(expireDate) Then
        GetLicenseExpireDateText = Format(CDate(expireDate), "dd.mm.yyyy")
    Else
        GetLicenseExpireDateText = "Не задана"
    End If

    Exit Function

ErrorHandler:

    GetLicenseExpireDateText = "Ошибка: " & Err.Description

End Function


Public Function GetMachineCode() As String

    ' Возвращает короткий код компьютера.
    '
    ' Код строится по аппаратному/системному отпечатку:
    '   - имя компьютера;
    '   - Windows MachineGuid;
    '   - BIOS SerialNumber;
    '   - BaseBoard SerialNumber;
    '   - системный диск.

    On Error GoTo ErrorHandler

    Dim rawFingerprint As String
    Dim hashText As String

    rawFingerprint = GetMachineFingerprintRaw()
    hashText = HashTextSimple(rawFingerprint)

    GetMachineCode = FormatMachineCode(hashText)

    Exit Function

ErrorHandler:

    GetMachineCode = "PV-ERROR"

End Function


Public Sub RefreshLicenseInfoOnForm(ByVal targetForm As Form)

    ' Заполняет поля лицензии на форме.
    '
    ' Ожидаемые элементы:
    '   txtLicenseStatus
    '   txtLicenseExpireDate
    '   txtMachineCode

    On Error Resume Next

    Call InitializeLicenseSystem

    If ControlExistsOnForm(targetForm, "txtLicenseStatus") Then
        targetForm.Controls("txtLicenseStatus").Value = GetLicenseStatusText()
    End If

    If ControlExistsOnForm(targetForm, "txtLicenseExpireDate") Then
        targetForm.Controls("txtLicenseExpireDate").Value = GetLicenseExpireDateText()
    End If

    If ControlExistsOnForm(targetForm, "txtMachineCode") Then
        targetForm.Controls("txtMachineCode").Value = GetMachineCode()
    End If

End Sub


Public Sub CopyMachineCodeToClipboard()

    ' Копирует MachineCode в буфер обмена.
    '
    ' Использует Windows Clipboard API.
    ' Это надежнее, чем MSForms.DataObject, который не всегда работает
    ' на компьютерах без установленной/зарегистрированной библиотеки Forms.

    On Error GoTo ErrorHandler

    Dim machineCode As String

    machineCode = GetMachineCode()

    If CopyTextToClipboardSafe(machineCode) = True Then

        MsgBox "Код компьютера скопирован в буфер обмена:" & vbCrLf & _
               machineCode, _
               vbInformation, _
               "Код компьютера"

    Else

        MsgBox "Не удалось автоматически скопировать код компьютера." & vbCrLf & vbCrLf & _
               "Скопируйте его вручную:" & vbCrLf & _
               machineCode, _
               vbInformation, _
               "Код компьютера"

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось скопировать код компьютера." & vbCrLf & vbCrLf & _
           "Скопируйте его вручную:" & vbCrLf & _
           GetMachineCode(), _
           vbInformation, _
           "Код компьютера"

End Sub

Public Sub CreateAlphaTrialLicense()

    ' Создает локальную Alpha-лицензию на 60 дней для текущего компьютера.
    '
    ' Это временная процедура для первичной отладки.
    ' После внедрения отдельного генератора ключей ее нужно удалить
    ' или скрыть с интерфейса заказчика.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim machineCode As String
    Dim expireDate As Date
    Dim licenseKey As String

    Call EnsureLicenseTables

    machineCode = GetMachineCode()
    expireDate = DateAdd("d", DEFAULT_ALPHA_DAYS, Date)
    licenseKey = GenerateLicenseKeyForMachine(machineCode, expireDate, LICENSE_TYPE_ALPHA)

    Set db = CurrentDb

    db.Execute _
        "UPDATE [" & TABLE_LICENSE & "] SET [IsActive] = False;", _
        dbFailOnError

    db.Execute _
        "INSERT INTO [" & TABLE_LICENSE & "] " & _
        "([ProductName], [LicenseType], [MachineCode], [LicenseKey], [ExpireDate], [CreatedDate], [UpdatedDate], [IsActive], [Comment]) " & _
        "VALUES (" & _
        SqlText(PRODUCT_NAME) & ", " & _
        SqlText(LICENSE_TYPE_ALPHA) & ", " & _
        SqlText(machineCode) & ", " & _
        SqlText(licenseKey) & ", " & _
        SqlDate(expireDate) & ", " & _
        SqlDateTime(Now()) & ", " & _
        SqlDateTime(Now()) & ", " & _
        "True, " & _
        SqlText("Локальная тестовая Alpha-лицензия на 60 дней") & _
        ");", _
        dbFailOnError

    MsgBox "Создана локальная Alpha-лицензия." & vbCrLf & _
           "Код компьютера: " & machineCode & vbCrLf & _
           "Действует до: " & Format(expireDate, "dd.mm.yyyy") & vbCrLf & vbCrLf & _
           "Ключ:" & vbCrLf & licenseKey, _
           vbInformation, _
           "Лицензия"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось создать тестовую Alpha-лицензию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Лицензия"

End Sub


Public Sub ResetActiveLicenseForDebug(Optional ByVal showMessage As Boolean = True)

    ' Сбрасывает активную лицензию.
    '
    ' Это служебная процедура для отладки.
    ' Перед передачей заказчику кнопку, которая ее вызывает,
    ' нужно скрыть или удалить.

    On Error GoTo ErrorHandler

    Call EnsureLicenseTables

    CurrentDb.Execute _
        "UPDATE [" & TABLE_LICENSE & "] " & _
        "SET [IsActive] = False, [UpdatedDate] = Now(), " & _
        "[Comment] = Nz([Comment], '') & Chr(13) & Chr(10) & " & _
        SqlText("Лицензия вручную деактивирована для теста: ") & " & Format(Now(), 'dd.mm.yyyy hh:nn') " & _
        "WHERE [IsActive] = True;", _
        dbFailOnError

    Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, LICENSE_STATUS_NOT_FOUND, "Лицензия сброшена вручную")

    If showMessage = True Then

        MsgBox "Активная лицензия сброшена." & vbCrLf & _
               "После проверки лицензии управляющие кнопки должны отключиться.", _
               vbInformation, _
               "Сброс лицензии"

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сбросить лицензию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Сброс лицензии"

End Sub


Public Sub EnterLicenseKeyPlaceholder()

    ' Вводит и сохраняет реальный лицензионный ключ.
    '
    ' Имя процедуры оставлено прежним, чтобы не менять обработчик
    ' кнопки cmdEnterLicenseKey_Click в fГлавная.

    On Error GoTo ErrorHandler

    Dim inputKey As String

    inputKey = InputBox( _
        "Введите лицензионный ключ." & vbCrLf & vbCrLf & _
        "Код этого компьютера:" & vbCrLf & _
        GetMachineCode(), _
        "Ввод лицензионного ключа" _
    )

    If Trim$(inputKey) = "" Then
        Exit Sub
    End If

    If SaveLicenseKey(inputKey) = True Then

        Call ApplyLicenseToOpenForms

        MsgBox "Лицензионный ключ принят." & vbCrLf & vbCrLf & _
               "Статус: " & GetLicenseStatusText() & vbCrLf & _
               "Действует до: " & GetLicenseExpireDateText(), _
               vbInformation, _
               "Лицензия"

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сохранить лицензионный ключ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Лицензия"

End Sub


Public Function SaveLicenseKey(ByVal licenseKey As String) As Boolean

    ' Проверяет и сохраняет лицензионный ключ для текущего компьютера.

    On Error GoTo ErrorHandler

    Dim keyMachineCode As String
    Dim keyLicenseType As String
    Dim keyExpireDate As Date
    Dim errorText As String
    Dim db As DAO.Database

    SaveLicenseKey = False

    Call EnsureLicenseTables

    If ValidateLicenseKeyForCurrentMachine( _
        licenseKey:=licenseKey, _
        licenseType:=keyLicenseType, _
        machineCode:=keyMachineCode, _
        expireDate:=keyExpireDate, _
        errorText:=errorText _
    ) = False Then

        MsgBox "Лицензионный ключ не принят." & vbCrLf & vbCrLf & _
               errorText, _
               vbExclamation, _
               "Лицензия"

        Exit Function

    End If

    Set db = CurrentDb

    db.Execute _
        "UPDATE [" & TABLE_LICENSE & "] SET [IsActive] = False, [UpdatedDate] = Now();", _
        dbFailOnError

    db.Execute _
        "INSERT INTO [" & TABLE_LICENSE & "] " & _
        "([ProductName], [LicenseType], [MachineCode], [LicenseKey], [ExpireDate], [CreatedDate], [UpdatedDate], [IsActive], [Comment]) " & _
        "VALUES (" & _
        SqlText(PRODUCT_NAME) & ", " & _
        SqlText(keyLicenseType) & ", " & _
        SqlText(keyMachineCode) & ", " & _
        SqlText(NormalizeLicenseKey(licenseKey)) & ", " & _
        SqlDate(keyExpireDate) & ", " & _
        SqlDateTime(Now()) & ", " & _
        SqlDateTime(Now()) & ", " & _
        "True, " & _
        SqlText("Лицензия введена пользователем") & _
        ");", _
        dbFailOnError

    SaveLicenseKey = True

    Exit Function

ErrorHandler:

    MsgBox "Не удалось сохранить лицензионный ключ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Лицензия"

    SaveLicenseKey = False

End Function


Public Function ValidateLicenseKeyForCurrentMachine( _
    ByVal licenseKey As String, _
    ByRef licenseType As String, _
    ByRef machineCode As String, _
    ByRef expireDate As Date, _
    ByRef errorText As String _
) As Boolean

    ' Проверяет ключ:
    '   - формат;
    '   - подпись;
    '   - привязку к текущему компьютеру;
    '   - срок действия.

    On Error GoTo ErrorHandler

    ValidateLicenseKeyForCurrentMachine = False

    If ParseAndValidateLicenseKey(licenseKey, licenseType, machineCode, expireDate, errorText) = False Then
        Exit Function
    End If

    If StrComp(machineCode, GetMachineCode(), vbTextCompare) <> 0 Then

        errorText = _
            "Ключ выдан для другого компьютера." & vbCrLf & _
            "Код в ключе: " & machineCode & vbCrLf & _
            "Код этого компьютера: " & GetMachineCode()

        Exit Function

    End If

    If Date > expireDate Then

        errorText = "Срок действия ключа истек: " & Format(expireDate, "dd.mm.yyyy")
        Exit Function

    End If

    ValidateLicenseKeyForCurrentMachine = True

    Exit Function

ErrorHandler:

    errorText = "Ошибка проверки ключа: " & Err.Description
    ValidateLicenseKeyForCurrentMachine = False

End Function


Private Function ParseAndValidateLicenseKey( _
    ByVal licenseKey As String, _
    ByRef licenseType As String, _
    ByRef machineCode As String, _
    ByRef expireDate As Date, _
    ByRef errorText As String _
) As Boolean

    ' Разбирает и проверяет лицензионный ключ.
    '
    ' Формат:
    '   PV1-ALPHA-YYYYMMDD-XXXX-YYYY-SIGNATURE
    '
    ' Где MachineCode имеет вид:
    '   PV-XXXX-YYYY

    On Error GoTo ErrorHandler

    Dim normalizedKey As String
    Dim parts As Variant
    Dim prefixText As String
    Dim dateText As String
    Dim machinePart1 As String
    Dim machinePart2 As String
    Dim signatureText As String
    Dim expectedSignature As String

    ParseAndValidateLicenseKey = False
    errorText = ""

    normalizedKey = NormalizeLicenseKey(licenseKey)
    parts = Split(normalizedKey, "-")

    If UBound(parts) <> 5 Then
        errorText = "Некорректный формат ключа."
        Exit Function
    End If

    prefixText = CStr(parts(0))
    licenseType = CStr(parts(1))
    dateText = CStr(parts(2))
    machinePart1 = CStr(parts(3))
    machinePart2 = CStr(parts(4))
    signatureText = CStr(parts(5))

    If StrComp(prefixText, "PV1", vbTextCompare) <> 0 Then
        errorText = "Некорректный префикс ключа."
        Exit Function
    End If

    If Len(dateText) <> 8 Or IsNumeric(dateText) = False Then
        errorText = "Некорректная дата окончания в ключе."
        Exit Function
    End If

    expireDate = DateSerial( _
        CLng(Left$(dateText, 4)), _
        CLng(Mid$(dateText, 5, 2)), _
        CLng(Right$(dateText, 2)) _
    )

    machineCode = "PV-" & machinePart1 & "-" & machinePart2

    expectedSignature = BuildLicenseSignature(licenseType, dateText, machineCode)

    If StrComp(signatureText, expectedSignature, vbTextCompare) <> 0 Then
        errorText = "Подпись лицензионного ключа не совпадает."
        Exit Function
    End If

    ParseAndValidateLicenseKey = True

    Exit Function

ErrorHandler:

    errorText = "Ошибка разбора ключа: " & Err.Description
    ParseAndValidateLicenseKey = False

End Function


Public Function GenerateLicenseKeyForMachine( _
    ByVal machineCode As String, _
    ByVal expireDate As Date, _
    Optional ByVal licenseType As String = LICENSE_TYPE_ALPHA _
) As String

    ' Генерирует лицензионный ключ.
    '
    ' Эту функцию удобно использовать в отдельной базе разработчика
    ' или во временном генераторе ключей.

    On Error GoTo ErrorHandler

    Dim normalizedMachineCode As String
    Dim normalizedLicenseType As String
    Dim dateText As String
    Dim signatureText As String
    Dim machinePart As String

    normalizedMachineCode = NormalizeMachineCode(machineCode)
    normalizedLicenseType = NormalizeLicenseType(licenseType)
    dateText = Format$(expireDate, "yyyymmdd")

    signatureText = BuildLicenseSignature(normalizedLicenseType, dateText, normalizedMachineCode)

    machinePart = Replace(normalizedMachineCode, "PV-", "")

    GenerateLicenseKeyForMachine = _
        "PV1-" & normalizedLicenseType & "-" & dateText & "-" & machinePart & "-" & signatureText

    Exit Function

ErrorHandler:

    GenerateLicenseKeyForMachine = ""

End Function


Public Sub ShowDeveloperLicenseKeyGenerator()

    ' Временный генератор ключа для разработчика.
    '
    ' Можно вызвать из Immediate Window:
    '   Call ShowDeveloperLicenseKeyGenerator
    '
    ' Перед передачей заказчику этот вызов нигде не размещать.

    On Error GoTo ErrorHandler

    Dim machineCode As String
    Dim expireText As String
    Dim expireDate As Date
    Dim licenseKey As String

    machineCode = InputBox( _
        "Введите код компьютера клиента.", _
        "Генератор лицензии", _
        GetMachineCode() _
    )

    If Trim$(machineCode) = "" Then
        Exit Sub
    End If

    expireText = InputBox( _
        "Введите дату окончания лицензии в формате ДД.ММ.ГГГГ.", _
        "Генератор лицензии", _
        Format$(DateAdd("d", DEFAULT_ALPHA_DAYS, Date), "dd.mm.yyyy") _
    )

    If Trim$(expireText) = "" Then
        Exit Sub
    End If

    If IsDate(expireText) = False Then
        MsgBox "Некорректная дата.", vbExclamation, "Генератор лицензии"
        Exit Sub
    End If

    expireDate = CDate(expireText)

    licenseKey = GenerateLicenseKeyForMachine(machineCode, expireDate, LICENSE_TYPE_ALPHA)

    MsgBox "Лицензионный ключ:" & vbCrLf & vbCrLf & _
           licenseKey, _
           vbInformation, _
           "Генератор лицензии"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сформировать лицензионный ключ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Генератор лицензии"

End Sub


Private Function NormalizeLicenseKey(ByVal licenseKey As String) As String

    NormalizeLicenseKey = UCase$(Trim$(licenseKey))
    NormalizeLicenseKey = Replace(NormalizeLicenseKey, " ", "")
    NormalizeLicenseKey = Replace(NormalizeLicenseKey, vbCr, "")
    NormalizeLicenseKey = Replace(NormalizeLicenseKey, vbLf, "")

End Function


Private Function NormalizeLicenseType(ByVal licenseType As String) As String

    NormalizeLicenseType = UCase$(Trim$(licenseType))

    If NormalizeLicenseType = "" Then
        NormalizeLicenseType = UCase$(LICENSE_TYPE_ALPHA)
    End If

End Function


Private Function NormalizeMachineCode(ByVal machineCode As String) As String

    Dim normalizedText As String
    Dim parts As Variant

    normalizedText = UCase$(Trim$(machineCode))
    normalizedText = Replace(normalizedText, " ", "")

    If Left$(normalizedText, 3) <> "PV-" Then
        normalizedText = "PV-" & normalizedText
    End If

    parts = Split(normalizedText, "-")

    If UBound(parts) = 2 Then
        NormalizeMachineCode = "PV-" & parts(1) & "-" & parts(2)
    Else
        NormalizeMachineCode = normalizedText
    End If

End Function


Private Function BuildLicenseSignature( _
    ByVal licenseType As String, _
    ByVal dateText As String, _
    ByVal machineCode As String _
) As String

    ' Строит подпись ключа.
    '
    ' Это не банковская криптография, но для Alpha-версии Access
    ' в связке с ACCDE достаточно для защиты от обычного копирования.

    Dim payloadText As String
    Dim secretText As String
    Dim part1 As String
    Dim part2 As String

    payloadText = _
        "PV1|" & _
        NormalizeLicenseType(licenseType) & "|" & _
        dateText & "|" & _
        NormalizeMachineCode(machineCode)

    secretText = GetLicenseSecret()

    part1 = HashTextLicense(payloadText & "|" & secretText)
    part2 = HashTextLicense(secretText & "|" & payloadText)

    BuildLicenseSignature = part1 & part2

End Function


Private Function GetLicenseSecret() As String

    ' Секретная строка разработчика.
    '
    ' В ACCDE она не видна обычному пользователю, но абсолютной
    ' защитой это считать нельзя.

    GetLicenseSecret = "PV-" & "Alpha-" & "2026-" & "Sulimov-" & "Brew"

End Function


Private Function HashTextLicense(ByVal sourceText As String) As String

    ' Простая стабильная хеш-функция для подписи ключей.
    '
    ' Не использует LongLong, чтобы работать в 32/64-bit Access.

    On Error GoTo ErrorHandler

    Dim i As Long
    Dim hashValue As Double
    Dim charCode As Long

    hashValue = 5381#

    For i = 1 To Len(sourceText)

        charCode = AscW(Mid$(sourceText, i, 1))

        If charCode < 0 Then
            charCode = charCode + 65536
        End If

        hashValue = hashValue * 33# + charCode

        Do While hashValue > 2147483647#
            hashValue = hashValue - 2147483647#
        Loop

    Next i

    HashTextLicense = Right$("00000000" & Hex$(CLng(hashValue)), 8)

    Exit Function

ErrorHandler:

    HashTextLicense = "00000000"

End Function


' ============================================================
' Блокировка управляющих элементов по лицензии
' ============================================================

Public Sub ApplyLicenseToForm(ByVal targetForm As Form)

    ' Применяет режим доступа к форме и всем ее подчиненным формам.
    '
    ' Управляющие элементы, которые должны блокироваться без лицензии,
    ' должны иметь свойство Tag:
    '   RequiresLicense
    '
    ' В русской версии Access это свойство называется:
    '   Дополнительные сведения
    '
    ' Важно:
    '   Эта процедура рекурсивно проходит по подформам.
    '   Поэтому если fВарка, fЦКТ_Панель или fФорфас_Панель
    '   встроены в fГлавная как SubForm/SubReport control,
    '   кнопки внутри них тоже будут обработаны.

    On Error Resume Next

    Dim licenseIsValid As Boolean

    licenseIsValid = IsLicenseValid()

    Call ApplyLicenseToFormInternal(targetForm, licenseIsValid)

End Sub


Private Sub ApplyLicenseToFormInternal( _
    ByVal targetForm As Form, _
    ByVal licenseIsValid As Boolean _
)

    ' Внутренняя рекурсивная процедура.
    '
    ' Обрабатывает:
    '   - элементы текущей формы;
    '   - подчиненные формы внутри текущей формы;
    '   - подчиненные формы второго уровня, если они появятся позже.

    On Error Resume Next

    Dim ctl As Control
    Dim tagText As String

    For Each ctl In targetForm.Controls

        tagText = Trim$(Nz(ctl.Tag, ""))

        If StrComp(tagText, "RequiresLicense", vbTextCompare) = 0 Then

            Select Case ctl.ControlType

                Case acCommandButton, acComboBox, acTextBox, acCheckBox, acListBox, acOptionGroup, acToggleButton
                    ctl.Enabled = licenseIsValid

            End Select

        End If

        ' Подчиненная форма.
        '
        ' Для SubForm/SubReport control свойство .Form доступно только
        ' если SourceObject загружен. Поэтому ошибки здесь намеренно
        ' подавляются через On Error Resume Next.
        If ctl.ControlType = acSubform Then
            Err.Clear
            Call ApplyLicenseToFormInternal(ctl.Form, licenseIsValid)
            Err.Clear
        End If

    Next ctl

End Sub

Public Sub ApplyLicenseToOpenForms()

    ' Применяет режим лицензии ко всем открытым формам.
    '
    ' ApplyLicenseToForm сама рекурсивно обрабатывает подформы,
    ' поэтому отдельно искать subBrew/subCctPanel/subForfasPanel здесь не нужно.

    On Error Resume Next

    Dim formItem As Access.Form

    For Each formItem In Forms
        Call ApplyLicenseToForm(formItem)
    Next formItem

End Sub

Public Function RequireActiveLicense( _
    Optional ByVal operationName As String = "Операция" _
) As Boolean

    ' Проверяет активность лицензии перед выполнением операции.
    '
    ' Эту функцию можно добавлять в обработчики критичных кнопок,
    ' если одной блокировки через Tag недостаточно.

    On Error GoTo ErrorHandler

    Dim statusText As String

    statusText = GetLicenseStatusText()

    If StrComp(statusText, LICENSE_STATUS_ACTIVE, vbTextCompare) = 0 Then
        RequireActiveLicense = True
        Exit Function
    End If

    MsgBox operationName & " недоступна." & vbCrLf & vbCrLf & _
           "Статус лицензии: " & statusText & vbCrLf & vbCrLf & _
           "Для продолжения работы обратитесь к разработчику.", _
           vbExclamation, _
           "Ограничение Alpha-версии"

    RequireActiveLicense = False

    Exit Function

ErrorHandler:

    MsgBox operationName & " недоступна." & vbCrLf & vbCrLf & _
           "Не удалось проверить лицензию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Ограничение Alpha-версии"

    RequireActiveLicense = False

End Function


Public Sub ShowLicenseBlockedMessage()

    ' Универсальное сообщение для заблокированных операций.

    MsgBox "Управляющая операция недоступна." & vbCrLf & vbCrLf & _
           "Статус лицензии: " & GetLicenseStatusText() & vbCrLf & vbCrLf & _
           "Данные не удалены и доступны для просмотра." & vbCrLf & _
           "Для продления работы обратитесь к разработчику.", _
           vbExclamation, _
           "Ограничение Alpha-версии"

End Sub


' ============================================================
' Создание и обслуживание таблиц
' ============================================================

Public Sub EnsureLicenseTables()

    ' Создает таблицы tAppLicense и tAppState, если их нет.

    On Error GoTo ErrorHandler

    If TableExists(TABLE_LICENSE) = False Then
        Call CreateAppLicenseTable
    End If

    If TableExists(TABLE_STATE) = False Then
        Call CreateAppStateTable
    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub CreateAppLicenseTable()

    On Error GoTo ErrorHandler

    CurrentDb.Execute _
        "CREATE TABLE [" & TABLE_LICENSE & "] (" & _
        "[Код] AUTOINCREMENT CONSTRAINT [pk_tAppLicense] PRIMARY KEY, " & _
        "[ProductName] TEXT(100), " & _
        "[LicenseType] TEXT(100), " & _
        "[MachineCode] LONGTEXT, " & _
        "[LicenseKey] LONGTEXT, " & _
        "[ExpireDate] DATETIME, " & _
        "[CreatedDate] DATETIME, " & _
        "[UpdatedDate] DATETIME, " & _
        "[IsActive] YESNO, " & _
        "[Comment] LONGTEXT" & _
        ");", _
        dbFailOnError

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub CreateAppStateTable()

    On Error GoTo ErrorHandler

    CurrentDb.Execute _
        "CREATE TABLE [" & TABLE_STATE & "] (" & _
        "[Код] AUTOINCREMENT CONSTRAINT [pk_tAppState] PRIMARY KEY, " & _
        "[StateName] TEXT(100), " & _
        "[StateValue] LONGTEXT, " & _
        "[UpdatedDate] DATETIME, " & _
        "[Comment] LONGTEXT" & _
        ");", _
        dbFailOnError

    CurrentDb.Execute _
        "CREATE UNIQUE INDEX [ux_tAppState_StateName] " & _
        "ON [" & TABLE_STATE & "] ([StateName]);", _
        dbFailOnError

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function TableExists(ByVal tableName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim tdf As DAO.TableDef

    For Each tdf In CurrentDb.TableDefs

        If StrComp(tdf.Name, tableName, vbTextCompare) = 0 Then
            TableExists = True
            Exit Function
        End If

    Next tdf

    TableExists = False

    Exit Function

ErrorHandler:

    TableExists = False

End Function



Private Sub EnsureFirstRunState()

    ' Инициализирует FirstRunDate и LastMachineCode,
    ' но не перезаписывает LastRunDate до проверки лицензии.

    On Error GoTo ErrorHandler

    Dim firstRunDate As Variant
    Dim lastRunDate As Variant
    Dim machineCode As String

    firstRunDate = GetAppStateValue(STATE_FIRST_RUN_DATE)
    lastRunDate = GetAppStateValue(STATE_LAST_RUN_DATE)
    machineCode = GetMachineCode()

    If IsNull(firstRunDate) Or Len(Trim$(Nz(firstRunDate, ""))) = 0 Then
        Call SetAppStateValue(STATE_FIRST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "Дата первого запуска")
    End If

    If IsNull(lastRunDate) Or Len(Trim$(Nz(lastRunDate, ""))) = 0 Then
        Call SetAppStateValue(STATE_LAST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "Дата последнего запуска")
    End If

    Call SetAppStateValue(STATE_LAST_MACHINE_CODE, machineCode, "Последний код компьютера")

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub CommitCurrentRunDate()

    ' Фиксирует текущую дату как дату последнего успешного запуска.

    On Error Resume Next

    Call SetAppStateValue(STATE_LAST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "Дата последнего запуска")
    Call SetAppStateValue(STATE_LAST_MACHINE_CODE, GetMachineCode(), "Последний код компьютера")

End Sub


Private Sub UpdateRunState()

    ' Обновляет FirstRunDate / LastRunDate / LastMachineCode.

    On Error GoTo ErrorHandler

    Dim firstRunDate As Variant
    Dim machineCode As String

    firstRunDate = GetAppStateValue(STATE_FIRST_RUN_DATE)
    machineCode = GetMachineCode()

    If IsNull(firstRunDate) Or Len(Trim$(Nz(firstRunDate, ""))) = 0 Then
        Call SetAppStateValue(STATE_FIRST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "Дата первого запуска")
    End If

    Call SetAppStateValue(STATE_LAST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "Дата последнего запуска")
    Call SetAppStateValue(STATE_LAST_MACHINE_CODE, machineCode, "Последний код компьютера")

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function GetAppStateValue(ByVal stateName As String) As Variant

    On Error GoTo ErrorHandler

    If TableExists(TABLE_STATE) = False Then
        GetAppStateValue = Null
        Exit Function
    End If

    GetAppStateValue = DLookup("[StateValue]", TABLE_STATE, "[StateName] = " & SqlText(stateName))

    Exit Function

ErrorHandler:

    GetAppStateValue = Null

End Function


Private Sub SetAppStateValue( _
    ByVal stateName As String, _
    ByVal stateValue As String, _
    Optional ByVal commentText As String = "" _
)

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim existingCount As Long

    Set db = CurrentDb

    existingCount = DCount("*", TABLE_STATE, "[StateName] = " & SqlText(stateName))

    If existingCount = 0 Then

        db.Execute _
            "INSERT INTO [" & TABLE_STATE & "] " & _
            "([StateName], [StateValue], [UpdatedDate], [Comment]) " & _
            "VALUES (" & _
            SqlText(stateName) & ", " & _
            SqlText(stateValue) & ", " & _
            SqlDateTime(Now()) & ", " & _
            SqlText(commentText) & _
            ");", _
            dbFailOnError

    Else

        db.Execute _
            "UPDATE [" & TABLE_STATE & "] SET " & _
            "[StateValue] = " & SqlText(stateValue) & ", " & _
            "[UpdatedDate] = " & SqlDateTime(Now()) & ", " & _
            "[Comment] = " & SqlText(commentText) & " " & _
            "WHERE [StateName] = " & SqlText(stateName) & ";", _
            dbFailOnError

    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function HasActiveLicenseRecord() As Boolean

    On Error GoTo ErrorHandler

    HasActiveLicenseRecord = (DCount("*", TABLE_LICENSE, "[IsActive] = True") > 0)

    Exit Function

ErrorHandler:

    HasActiveLicenseRecord = False

End Function


' ============================================================
' MachineCode
' ============================================================

Private Function GetMachineFingerprintRaw() As String

    ' Собирает исходную строку отпечатка компьютера.

    On Error Resume Next

    Dim resultText As String

    resultText = ""

    resultText = resultText & "COMPUTER=" & Environ$("COMPUTERNAME") & "|"
    resultText = resultText & "USERDOMAIN=" & Environ$("USERDOMAIN") & "|"
    resultText = resultText & "MACHINEGUID=" & GetWindowsMachineGuid() & "|"
    resultText = resultText & "BIOS=" & GetWmiValue("Win32_BIOS", "SerialNumber") & "|"
    resultText = resultText & "BOARD=" & GetWmiValue("Win32_BaseBoard", "SerialNumber") & "|"
    resultText = resultText & "DISK=" & GetWmiValue("Win32_LogicalDisk", "VolumeSerialNumber", "DeviceID='C:'") & "|"

    GetMachineFingerprintRaw = UCase$(Trim$(resultText))

End Function


Private Function GetWindowsMachineGuid() As String

    On Error GoTo ErrorHandler

    Dim shellObject As Object

    Set shellObject = CreateObject("WScript.Shell")

    GetWindowsMachineGuid = CStr(shellObject.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Cryptography\MachineGuid"))

    Exit Function

ErrorHandler:

    GetWindowsMachineGuid = ""

End Function


Private Function GetWmiValue( _
    ByVal wmiClassName As String, _
    ByVal propertyName As String, _
    Optional ByVal whereCondition As String = "" _
) As String

    On Error GoTo ErrorHandler

    Dim wmiService As Object
    Dim items As Object
    Dim item As Object
    Dim queryText As String

    Set wmiService = GetObject("winmgmts:\\.\root\cimv2")

    queryText = "SELECT " & propertyName & " FROM " & wmiClassName

    If Len(Trim$(whereCondition)) > 0 Then
        queryText = queryText & " WHERE " & whereCondition
    End If

    Set items = wmiService.ExecQuery(queryText)

    For Each item In items
        GetWmiValue = Nz(CallByName(item, propertyName, VbGet), "")
        Exit Function
    Next item

    GetWmiValue = ""

    Exit Function

ErrorHandler:

    GetWmiValue = ""

End Function


Private Function HashTextSimple(ByVal sourceText As String) As String

    ' Простая устойчивая хеш-функция для короткого MachineCode.
    '
    ' Это не криптографическая подпись.
    ' Для Alpha-версии достаточно как код компьютера.
    ' Для генератора ключей позже сделаем отдельную схему подписи.

    On Error GoTo ErrorHandler

    Dim i As Long
    Dim hashValue As Currency
    Dim charCode As Long

    hashValue = 5381

    For i = 1 To Len(sourceText)

        charCode = AscW(Mid$(sourceText, i, 1)) And &HFFFF&
        hashValue = ((hashValue * 33) + charCode)

        Do While hashValue > 2147483647
            hashValue = hashValue - 2147483647
        Loop

    Next i

    HashTextSimple = Right$("00000000" & Hex$(CLng(hashValue)), 8)

    Exit Function

ErrorHandler:

    HashTextSimple = "00000000"

End Function


Private Function FormatMachineCode(ByVal hashText As String) As String

    ' Форматирует короткий код компьютера.

    hashText = Replace(hashText, "-", "")
    hashText = Replace(hashText, " ", "")
    hashText = UCase$(hashText)

    If Len(hashText) < 8 Then
        hashText = Right$("00000000" & hashText, 8)
    End If

    FormatMachineCode = "PV-" & Mid$(hashText, 1, 4) & "-" & Mid$(hashText, 5, 4)

End Function



Private Function CopyTextToClipboardSafe(ByVal sourceText As String) As Boolean

    ' Надежно копирует Unicode-текст в буфер обмена Windows.
    '
    ' Работает без ссылки на Microsoft Forms.
    ' Поддерживает 32-bit и 64-bit Access.

    On Error GoTo ErrorHandler

#If VBA7 Then

    Dim hGlobalMemory As LongPtr
    Dim lockedMemoryPointer As LongPtr
    Dim setDataResult As LongPtr
    Dim bytesCount As LongPtr

#Else

    Dim hGlobalMemory As Long
    Dim lockedMemoryPointer As Long
    Dim setDataResult As Long
    Dim bytesCount As Long

#End If

    CopyTextToClipboardSafe = False

    bytesCount = (Len(sourceText) + 1) * 2

    hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE, bytesCount)

    If hGlobalMemory = 0 Then
        Exit Function
    End If

    lockedMemoryPointer = GlobalLock(hGlobalMemory)

    If lockedMemoryPointer = 0 Then
        Exit Function
    End If

    Call lstrcpyW(lockedMemoryPointer, StrPtr(sourceText))
    Call GlobalUnlock(hGlobalMemory)

    If OpenClipboard(0) = 0 Then
        Exit Function
    End If

    Call EmptyClipboard

    setDataResult = SetClipboardData(CF_UNICODETEXT, hGlobalMemory)

    Call CloseClipboard

    CopyTextToClipboardSafe = (setDataResult <> 0)

    Exit Function

ErrorHandler:

    On Error Resume Next
    Call CloseClipboard
    CopyTextToClipboardSafe = False

End Function

' ============================================================
' Утилиты
' ============================================================

Private Function ControlExistsOnForm( _
    ByVal targetForm As Form, _
    ByVal controlName As String _
) As Boolean

    On Error GoTo ErrorHandler

    Dim ctl As Control

    For Each ctl In targetForm.Controls

        If StrComp(ctl.Name, controlName, vbTextCompare) = 0 Then
            ControlExistsOnForm = True
            Exit Function
        End If

    Next ctl

    ControlExistsOnForm = False

    Exit Function

ErrorHandler:

    ControlExistsOnForm = False

End Function


Private Function SqlText(ByVal sourceValue As Variant) As String

    If IsNull(sourceValue) Then
        SqlText = "Null"
    Else
        SqlText = "'" & Replace(CStr(sourceValue), "'", "''") & "'"
    End If

End Function


Private Function SqlDate(ByVal sourceDate As Date) As String

    SqlDate = "#" & Format$(sourceDate, "yyyy\/mm\/dd") & "#"

End Function


Private Function SqlDateTime(ByVal sourceDate As Date) As String

    SqlDateTime = "#" & Format$(sourceDate, "yyyy\/mm\/dd hh\:nn\:ss") & "#"

End Function

```

### mAppShell_HiddenRibbon_FixedXml_v2_Code.bas

**Группа:** `final_preferred`  
**Назначение:** mAppShell — настройка Alpha-оболочки; USysRibbons/CustomRibbonID использовать осторожно, при ошибке XML удалить запись PivovarHiddenRibbon.  
**SHA256:** `9e06daf6e8b645959bd2879b38add89270966d468342150e2818902cc7cebda6`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Модуль: mAppShell
'
' Назначение:
'   Упаковка Access-приложения "Пивовар" в Alpha-режим.
'
' Исправление XML Ribbon:
'   Предыдущая ошибка возникала из-за пустого:
'       <tabs></tabs>
'
'   В этой версии используется валидная скрытая вкладка с группой и кнопкой.
'   Стандартная Ribbon-лента убирается через startFromScratch="true",
'   а наша служебная вкладка скрыта через visible="false".
' ============================================================


Private Const MAIN_FORM_NAME As String = "fГлавная"

Private Const HIDDEN_RIBBON_NAME As String = "PivovarHiddenRibbon"
Private Const USYS_RIBBONS_TABLE As String = "USysRibbons"


' ============================================================
' Основные процедуры
' ============================================================

Public Sub ConfigurePivovarAlphaShell()

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Включить режим Alpha-оболочки?" & vbCrLf & vbCrLf & _
        "Будет настроен автозапуск fГлавная, скрыта стандартная лента Access " & _
        "и отключены штатные элементы интерфейса." & vbCrLf & vbCrLf & _
        "Перед выполнением рекомендуется сделать резервную копию базы.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Пивовар Alpha" _
    ) <> vbYes Then
        Exit Sub
    End If

    Call EnsureHiddenRibbon
    Call SetHiddenRibbonAsStartupRibbon

    Call SetDbProperty("StartupForm", dbText, MAIN_FORM_NAME)
    Call SetDbProperty("AllowFullMenus", dbBoolean, False)
    Call SetDbProperty("AllowShortcutMenus", dbBoolean, False)
    Call SetDbProperty("AllowBuiltInToolbars", dbBoolean, False)
    Call SetDbProperty("AllowToolbarChanges", dbBoolean, False)
    Call SetDbProperty("AllowSpecialKeys", dbBoolean, False)
    Call SetDbProperty("AllowBreakIntoCode", dbBoolean, False)
    Call SetDbProperty("StartupShowDBWindow", dbBoolean, False)
    Call SetDbProperty("StartUpShowDBWindow", dbBoolean, False)

    ' На этапе отладки оставляем обход через Shift включенным.
    Call SetDbProperty("AllowBypassKey", dbBoolean, True)

    Call HideAccessInterface

    MsgBox "Режим Alpha-оболочки включен." & vbCrLf & vbCrLf & _
           "Важно: Ribbon-лента применится после полного закрытия " & _
           "и повторного открытия базы.", _
           vbInformation, _
           "Пивовар Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось включить режим Alpha-оболочки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Пивовар Alpha"

End Sub


Public Sub ConfigurePivovarAlphaShellStrict()

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Включить строгий режим Alpha?" & vbCrLf & vbCrLf & _
        "Будет отключен обход запуска через Shift." & vbCrLf & _
        "Делать это нужно только на копии для передачи заказчику." & vbCrLf & vbCrLf & _
        "Продолжить?", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Пивовар Alpha" _
    ) <> vbYes Then
        Exit Sub
    End If

    Call EnsureHiddenRibbon
    Call SetHiddenRibbonAsStartupRibbon

    Call SetDbProperty("StartupForm", dbText, MAIN_FORM_NAME)
    Call SetDbProperty("AllowFullMenus", dbBoolean, False)
    Call SetDbProperty("AllowShortcutMenus", dbBoolean, False)
    Call SetDbProperty("AllowBuiltInToolbars", dbBoolean, False)
    Call SetDbProperty("AllowToolbarChanges", dbBoolean, False)
    Call SetDbProperty("AllowSpecialKeys", dbBoolean, False)
    Call SetDbProperty("AllowBreakIntoCode", dbBoolean, False)
    Call SetDbProperty("StartupShowDBWindow", dbBoolean, False)
    Call SetDbProperty("StartUpShowDBWindow", dbBoolean, False)
    Call SetDbProperty("AllowBypassKey", dbBoolean, False)

    Call HideAccessInterface

    MsgBox "Строгий режим Alpha включен." & vbCrLf & vbCrLf & _
           "Закройте и снова откройте базу. После проверки соберите ACCDE.", _
           vbInformation, _
           "Пивовар Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось включить строгий режим Alpha." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Пивовар Alpha"

End Sub


Public Sub RestorePivovarDeveloperShell()

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Вернуть режим разработки Access?" & vbCrLf & vbCrLf & _
        "Будут включены стандартные меню, специальные клавиши, область навигации " & _
        "и обход запуска через Shift.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Пивовар Alpha" _
    ) <> vbYes Then
        Exit Sub
    End If

    Call DeleteDbProperty("StartupForm")
    Call DeleteDbProperty("CustomRibbonID")

    Call SetDbProperty("AllowFullMenus", dbBoolean, True)
    Call SetDbProperty("AllowShortcutMenus", dbBoolean, True)
    Call SetDbProperty("AllowBuiltInToolbars", dbBoolean, True)
    Call SetDbProperty("AllowToolbarChanges", dbBoolean, True)
    Call SetDbProperty("AllowSpecialKeys", dbBoolean, True)
    Call SetDbProperty("AllowBreakIntoCode", dbBoolean, True)
    Call SetDbProperty("StartupShowDBWindow", dbBoolean, True)
    Call SetDbProperty("StartUpShowDBWindow", dbBoolean, True)
    Call SetDbProperty("AllowBypassKey", dbBoolean, True)

    Call ShowAccessInterface

    MsgBox "Режим разработки восстановлен." & vbCrLf & vbCrLf & _
           "Закройте и снова откройте базу, чтобы Ribbon полностью вернулся.", _
           vbInformation, _
           "Пивовар Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось восстановить режим разработки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Пивовар Alpha"

End Sub


Public Sub FixHiddenRibbonXmlNow()

    ' Исправляет уже созданную запись в USysRibbons.
    '
    ' Использовать, если при запуске появляется ошибка XML Ribbon.
    ' После выполнения нужно полностью закрыть и открыть базу заново.

    On Error GoTo ErrorHandler

    Call EnsureHiddenRibbon
    Call SetHiddenRibbonAsStartupRibbon

    MsgBox "XML скрытой Ribbon-ленты исправлен." & vbCrLf & vbCrLf & _
           "Полностью закройте и снова откройте базу.", _
           vbInformation, _
           "Пивовар Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось исправить XML Ribbon." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Пивовар Alpha"

End Sub


Public Sub DisableCustomRibbonNow()

    ' Аварийно отключает пользовательскую Ribbon-ленту.
    '
    ' Использовать, если ошибка XML мешает нормальной работе.
    ' После выполнения нужно закрыть и открыть базу.

    On Error Resume Next

    Call DeleteDbProperty("CustomRibbonID")
    Call ShowAccessInterface

    MsgBox "Пользовательская Ribbon-лента отключена." & vbCrLf & vbCrLf & _
           "Полностью закройте и снова откройте базу.", _
           vbInformation, _
           "Пивовар Alpha"

End Sub


Public Sub HideAccessInterface()

    On Error Resume Next

    DoCmd.ShowToolbar "Ribbon", acToolbarNo

    CommandBars("Ribbon").Visible = False
    CommandBars("Menu Bar").Enabled = False

    DoCmd.SelectObject acTable, , True
    DoCmd.RunCommand acCmdWindowHide

End Sub


Public Sub ShowAccessInterface()

    On Error Resume Next

    CommandBars("Ribbon").Visible = True
    CommandBars("Menu Bar").Enabled = True

    DoCmd.ShowToolbar "Ribbon", acToolbarYes
    DoCmd.SelectObject acTable, , True

End Sub


Public Sub PreparePivovarAlphaAccdeChecklist()

    MsgBox _
        "Порядок финальной подготовки Alpha:" & vbCrLf & vbCrLf & _
        "1. Сделать резервную копию dev-базы." & vbCrLf & _
        "2. Скрыть временные кнопки лицензии:" & vbCrLf & _
        "   - cmdCreateAlphaTrialLicense" & vbCrLf & _
        "   - cmdResetLicense" & vbCrLf & _
        "3. Проверить Tag/Дополнительные сведения = RequiresLicense на рабочих кнопках." & vbCrLf & _
        "4. Выполнить Отладка -> Компилировать." & vbCrLf & _
        "5. Нажать Включить Alpha-режим." & vbCrLf & _
        "6. Полностью закрыть и открыть базу." & vbCrLf & _
        "7. Проверить автозапуск fГлавная и скрытие Ribbon." & vbCrLf & _
        "8. Проверить лицензию и блокировку кнопок." & vbCrLf & _
        "9. На копии для передачи нажать Включить строгий режим." & vbCrLf & _
        "10. Файл -> Сохранить как -> Создать ACCDE.", _
        vbInformation, _
        "Пивовар Alpha"

End Sub


' ============================================================
' USysRibbons / скрытая Ribbon-лента
' ============================================================

Private Sub EnsureHiddenRibbon()

    On Error GoTo ErrorHandler

    If TableExists(USYS_RIBBONS_TABLE) = False Then
        Call CreateUsysRibbonsTable
    End If

    Call UpsertHiddenRibbonXml

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось создать скрытую Ribbon-ленту." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Пивовар Alpha"

End Sub


Private Sub CreateUsysRibbonsTable()

    On Error GoTo ErrorHandler

    CurrentDb.Execute _
        "CREATE TABLE [" & USYS_RIBBONS_TABLE & "] (" & _
        "[ID] AUTOINCREMENT CONSTRAINT [PrimaryKey] PRIMARY KEY, " & _
        "[RibbonName] TEXT(255), " & _
        "[RibbonXml] LONGTEXT" & _
        ");", _
        dbFailOnError

    CurrentDb.Execute _
        "CREATE UNIQUE INDEX [ux_USysRibbons_RibbonName] " & _
        "ON [" & USYS_RIBBONS_TABLE & "] ([RibbonName]);", _
        dbFailOnError

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub UpsertHiddenRibbonXml()

    On Error GoTo ErrorHandler

    Dim ribbonXml As String
    Dim existingCount As Long

    ribbonXml = GetHiddenRibbonXml()
    existingCount = DCount("*", USYS_RIBBONS_TABLE, "[RibbonName] = " & SqlText(HIDDEN_RIBBON_NAME))

    If existingCount = 0 Then

        CurrentDb.Execute _
            "INSERT INTO [" & USYS_RIBBONS_TABLE & "] ([RibbonName], [RibbonXml]) " & _
            "VALUES (" & SqlText(HIDDEN_RIBBON_NAME) & ", " & SqlText(ribbonXml) & ");", _
            dbFailOnError

    Else

        CurrentDb.Execute _
            "UPDATE [" & USYS_RIBBONS_TABLE & "] SET [RibbonXml] = " & SqlText(ribbonXml) & " " & _
            "WHERE [RibbonName] = " & SqlText(HIDDEN_RIBBON_NAME) & ";", _
            dbFailOnError

    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function GetHiddenRibbonXml() As String

    ' Валидная скрытая Ribbon-лента.
    '
    ' Важно:
    '   Не использовать пустой <tabs></tabs>.
    '   Здесь tabs содержит tab, tab содержит group, group содержит button.
    '   Все элементы скрыты через visible="false".
    '
    ' startFromScratch="true" убирает стандартные вкладки Ribbon.

    GetHiddenRibbonXml = _
        "<customUI xmlns=""http://schemas.microsoft.com/office/2006/01/customui"">" & _
        "  <ribbon startFromScratch=""true"">" & _
        "    <tabs>" & _
        "      <tab id=""tabPivovarHidden"" label=""Пивовар"" visible=""false"">" & _
        "        <group id=""grpPivovarHidden"" label=""Пивовар"" visible=""false"">" & _
        "          <button id=""btnPivovarHidden"" label=""Пивовар"" visible=""false"" />" & _
        "        </group>" & _
        "      </tab>" & _
        "    </tabs>" & _
        "  </ribbon>" & _
        "</customUI>"

End Function


Private Sub SetHiddenRibbonAsStartupRibbon()

    Call SetDbProperty("CustomRibbonID", dbText, HIDDEN_RIBBON_NAME)

End Sub


' ============================================================
' Вспомогательные процедуры
' ============================================================

Private Sub SetDbProperty( _
    ByVal propertyName As String, _
    ByVal propertyType As DAO.DataTypeEnum, _
    ByVal propertyValue As Variant _
)

    On Error GoTo ErrorHandler

    If propertyType = dbText Then

        If IsNull(propertyValue) Or Len(CStr(propertyValue)) = 0 Then
            Call DeleteDbProperty(propertyName)
            Exit Sub
        End If

    End If

    If DbPropertyExists(propertyName) = True Then

        CurrentDb.Properties(propertyName).Value = propertyValue

    Else

        Dim prp As DAO.Property

        Set prp = CurrentDb.CreateProperty(propertyName, propertyType, propertyValue)
        CurrentDb.Properties.Append prp

    End If

    Exit Sub

ErrorHandler:

    Debug.Print "Не удалось установить свойство базы:", propertyName, Err.Description

End Sub


Private Sub DeleteDbProperty(ByVal propertyName As String)

    On Error Resume Next

    If DbPropertyExists(propertyName) Then
        CurrentDb.Properties.Delete propertyName
    End If

End Sub


Private Function DbPropertyExists(ByVal propertyName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim valueHolder As Variant

    valueHolder = CurrentDb.Properties(propertyName).Value

    DbPropertyExists = True

    Exit Function

ErrorHandler:

    DbPropertyExists = False

End Function


Private Function TableExists(ByVal tableName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim tdf As DAO.TableDef

    For Each tdf In CurrentDb.TableDefs

        If StrComp(tdf.Name, tableName, vbTextCompare) = 0 Then
            TableExists = True
            Exit Function
        End If

    Next tdf

    TableExists = False

    Exit Function

ErrorHandler:

    TableExists = False

End Function


Private Function SqlText(ByVal sourceValue As Variant) As String

    If IsNull(sourceValue) Then
        SqlText = "Null"
    Else
        SqlText = "'" & Replace(CStr(sourceValue), "'", "''") & "'"
    End If

End Function

```

### fBrew_Final_GoLast_Subform_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fВарка — переход на последнюю варку, RefreshPanel для работы внутри fГлавная.  
**SHA256:** `1fc0a5ee2abc16a75c99ad851babc42db4d184bebda1c85bb0edb0bdebafbf0e`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fВарка
'
' Назначение:
'   Учет варок и отправка продукта из варки в ЦКТ
'   через универсальную модель емкостей.
'
' Главная логика:
'   - tВарка хранит исходные данные варки;
'   - tИсточникиЦКТ хранит журнал движений Варка -> ЦКТ;
'   - tСостояниеЕмкостей хранит текущее состояние ЦКТ;
'   - поля "Отправлено в ЦКТ..." на форме являются расчетными;
'   - ручной ввод в поля "Отправлено..." не используется.
'
' Важно:
'   "Завершение варки" здесь означает:
'   весь объем из котла отправлен в ЦКТ.
'
'   Это НЕ финальный розлив в кеги.
' ============================================================


Private Const RECIPE_FORM_NAME As String = "fРецепт"

Private Const VESSEL_TYPE_CCT As String = "ЦКТ"

Private Const OPERATION_BREW_TO_CCT As String = "Поступление из варки"
Private Const OPERATION_ADJUSTMENT As String = "Корректировка"

Private Const BREW_STATUS_CURRENT As String = "Текущая"
Private Const BREW_STATUS_IN_PROCESS As String = "В процессе"
Private Const BREW_STATUS_SENT_TO_CCT As String = "Разлита в ЦКТ"
Private Const BREW_STATUS_MANUAL_CLOSED As String = "Закрыта вручную"

' Служебный флаг.
' Нужен, чтобы программное снятие/установка чекбокса "Текущая варка"
' не вызывали пользовательский вопрос о ручном закрытии.
Private mInternalStatusChange As Boolean


Private Sub Form_Load()

    ' При открытии формы переходим на последнюю варку.
    '
    ' Когда fВарка открыта отдельно, переход обычно срабатывает сразу.
    '
    ' Когда fВарка открыта как подчиненная форма внутри fГлавная,
    ' Access может после Form_Load дополнительно обновить подформу
    ' и вернуть ее на первую запись.
    '
    ' Поэтому дополнительно включаем короткий одноразовый таймер:
    ' он выполнит повторный переход на последнюю варку уже после
    ' завершения загрузки родительской формы.

    Call GoToLastBrew
    Call RefreshFormData

    Me.TimerInterval = 200

End Sub

Private Sub Form_Timer()

    ' Одноразовый отложенный переход на последнюю варку.
    '
    ' Нужен для режима подчиненной формы внутри fГлавная:
    ' Access иногда после Form_Load выполняет внутренний Requery
    ' и возвращает подформу на первую запись.

    On Error Resume Next

    Me.TimerInterval = 0

    If Me.Dirty = True Then
        Me.Dirty = False
    End If

    DBEngine.Idle dbRefreshCache

    Call GoToLastBrew
    Call RefreshFormData

    Me.Refresh
    Me.Recalc
    Me.Repaint

End Sub

Private Sub Form_Current()

    ' Если идет служебная операция навигации/удаления,
    ' не обновляем интерфейс в промежуточном состоянии.
    If gFormRecordOperationBusy = True Then
        Exit Sub
    End If

    Call RefreshFormData

End Sub


Private Sub Form_BeforeInsert(Cancel As Integer)

    ' Перед созданием новой записи подставляем значения по умолчанию.
    Call ApplyNewBrewDefaults

End Sub


Private Sub Form_BeforeUpdate(Cancel As Integer)

    ' Перед сохранением:
    '   - назначаем номер варки;
    '   - согласуем статус варки;
    '   - если варка текущая, снимаем признак текущей варки с остальных записей.

    On Error GoTo ErrorHandler

    Call EnsureBrewNumberAssigned
    Call EnsureBrewStatusBeforeSave

    If Nz(Me!chkCurrentBrew.value, False) = True Then

        If IsNull(Me!txtId.value) Then

            CurrentDb.Execute _
                "UPDATE tВарка " & _
                "SET [Текущая варка] = False " & _
                "WHERE [Текущая варка] = True;", _
                dbFailOnError

        Else

            CurrentDb.Execute _
                "UPDATE tВарка " & _
                "SET [Текущая варка] = False " & _
                "WHERE [Текущая варка] = True " & _
                "AND [Код] <> " & CLng(Me!txtId.value) & ";", _
                dbFailOnError

        End If

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сохранить варку." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Сохранение варки"

    Cancel = True

End Sub


Private Sub Form_AfterInsert()

    ' После добавления новой варки сохраняем снимок состава рецепта.
    Call SaveBrewRecipeCompositionIfNeeded

    ' Обновляем расчетные поля.
    Call RefreshFormData

End Sub


Private Sub Form_AfterUpdate()

    ' После сохранения варки сохраняем состав рецепта,
    ' если он еще не был сохранен.
    Call SaveBrewRecipeCompositionIfNeeded

    ' Обновляем расчетные поля.
    Call RefreshFormData

End Sub


Private Sub cboRecipe_DropDown()

    ' Перед раскрытием списка обновляем список рецептов.
    Me!cboRecipe.Requery

End Sub


Private Sub cboRecipe_AfterUpdate()

    ' После выбора рецепта формируем текстовый снимок рецепта.
    Call RefreshRecipeAfterSelection

End Sub


Private Sub txtOutputKettleL_AfterUpdate()

    ' После изменения выхода из котла пересчитываем остаток.
    Call RefreshFormData

End Sub


Private Sub chkCurrentBrew_AfterUpdate()

    ' Управляет ручным снятием признака "Текущая варка".
    '
    ' Если пользователь снимает активный чекбокс:
    '   Да  — закрыть варку вручную;
    '   Нет — не закрывать и вернуть галочку обратно.

    On Error GoTo ErrorHandler

    Dim userAnswer As VbMsgBoxResult

    If mInternalStatusChange = True Then
        Exit Sub
    End If

    If Nz(Me!chkCurrentBrew.value, False) = True Then

        If HasUnfinishedBrew(GetCurrentBrewId()) = True Then

            MsgBox "Нельзя сделать эту варку текущей, потому что уже есть другая незавершенная варка.", _
                   vbExclamation, _
                   "Текущая варка"

            mInternalStatusChange = True
            Me!chkCurrentBrew.value = False
            mInternalStatusChange = False

            Exit Sub

        End If

        Me!txtBrewStatus.value = BREW_STATUS_CURRENT
        Me!txtBrewFinishDate.value = Null

        If Me.Dirty = True Then
            Me.Dirty = False
        End If

    Else

        If Nz(Me!txtBrewStatus.value, "") = BREW_STATUS_CURRENT Then

            userAnswer = MsgBox( _
                "Закрыть варку вручную?" & vbCrLf & vbCrLf & _
                "Да — закрыть варку вручную, списать остаток из котла и разрешить создание новой варки." & vbCrLf & _
                "Нет — не закрывать варку и оставить ее текущей.", _
                vbQuestion + vbYesNo + vbDefaultButton2, _
                "Снятие текущей варки" _
            )

            If userAnswer = vbYes Then

                If ManuallyCloseCurrentBrew(True) = False Then

                    mInternalStatusChange = True
                    Me!chkCurrentBrew.value = True
                    Me!txtBrewStatus.value = BREW_STATUS_CURRENT
                    Me!txtBrewFinishDate.value = Null
                    mInternalStatusChange = False

                End If

            Else

                mInternalStatusChange = True
                Me!chkCurrentBrew.value = True
                Me!txtBrewStatus.value = BREW_STATUS_CURRENT
                Me!txtBrewFinishDate.value = Null
                mInternalStatusChange = False

            End If

        End If

    End If

    Exit Sub

ErrorHandler:

    mInternalStatusChange = False

    MsgBox "Не удалось обработать признак текущей варки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Текущая варка"

End Sub


' ============================================================
' Кнопки управления записями
' ============================================================

Private Sub cmdNewRecord_Click()

    ' Создает новую варку.
    '
    ' Новая варка запрещена, если есть незавершенная варка.
    ' В текущей логике незавершенная варка — это варка,
    ' которая еще не полностью отправлена в ЦКТ.

    On Error GoTo ErrorHandler

    If HasUnfinishedBrew(0) = True Then

        MsgBox "Нельзя создать новую варку, пока предыдущая варка не разлита в ЦКТ." & vbCrLf & vbCrLf & _
               "Сначала необходимо отправить весь объем текущей варки в ЦКТ " & _
               "или закрыть варку вручную в исключительном случае.", _
               vbExclamation, _
               "Создание варки"

        Exit Sub

    End If

    If CreateNewFormRecord(Me) = True Then

        If Me.NewRecord = True Then
            Call ApplyNewBrewDefaults
        End If

        Call RefreshFormData

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось создать новую варку." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Создание варки"

End Sub


Private Sub cmdSaveRecord_Click()

    ' Сохраняет текущую запись варки.

    If SaveCurrentFormRecord(Me) = True Then

        Call SaveBrewRecipeCompositionIfNeeded
        Call RefreshFormData

    End If

End Sub


Private Sub cmdDeleteRecord_Click()

    ' Удаляет варку только если по ней еще нет движений в ЦКТ.

    Call DeleteCurrentBrewSafely

End Sub


Private Sub cmdPreviousRecord_Click()

    ' Переход на предыдущую существующую запись.

    Call MoveToPreviousExistingRecord(Me)
    Call RefreshFormData

End Sub


Private Sub cmdNextRecord_Click()

    ' Переход на следующую существующую запись.

    Call MoveToNextExistingRecord(Me)
    Call RefreshFormData

End Sub


' ============================================================
' Кнопка формы рецептов
' ============================================================

Private Sub cmdOpenRecipe_Click()

    ' Открывает форму рецептов.
    '
    ' Если рецепт выбран — открывает форму с фильтром.
    ' Если рецепт не выбран — открывает форму на добавление.

    On Error GoTo ErrorHandler

    Dim whereCondition As String

    If Nz(Me!cboRecipe.value, "") <> "" Then

        whereCondition = "[Имя рецепта] = '" & EscapeSqlText(CStr(Me!cboRecipe.value)) & "'"

        DoCmd.OpenForm _
            formName:=RECIPE_FORM_NAME, _
            View:=acNormal, _
            whereCondition:=whereCondition, _
            DataMode:=acFormEdit, _
            WindowMode:=acDialog

    Else

        DoCmd.OpenForm _
            formName:=RECIPE_FORM_NAME, _
            View:=acNormal, _
            DataMode:=acFormAdd, _
            WindowMode:=acDialog

    End If

    Me!cboRecipe.Requery
    Call RefreshRecipeAfterSelection
    Call RefreshFormData

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть форму рецептов." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Рецепты"

End Sub


' ============================================================
' Кнопки отправки остатка в ЦКТ
' ============================================================

Private Sub cmdSendRestToCCT1_Click()
    Call SendRestToCCT(1)
End Sub

Private Sub cmdSendRestToCCT2_Click()
    Call SendRestToCCT(2)
End Sub

Private Sub cmdSendRestToCCT3_Click()
    Call SendRestToCCT(3)
End Sub

Private Sub cmdSendRestToCCT4_Click()
    Call SendRestToCCT(4)
End Sub

Private Sub cmdSendRestToCCT5_Click()
    Call SendRestToCCT(5)
End Sub

Private Sub cmdSendRestToCCT6_Click()
    Call SendRestToCCT(6)
End Sub


' ============================================================
' Кнопки ручной отправки / корректировки в ЦКТ
' ============================================================

Private Sub cmdManualSendToCCT1_Click()
    Call ManualSendToCCT(1)
End Sub

Private Sub cmdManualSendToCCT2_Click()
    Call ManualSendToCCT(2)
End Sub

Private Sub cmdManualSendToCCT3_Click()
    Call ManualSendToCCT(3)
End Sub

Private Sub cmdManualSendToCCT4_Click()
    Call ManualSendToCCT(4)
End Sub

Private Sub cmdManualSendToCCT5_Click()
    Call ManualSendToCCT(5)
End Sub

Private Sub cmdManualSendToCCT6_Click()
    Call ManualSendToCCT(6)
End Sub


' ============================================================
' Основная логика отправки в ЦКТ
' ============================================================

Private Sub SendRestToCCT(ByVal cctNumber As Long)

    ' Отправляет весь текущий остаток в указанный ЦКТ.

    On Error GoTo ErrorHandler

    Dim restVolumeL As Double

    Call RefreshFormData

    restVolumeL = Nz(Me!txtCurrentKettel.value, 0)

    If restVolumeL <= 0 Then

        MsgBox "Остаток в котле равен " & restVolumeL & " л." & vbCrLf & _
               "Отправлять нечего.", _
               vbInformation, _
               "Отправка остатка"

        Exit Sub

    End If

    Call SendVolumeToCCT( _
        cctNumber:=cctNumber, _
        operationVolumeL:=restVolumeL, _
        operationType:=OPERATION_BREW_TO_CCT, _
        commentText:="" _
    )

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось отправить остаток в ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Отправка остатка"

End Sub


Private Sub ManualSendToCCT(ByVal cctNumber As Long)

    ' Ручная операция с ЦКТ:
    '
    '   положительное число может быть:
    '       - обычным поступлением из варки;
    '       - положительной корректировкой;
    '
    '   отрицательное число всегда является корректировкой.
    '
    ' Для любой корректировки комментарий обязателен.

    On Error GoTo ErrorHandler

    Dim inputText As String
    Dim commentText As String
    Dim operationVolumeL As Double
    Dim operationType As String
    Dim userAnswer As VbMsgBoxResult

    inputText = InputBox( _
        "Введите объем операции для ЦКТ" & cctNumber & " в литрах." & vbCrLf & vbCrLf & _
        "Примеры:" & vbCrLf & _
        "100  — добавить 100 л" & vbCrLf & _
        "-20  — корректировка минус 20 л", _
        "Операция с ЦКТ" & cctNumber _
    )

    If Trim(inputText) = "" Then
        Exit Sub
    End If

    If TryParseVolume(inputText, operationVolumeL) = False Then

        MsgBox "Не удалось распознать объем операции." & vbCrLf & _
               "Введите число, например 100 или -20.", _
               vbExclamation, _
               "Операция с ЦКТ"

        Exit Sub

    End If

    If operationVolumeL = 0 Then

        MsgBox "Объем операции не может быть равен 0.", _
               vbExclamation, _
               "Операция с ЦКТ"

        Exit Sub

    End If

    If operationVolumeL < 0 Then

        operationType = OPERATION_ADJUSTMENT

        commentText = InputBox( _
            "Для корректировки необходимо указать причину.", _
            "Комментарий к корректировке" _
        )

        If Trim(commentText) = "" Then

            MsgBox "Операция отменена." & vbCrLf & _
                   "Для корректировки комментарий обязателен.", _
                   vbInformation, _
                   "Корректировка"

            Exit Sub

        End If

    Else

        userAnswer = MsgBox( _
            "Как выполнить операцию +" & operationVolumeL & " л для ЦКТ" & cctNumber & "?" & vbCrLf & vbCrLf & _
            "Да — обычное поступление из варки." & vbCrLf & _
            "Нет — положительная корректировка ранее отправленного объема.", _
            vbQuestion + vbYesNo + vbDefaultButton1, _
            "Тип операции" _
        )

        If userAnswer = vbYes Then

            operationType = OPERATION_BREW_TO_CCT
            commentText = ""

        Else

            operationType = OPERATION_ADJUSTMENT

            commentText = InputBox( _
                "Для положительной корректировки необходимо указать причину.", _
                "Комментарий к корректировке" _
            )

            If Trim(commentText) = "" Then

                MsgBox "Операция отменена." & vbCrLf & _
                       "Для корректировки комментарий обязателен.", _
                       vbInformation, _
                       "Корректировка"

                Exit Sub

            End If

        End If

    End If

    Call SendVolumeToCCT( _
        cctNumber:=cctNumber, _
        operationVolumeL:=operationVolumeL, _
        operationType:=operationType, _
        commentText:=commentText _
    )

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить ручную операцию с ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операция с ЦКТ"

End Sub


Private Sub SendVolumeToCCT( _
    ByVal cctNumber As Long, _
    ByVal operationVolumeL As Double, _
    ByVal operationType As String, _
    ByVal commentText As String _
)

    ' Универсальная отправка объема в выбранный ЦКТ.
    '
    ' Визуально пользователь работает с ЦКТ1...ЦКТ6,
    ' а внутри код получает Код емкости из tЕмкости.

    On Error GoTo ErrorHandler

    Dim vesselId As Long
    Dim vesselName As String
    Dim brewId As Long
    Dim brewNumber As Long
    Dim brewDate As Date
    Dim recipeName As String
    Dim currentRestL As Double
    Dim sentToThisVesselL As Double
    Dim userAnswer As VbMsgBoxResult

    If EnsureBrewSavedForMovement() = False Then
        Exit Sub
    End If

    brewId = CLng(Me!txtId.value)
    brewNumber = CLng(Me!txtBrewNumber.value)
    brewDate = CDate(Me!txtBrewDate.value)
    recipeName = CStr(Me!cboRecipe.value)

    vesselId = GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, cctNumber)
    vesselName = GetVesselNameById(vesselId)

    If vesselId <= 0 Then

        MsgBox "Не найдена емкость ЦКТ" & cctNumber & " в справочнике tЕмкости.", _
               vbExclamation, _
               "ЦКТ" & cctNumber

        Exit Sub

    End If

    currentRestL = CalculateCurrentBrewRest()

    ' Любая положительная операция уменьшает остаток варки,
    ' поэтому не разрешаем отправить/добавить больше, чем осталось в котле.
    If operationVolumeL > 0 Then

        If operationVolumeL > currentRestL Then

            MsgBox "Нельзя отправить больше, чем осталось в котле." & vbCrLf & vbCrLf & _
                   "Осталось в котле: " & currentRestL & " л" & vbCrLf & _
                   "Объем операции: " & operationVolumeL & " л", _
                   vbExclamation, _
                   "Недостаточно объема"

            Exit Sub

        End If

    End If

    ' Для любой корректировки проверяем,
    ' что из этой варки в этот ЦКТ уже было поступление.
    If StrComp(operationType, OPERATION_ADJUSTMENT, vbTextCompare) = 0 Then

        sentToThisVesselL = GetBrewSentToVessel(brewId, vesselId)

        If sentToThisVesselL <= 0 Then

            MsgBox "Нельзя выполнить корректировку, потому что из этой варки в " & vesselName & _
                   " еще не было поступления." & vbCrLf & vbCrLf & _
                   "Если нужно впервые отправить объем в емкость, используйте обычное поступление из варки.", _
                   vbExclamation, _
                   "Корректировка"

            Exit Sub

        End If

        If operationVolumeL < 0 And Abs(operationVolumeL) > sentToThisVesselL Then

            MsgBox "Нельзя выполнить отрицательную корректировку больше уже отправленного объема." & vbCrLf & vbCrLf & _
                   "Из этой варки в " & vesselName & " отправлено: " & sentToThisVesselL & " л" & vbCrLf & _
                   "Корректировка: " & operationVolumeL & " л", _
                   vbExclamation, _
                   "Корректировка"

            Exit Sub

        End If

    End If

    userAnswer = MsgBox( _
        "Выполнить операцию?" & vbCrLf & vbCrLf & _
        "Варка №" & brewNumber & vbCrLf & _
        "Сорт: " & recipeName & vbCrLf & _
        "Емкость: " & vesselName & vbCrLf & _
        "Тип операции: " & operationType & vbCrLf & _
        "Объем: " & operationVolumeL & " л", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Подтверждение операции" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    If RegisterBrewToVessel( _
        brewId:=brewId, _
        brewNumber:=brewNumber, _
        brewDate:=brewDate, _
        recipeName:=recipeName, _
        vesselId:=vesselId, _
        operationVolumeL:=operationVolumeL, _
        operationType:=operationType, _
        commentText:=commentText _
    ) = False Then

        Exit Sub

    End If

    Call RefreshFormData
    Call AutoUpdateBrewCctCompletionState(True)

    Call RefreshMainFormAfterOperation

    MsgBox "Операция выполнена." & vbCrLf & vbCrLf & _
           "Емкость: " & vesselName & vbCrLf & _
           "Объем: " & operationVolumeL & " л", _
           vbInformation, _
           "Операция выполнена"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить операцию с ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операция с ЦКТ"

End Sub


' ============================================================
' Автоматическое завершение / возврат статуса варки
' ============================================================

Private Sub AutoUpdateBrewCctCompletionState(Optional ByVal showMessage As Boolean = True)

    ' Автоматически обновляет состояние варки после операций Варка -> ЦКТ.
    '
    ' Если остаток в котле стал 0:
    '   - снимает признак "Текущая варка";
    '   - ставит статус "Разлита в ЦКТ";
    '   - ставит дату завершения.
    '
    ' Если после корректировки остаток снова стал больше 0:
    '   - возвращает статус "В процессе";
    '   - очищает дату завершения;
    '   - если нет другой незавершенной варки, снова ставит признак "Текущая варка".

    On Error GoTo ErrorHandler

    Dim currentRestL As Double
    Dim currentStatus As String
    Dim hasOtherUnfinished As Boolean

    If Me.NewRecord = True Then
        Exit Sub
    End If

    If IsNull(Me!txtId.value) Then
        Exit Sub
    End If

    currentRestL = CalculateCurrentBrewRest()
    currentStatus = Nz(Me!txtBrewStatus.value, "")

    ' Небольшой допуск на дробные значения.
    If Abs(currentRestL) <= 0.0001 Then

        If currentStatus <> BREW_STATUS_SENT_TO_CCT _
           And currentStatus <> BREW_STATUS_MANUAL_CLOSED Then

            mInternalStatusChange = True

            Me!chkCurrentBrew.value = False
            Me!txtBrewStatus.value = BREW_STATUS_SENT_TO_CCT
            Me!txtBrewFinishDate.value = Date

            mInternalStatusChange = False

            If Me.Dirty = True Then
                Me.Dirty = False
            End If

            Call RefreshFormData

            If showMessage = True Then

                MsgBox "Варка полностью разлита в ЦКТ." & vbCrLf & vbCrLf & _
                       "Признак ""Текущая варка"" снят автоматически.", _
                       vbInformation, _
                       "Варка завершена"

            End If

        End If

    ElseIf currentRestL > 0 Then

        If currentStatus = BREW_STATUS_SENT_TO_CCT Then

            hasOtherUnfinished = HasUnfinishedBrew(GetCurrentBrewId())

            Me!txtBrewStatus.value = BREW_STATUS_IN_PROCESS
            Me!txtBrewFinishDate.value = Null

            mInternalStatusChange = True

            If hasOtherUnfinished = False Then
                Me!chkCurrentBrew.value = True
            Else
                Me!chkCurrentBrew.value = False
            End If

            mInternalStatusChange = False

            If Me.Dirty = True Then
                Me.Dirty = False
            End If

            Call RefreshFormData

            If showMessage = True Then

                MsgBox "После корректировки у варки снова появился остаток в котле." & vbCrLf & vbCrLf & _
                       "Статус варки возвращен: ""В процессе"".", _
                       vbInformation, _
                       "Статус варки изменен"

            End If

        End If

    End If

    Exit Sub

ErrorHandler:

    mInternalStatusChange = False

    MsgBox "Не удалось автоматически обновить статус варки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Статус варки"

End Sub


Private Function ManuallyCloseCurrentBrew(Optional ByVal alreadyConfirmed As Boolean = False) As Boolean

    ' Закрывает текущую варку вручную.
    '
    ' Логика:
    '   - остаток из котла списывается;
    '   - причина списания обязательна;
    '   - статус становится "Закрыта вручную";
    '   - признак "Текущая варка" снимается;
    '   - дата завершения ставится текущей датой;
    '   - комментарий пишется через связанное поле формы,
    '     без отдельного Recordset, чтобы не было конфликта записи.

    On Error GoTo ErrorHandler

    Dim currentRestL As Double
    Dim userAnswer As VbMsgBoxResult
    Dim reasonText As String
    Dim writeOffText As String

    ManuallyCloseCurrentBrew = False

    If Me.NewRecord = True Then

        MsgBox "Новая варка еще не сохранена. Закрывать нечего.", _
               vbInformation, _
               "Ручное закрытие варки"

        Exit Function

    End If

    If IsNull(Me!txtId.value) Then

        MsgBox "Не удалось определить Код варки.", _
               vbExclamation, _
               "Ручное закрытие варки"

        Exit Function

    End If

    currentRestL = CalculateCurrentBrewRest()

    If currentRestL < -0.0001 Then

        MsgBox "Нельзя закрыть варку вручную, потому что расчетный остаток в котле отрицательный." & vbCrLf & vbCrLf & _
               "Остаток в котле: " & currentRestL & " л" & vbCrLf & _
               "Сначала исправьте отправленные объемы корректировкой.", _
               vbExclamation, _
               "Ручное закрытие варки"

        Exit Function

    End If

    If alreadyConfirmed = False Then

        userAnswer = MsgBox( _
            "Закрыть текущую варку вручную?" & vbCrLf & vbCrLf & _
            "Остаток в котле: " & currentRestL & " л" & vbCrLf & vbCrLf & _
            "Остаток будет списан из котла." & vbCrLf & _
            "После этого программа разрешит создать новую варку.", _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            "Ручное закрытие варки" _
        )

        If userAnswer <> vbYes Then
            Exit Function
        End If

    End If

    reasonText = InputBox( _
        "Укажите причину ручного закрытия варки." & vbCrLf & vbCrLf & _
        "Остаток в котле: " & currentRestL & " л", _
        "Причина ручного закрытия" _
    )

    If Trim(reasonText) = "" Then

        MsgBox "Ручное закрытие отменено." & vbCrLf & _
               "Для ручного закрытия необходимо указать причину.", _
               vbInformation, _
               "Ручное закрытие варки"

        Exit Function

    End If

    If currentRestL > 0.0001 Then

        ' Списываем остаток из котла.
        Me!txtKettleWriteOffL.value = Nz(Me!txtKettleWriteOffL.value, 0) + currentRestL

        writeOffText = _
            "Ручное закрытие варки: " & Format(Now(), "dd.mm.yyyy hh:nn") & vbCrLf & _
            "Списано из котла: " & currentRestL & " л" & vbCrLf & _
            "Причина: " & reasonText

        Me!txtKettleWriteOffReason.value = AppendTextBlock( _
            Nz(Me!txtKettleWriteOffReason.value, ""), _
            writeOffText _
        )

    Else

        writeOffText = _
            "Ручное закрытие варки: " & Format(Now(), "dd.mm.yyyy hh:nn") & vbCrLf & _
            "Остаток в котле на момент закрытия: " & currentRestL & " л" & vbCrLf & _
            "Причина: " & reasonText

    End If

    ' Пишем комментарий напрямую в связанное поле формы.
    ' Так не возникает конфликта записи.
    Me!txtBrewComment.value = AppendTextBlock( _
        Nz(Me!txtBrewComment.value, ""), _
        writeOffText _
    )

    mInternalStatusChange = True

    Me!chkCurrentBrew.value = False
    Me!txtBrewStatus.value = BREW_STATUS_MANUAL_CLOSED
    Me!txtBrewFinishDate.value = Date

    mInternalStatusChange = False

    If Me.Dirty = True Then
        Me.Dirty = False
    End If

    Call RefreshFormData

    MsgBox "Варка закрыта вручную." & vbCrLf & vbCrLf & _
           "Теперь можно создать новую варку.", _
           vbInformation, _
           "Ручное закрытие варки"

    ManuallyCloseCurrentBrew = True

    Exit Function

ErrorHandler:

    mInternalStatusChange = False
    ManuallyCloseCurrentBrew = False

    MsgBox "Не удалось закрыть варку вручную." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Ручное закрытие варки"

End Function


' ============================================================
' Обновление расчетных данных формы
' ============================================================

Private Sub RefreshFormData()

    ' Обновляет:
    '   - текст полного рецепта;
    '   - отправлено по ЦКТ1...ЦКТ6;
    '   - остаток в котле;
    '   - счетчик записей.

    On Error Resume Next

    Call RefreshFullRecipe
    Call RefreshCctSentAmounts
    Call RefreshCurrentKettel
    Call RefreshRecordUi

End Sub


Private Sub RefreshCctSentAmounts()

    ' Обновляет информационные поля:
    '   txtSentCCT1L ... txtSentCCT6L

    On Error GoTo ErrorHandler

    Dim brewId As Long

    If Me.NewRecord = True Or IsNull(Me!txtId.value) Then

        Me!txtSentCCT1L.value = 0
        Me!txtSentCCT2L.value = 0
        Me!txtSentCCT3L.value = 0
        Me!txtSentCCT4L.value = 0
        Me!txtSentCCT5L.value = 0
        Me!txtSentCCT6L.value = 0

        Exit Sub

    End If

    brewId = CLng(Me!txtId.value)

    Me!txtSentCCT1L.value = GetBrewSentToVessel(brewId, GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, 1))
    Me!txtSentCCT2L.value = GetBrewSentToVessel(brewId, GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, 2))
    Me!txtSentCCT3L.value = GetBrewSentToVessel(brewId, GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, 3))
    Me!txtSentCCT4L.value = GetBrewSentToVessel(brewId, GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, 4))
    Me!txtSentCCT5L.value = GetBrewSentToVessel(brewId, GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, 5))
    Me!txtSentCCT6L.value = GetBrewSentToVessel(brewId, GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, 6))

    Exit Sub

ErrorHandler:

    Me!txtSentCCT1L.value = 0
    Me!txtSentCCT2L.value = 0
    Me!txtSentCCT3L.value = 0
    Me!txtSentCCT4L.value = 0
    Me!txtSentCCT5L.value = 0
    Me!txtSentCCT6L.value = 0

End Sub


Private Sub RefreshCurrentKettel()

    ' Рассчитывает остаток в котле:
    '
    ' Осталось =
    '   На выходе из котла -
    '   сумма всех неотмененных отправок из этой варки в ЦКТ -
    '   списано из котла

    On Error GoTo ErrorHandler

    Me!txtCurrentKettel.value = CalculateCurrentBrewRest()

    Exit Sub

ErrorHandler:

    Me!txtCurrentKettel.value = Null

End Sub


Private Function CalculateCurrentBrewRest() As Double

    ' Возвращает текущий остаток в котле по данной варке.
    '
    ' Остаток =
    '   На выходе из котла -
    '   отправлено в ЦКТ -
    '   списано из котла

    On Error GoTo ErrorHandler

    Dim brewId As Long
    Dim outputKettleL As Double
    Dim totalSentL As Double
    Dim writtenOffL As Double

    outputKettleL = Nz(Me!txtOutputKettleL.value, 0)
    writtenOffL = Nz(Me!txtKettleWriteOffL.value, 0)

    If Me.NewRecord = True Or IsNull(Me!txtId.value) Then

        CalculateCurrentBrewRest = outputKettleL - writtenOffL
        Exit Function

    End If

    brewId = CLng(Me!txtId.value)

    totalSentL = GetBrewTotalSentToCCT(brewId)

    CalculateCurrentBrewRest = outputKettleL - totalSentL - writtenOffL

    Exit Function

ErrorHandler:

    CalculateCurrentBrewRest = 0

End Function


Private Sub RefreshRecordUi()

    ' Обновляет счетчик записей.

    On Error GoTo ErrorHandler

    Me!txtRecordCounter.value = GetFormRecordPositionText(Me)

    Exit Sub

ErrorHandler:

    On Error Resume Next
    Me!txtRecordCounter.value = ""

End Sub


' ============================================================
' Рецепт и состав варки
' ============================================================

Private Sub RefreshRecipeAfterSelection()

    ' Обновляет текстовый снимок рецепта после выбора рецепта.

    On Error GoTo ErrorHandler

    Dim recipeText As String

    If Nz(Me!cboRecipe.value, "") = "" Then

        Me!txtFullRecipe.value = Null
        Me!txtRecipeSnapshot.value = Null

    Else

        recipeText = BuildFullRecipeText(CStr(Me!cboRecipe.value))

        Me!txtFullRecipe.value = recipeText
        Me!txtRecipeSnapshot.value = recipeText

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось обновить состав рецепта." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Рецепт"

End Sub


Private Sub RefreshFullRecipe()

    ' Обновляет справочное поле полного рецепта.

    On Error GoTo ErrorHandler

    If Nz(Me!cboRecipe.value, "") = "" Then

        Me!txtFullRecipe.value = Null

    ElseIf Nz(Me!txtRecipeSnapshot.value, "") <> "" Then

        Me!txtFullRecipe.value = Me!txtRecipeSnapshot.value

    Else

        Me!txtFullRecipe.value = BuildFullRecipeText(CStr(Me!cboRecipe.value))

    End If

    Exit Sub

ErrorHandler:

    Me!txtFullRecipe.value = Null

End Sub


Private Function BuildFullRecipeText(ByVal recipeName As String) As String

    ' Формирует текстовый состав рецепта из tРецепт.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim sqlText As String
    Dim resultText As String
    Dim lineText As String

    Set db = CurrentDb

    sqlText = _
        "SELECT " & _
        "   [Имя параметра рецепта], " & _
        "   [Количество], " & _
        "   [Единицы измерения параметра], " & _
        "   [Группа параметра] " & _
        "FROM [tРецепт] " & _
        "WHERE [Имя рецепта] = '" & EscapeSqlText(recipeName) & "' " & _
        "ORDER BY [Код];"

    Set rs = db.OpenRecordset(sqlText, dbOpenSnapshot)

    If rs.EOF Then
        BuildFullRecipeText = ""
        GoTo ExitPoint
    End If

    resultText = ""
    resultText = resultText & "Рецепт: " & recipeName & vbCrLf
    resultText = resultText & "Состав рецепта:" & vbCrLf

    Do While Not rs.EOF

        lineText = ""

        If Nz(rs.Fields("Группа параметра").value, "") <> "" Then
            lineText = lineText & "[" & Nz(rs.Fields("Группа параметра").value, "") & "] "
        End If

        lineText = lineText & Nz(rs.Fields("Имя параметра рецепта").value, "")

        If Not IsNull(rs.Fields("Количество").value) Then
            lineText = lineText & " — " & rs.Fields("Количество").value
        End If

        If Nz(rs.Fields("Единицы измерения параметра").value, "") <> "" Then
            lineText = lineText & " " & Nz(rs.Fields("Единицы измерения параметра").value, "")
        End If

        resultText = resultText & lineText & vbCrLf

        rs.MoveNext

    Loop

    BuildFullRecipeText = resultText

ExitPoint:

    On Error Resume Next

    If Not rs Is Nothing Then
        rs.Close
    End If

    Set rs = Nothing
    Set db = Nothing

    Exit Function

ErrorHandler:

    BuildFullRecipeText = ""
    Resume ExitPoint

End Function


Private Sub SaveBrewRecipeCompositionIfNeeded()

    ' Копирует состав рецепта из tРецепт в tСоставВарки.
    '
    ' Важно:
    '   если состав для этой варки уже есть,
    '   автоматически его не перезаписываем.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim rsRecipe As DAO.Recordset
    Dim rsBrewComposition As DAO.Recordset

    Dim brewId As Long
    Dim brewNumber As Long
    Dim brewDate As Date
    Dim recipeName As String
    Dim existingCount As Long
    Dim sqlText As String

    If Me.NewRecord = True Then
        Exit Sub
    End If

    If IsNull(Me!txtId.value) Then
        Exit Sub
    End If

    If Nz(Me!cboRecipe.value, "") = "" Then
        Exit Sub
    End If

    If IsNull(Me!txtBrewDate.value) Then
        Exit Sub
    End If

    brewId = CLng(Me!txtId.value)
    brewNumber = CLng(Nz(Me!txtBrewNumber.value, 0))
    brewDate = CDate(Me!txtBrewDate.value)
    recipeName = CStr(Me!cboRecipe.value)

    existingCount = DCount("*", "tСоставВарки", "[Код варки] = " & brewId)

    If existingCount > 0 Then
        Exit Sub
    End If

    Set db = CurrentDb

    sqlText = _
        "SELECT * FROM [tРецепт] " & _
        "WHERE [Имя рецепта] = '" & EscapeSqlText(recipeName) & "' " & _
        "ORDER BY [Код];"

    Set rsRecipe = db.OpenRecordset(sqlText, dbOpenSnapshot)
    Set rsBrewComposition = db.OpenRecordset("tСоставВарки", dbOpenDynaset)

    Do While Not rsRecipe.EOF

        rsBrewComposition.AddNew

        rsBrewComposition.Fields("Код варки").value = brewId
        rsBrewComposition.Fields("Номер варки").value = brewNumber
        rsBrewComposition.Fields("Дата варки").value = brewDate
        rsBrewComposition.Fields("Имя рецепта").value = recipeName
        rsBrewComposition.Fields("Имя параметра рецепта").value = Nz(rsRecipe.Fields("Имя параметра рецепта").value, "")
        rsBrewComposition.Fields("Количество").value = Nz(rsRecipe.Fields("Количество").value, 0)
        rsBrewComposition.Fields("Единицы измерения параметра").value = Nz(rsRecipe.Fields("Единицы измерения параметра").value, "")
        rsBrewComposition.Fields("Группа параметра").value = Nz(rsRecipe.Fields("Группа параметра").value, "")
        rsBrewComposition.Fields("Учитывать в расходе").value = Nz(rsRecipe.Fields("Учитывать в расходе").value, False)
        rsBrewComposition.Fields("Тип строки").value = "Снимок рецепта"
        rsBrewComposition.Fields("Комментарий").value = Nz(rsRecipe.Fields("Комментарий").value, "")
        rsBrewComposition.Fields("Отменена").value = False

        rsBrewComposition.Update

        rsRecipe.MoveNext

    Loop

ExitPoint:

    On Error Resume Next

    If Not rsRecipe Is Nothing Then
        rsRecipe.Close
    End If

    If Not rsBrewComposition Is Nothing Then
        rsBrewComposition.Close
    End If

    Set rsRecipe = Nothing
    Set rsBrewComposition = Nothing
    Set db = Nothing

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сохранить состав варки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Состав варки"

    Resume ExitPoint

End Sub


' ============================================================
' Создание, сохранение, удаление варки
' ============================================================

Private Sub ApplyNewBrewDefaults()

    ' Значения по умолчанию для новой варки.
    '
    ' Новая варка автоматически становится текущей,
    ' потому что создание новой варки уже запрещено,
    ' если есть незавершенная предыдущая варка.

    On Error GoTo ErrorHandler

    If IsNull(Me!txtBrewDate.value) Then
        Me!txtBrewDate.value = Date
    End If

    Call EnsureBrewNumberAssigned

    Me!chkCurrentBrew.value = True
    Me!txtBrewStatus.value = BREW_STATUS_CURRENT
    Me!txtBrewFinishDate.value = Null

    Me!txtKettleWriteOffL.value = 0
    Me!txtKettleWriteOffReason.value = Null

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось заполнить значения новой варки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Новая варка"

End Sub


Private Sub EnsureBrewNumberAssigned()

    ' Назначает следующий номер варки, если номер пустой или 0.

    On Error GoTo ErrorHandler

    If Nz(Me!txtBrewNumber.value, 0) <= 0 Then
        Me!txtBrewNumber.value = GetNextBrewNumber()
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось назначить номер варки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Номер варки"

End Sub


Private Function GetNextBrewNumber() As Long

    ' Следующий сквозной номер варки.

    On Error GoTo ErrorHandler

    GetNextBrewNumber = Nz(DMax("[Номер варки]", "tВарка", "[Номер варки] Is Not Null AND [Номер варки] > 0"), 0) + 1

    Exit Function

ErrorHandler:

    GetNextBrewNumber = 0

End Function


Private Sub EnsureBrewStatusBeforeSave()

    ' Перед сохранением приводит статус варки в согласованное состояние.
    '
    ' Логика:
    '   - если статус "Разлита в ЦКТ" или "Закрыта вручную" —
    '     не перетираем его автоматически;
    '   - если стоит "Текущая варка" — статус = Текущая;
    '   - прочие незавершенные варианты считаем "В процессе".

    On Error GoTo ErrorHandler

    Dim currentStatus As String

    currentStatus = Nz(Me!txtBrewStatus.value, "")

    If currentStatus = BREW_STATUS_SENT_TO_CCT _
       Or currentStatus = BREW_STATUS_MANUAL_CLOSED Then

        Exit Sub

    End If

    If Nz(Me!chkCurrentBrew.value, False) = True Then

        Me!txtBrewStatus.value = BREW_STATUS_CURRENT
        Me!txtBrewFinishDate.value = Null

    Else

        Me!txtBrewStatus.value = BREW_STATUS_IN_PROCESS
        Me!txtBrewFinishDate.value = Null

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось проверить статус варки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Статус варки"

End Sub


Private Function EnsureBrewSavedForMovement() As Boolean

    ' Проверяет обязательные поля и сохраняет варку перед движением продукта.

    On Error GoTo ErrorHandler

    EnsureBrewSavedForMovement = False

    If IsNull(Me!txtBrewDate.value) Then

        MsgBox "Не указана дата варки.", _
               vbExclamation, _
               "Варка"

        Exit Function

    End If

    If Nz(Me!cboRecipe.value, "") = "" Then

        MsgBox "Не выбран рецепт.", _
               vbExclamation, _
               "Варка"

        Exit Function

    End If

    If Nz(Me!txtOutputKettleL.value, 0) <= 0 Then

        MsgBox "Не указан объем на выходе из котла.", _
               vbExclamation, _
               "Варка"

        Exit Function

    End If

    Call EnsureBrewNumberAssigned

    If Me.Dirty = True Then
        Me.Dirty = False
    End If

    If IsNull(Me!txtId.value) Then

        MsgBox "Не удалось сохранить варку перед операцией.", _
               vbExclamation, _
               "Варка"

        Exit Function

    End If

    Call SaveBrewRecipeCompositionIfNeeded

    EnsureBrewSavedForMovement = True

    Exit Function

ErrorHandler:

    MsgBox "Не удалось подготовить варку к операции." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Варка"

    EnsureBrewSavedForMovement = False

End Function


Private Sub DeleteCurrentBrewSafely()

    ' Физически удаляет варку только если по ней нет движений в ЦКТ.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim brewId As Long
    Dim movementCount As Long

    If Me.NewRecord = True Then

        Me.Undo
        Call RefreshFormData
        Exit Sub

    End If

    If IsNull(Me!txtId.value) Then
        Exit Sub
    End If

    brewId = CLng(Me!txtId.value)

    movementCount = DCount("*", "tИсточникиЦКТ", "[Код варки] = " & brewId)

    If movementCount > 0 Then

        MsgBox "Нельзя удалить эту варку физически, потому что по ней уже есть движения продукта." & vbCrLf & vbCrLf & _
               "Для таких случаев позже будет использоваться отмена операций или корректировка.", _
               vbExclamation, _
               "Удаление варки"

        Exit Sub

    End If

    If MsgBox("Удалить текущую варку?", _
              vbQuestion + vbYesNo + vbDefaultButton2, _
              "Удаление варки") <> vbYes Then

        Exit Sub

    End If

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ws.BeginTrans

    db.Execute _
        "DELETE FROM [tСоставВарки] WHERE [Код варки] = " & brewId & ";", _
        dbFailOnError

    db.Execute _
        "DELETE FROM [tВарка] WHERE [Код] = " & brewId & ";", _
        dbFailOnError

    ws.CommitTrans

    Me.Requery

    Call GoToLastBrew
    Call RefreshFormData

    Exit Sub

ErrorHandler:

    On Error Resume Next

    If Not ws Is Nothing Then
        ws.Rollback
    End If

    MsgBox "Не удалось удалить варку." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Удаление варки"

End Sub


' ============================================================
' Позиционирование и проверки
' ============================================================

Private Sub GoToCurrentOrLastBrew()

    ' Старое имя оставляем для совместимости.
    ' Новая логика: всегда переходить на последнюю варку.

    Call GoToLastBrew

End Sub


Private Function HasUnfinishedBrew(Optional ByVal excludedBrewId As Long = 0) As Boolean

    ' Проверяет, есть ли незавершенная варка.
    '
    ' В текущей логике "завершенная варка" означает:
    '   весь объем из котла разлит/перелит в ЦКТ.
    '
    ' Завершенные статусы:
    '   - Разлита в ЦКТ;
    '   - Закрыта вручную.
    '
    ' Финальный розлив в кеги здесь не учитывается.

    On Error GoTo ErrorHandler

    Dim whereCondition As String

    whereCondition = _
        "(" & _
        "   [Статус варки] Is Null " & _
        "   OR " & _
        "   (" & _
        "       [Статус варки] <> '" & BREW_STATUS_SENT_TO_CCT & "' " & _
        "       AND [Статус варки] <> '" & BREW_STATUS_MANUAL_CLOSED & "'" & _
        "   )" & _
        ")"

    If excludedBrewId > 0 Then
        whereCondition = whereCondition & " AND [Код] <> " & excludedBrewId
    End If

    HasUnfinishedBrew = (DCount("*", "tВарка", whereCondition) > 0)

    Exit Function

ErrorHandler:

    ' При ошибке лучше заблокировать создание новой варки.
    HasUnfinishedBrew = True

End Function


Private Function GetCurrentBrewId() As Long

    ' Возвращает Код текущей записи варки.
    '
    ' Для новой несохраненной записи возвращает 0.

    On Error GoTo ErrorHandler

    If IsNull(Me!txtId.value) Then
        GetCurrentBrewId = 0
    Else
        GetCurrentBrewId = CLng(Me!txtId.value)
    End If

    Exit Function

ErrorHandler:

    GetCurrentBrewId = 0

End Function


' ============================================================
' Комментарии и текстовые блоки
' ============================================================

Private Function AppendTextBlock( _
    ByVal currentText As String, _
    ByVal textToAppend As String _
) As String

    ' Добавляет новый текстовый блок к существующему тексту через пустую строку.

    If Trim(Nz(currentText, "")) = "" Then
        AppendTextBlock = textToAppend
    Else
        AppendTextBlock = currentText & vbCrLf & vbCrLf & textToAppend
    End If

End Function


' ============================================================
' Вспомогательные функции
' ============================================================

Private Function EscapeSqlText(ByVal sourceText As String) As String

    ' Экранирует одинарные кавычки в строке для SQL.

    EscapeSqlText = Replace(sourceText, "'", "''")

End Function


Private Function TryParseVolume( _
    ByVal sourceText As String, _
    ByRef resultValue As Double _
) As Boolean

    ' Безопасно преобразует строку в число.
    '
    ' Поддерживает ввод с точкой и с запятой:
    '   10.5
    '   10,5

    On Error GoTo ErrorHandler

    Dim normalizedText As String
    Dim decimalSeparator As String

    decimalSeparator = Mid(CStr(1.1), 2, 1)

    normalizedText = Trim(sourceText)
    normalizedText = Replace(normalizedText, " ", "")
    normalizedText = Replace(normalizedText, ".", decimalSeparator)
    normalizedText = Replace(normalizedText, ",", decimalSeparator)

    resultValue = CDbl(normalizedText)

    TryParseVolume = True

    Exit Function

ErrorHandler:

    TryParseVolume = False
    resultValue = 0

End Function


' ============================================================
' Добавить в модуль формы: fВарка
'
' Назначение:
'   Дает главной форме единый способ обновлять встроенную форму.
'
' Важно:
'   Это НЕ полный код fВарка.
'   Добавь этот блок в текущий код формы fВарка, ничего не удаляя.
' ============================================================

' ============================================================
' Внешнее обновление формы и позиционирование
' ============================================================

Public Sub RefreshPanel()

    ' Внешнее обновление формы варки.
    '
    ' Используется fГлавная при обновлении встроенной формы.
    '
    ' После обновления всегда переходим на последнюю варку.
    ' Дополнительно включаем короткий одноразовый таймер, чтобы
    ' закрепить позиционирование при работе в режиме подформы.

    On Error Resume Next

    If Me.Dirty = True Then
        Me.Dirty = False
    End If

    DBEngine.Idle dbRefreshCache

    Me.Requery

    Call GoToLastBrew
    Call RefreshFormData

    Me.Refresh
    Me.Recalc
    Me.Repaint

    Me.TimerInterval = 200

End Sub

Private Sub GoToLastBrew()

    ' Переходит на последнюю варку.
    '
    ' Последняя варка определяется по:
    '   1. максимальному [Номер варки];
    '   2. при равенстве — максимальному [Код].
    '
    ' Не использует признак [Текущая варка].
    ' Это сделано специально, чтобы после открытия и обновления формы
    ' всегда показывалась последняя созданная/актуальная запись.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim rsLast As DAO.Recordset
    Dim rsForm As DAO.Recordset
    Dim lastBrewId As Long
    Dim sqlText As String

    Set db = CurrentDb

    sqlText = _
        "SELECT TOP 1 [Код] " & _
        "FROM [tВарка] " & _
        "WHERE [Код] Is Not Null " & _
        "ORDER BY Nz([Номер варки], 0) DESC, [Код] DESC;"

    Set rsLast = db.OpenRecordset(sqlText, dbOpenSnapshot)

    If rsLast.EOF Then
        GoTo ExitPoint
    End If

    lastBrewId = CLng(rsLast.Fields("Код").value)

    Set rsForm = Me.RecordsetClone

    If rsForm.EOF And rsForm.BOF Then
        GoTo ExitPoint
    End If

    rsForm.FindFirst "[Код] = " & lastBrewId

    If rsForm.NoMatch = False Then
        Me.Bookmark = rsForm.Bookmark
    End If

ExitPoint:

    On Error Resume Next

    If Not rsLast Is Nothing Then
        rsLast.Close
    End If

    If Not rsForm Is Nothing Then
        rsForm.Close
    End If

    Set rsLast = Nothing
    Set rsForm = Nothing
    Set db = Nothing

    Exit Sub

ErrorHandler:

    Resume ExitPoint

End Sub


Private Sub RefreshMainFormAfterOperation()

    ' Обновляет главную форму после успешной операции Варка -> ЦКТ.
    '
    ' fВарка встроена в fГлавная как подчиненная форма,
    ' поэтому сначала пробуем обратиться через Parent.
    '
    ' Если по какой-то причине не получилось — обращаемся
    ' к открытой fГлавная напрямую.

    On Error Resume Next

    If Me.Dirty = True Then
        Me.Dirty = False
    End If

    DBEngine.Idle dbRefreshCache
    DoEvents

    Me.Parent.RefreshEmbeddedWorkingForms

    If Err.Number = 0 Then
        Exit Sub
    End If

    Err.Clear

    If CurrentProject.AllForms("fГлавная").IsLoaded Then
        Forms("fГлавная").RefreshEmbeddedWorkingForms
    End If

End Sub




```

### fOperationCCT_AutoRefresh_Full_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fОперацияЦКТ — операции ЦКТ, автообновление главной формы после успешных операций.  
**SHA256:** `8e26029375fed6b06eda305d76c80d9eeaa6aa83a447f0d0a29a825c1b15abea`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fОперацияЦКТ
'
' Назначение:
'   Выполнение операций по выбранному ЦКТ.
'
' Открывается из формы fЦКТ_Панель:
'   OpenArgs = номер ЦКТ: 1, 2, 3...
'
' Текущий реализованный этап:
'   - ЦКТ - Фильтрация - Форфас.
'
' Подготовлено под следующие этапы:
'   - ЦКТ - Розлив;
'   - Корректировка объема ЦКТ.
'
' Важно:
'   Эта форма несвязанная.
'   Все изменения выполняются через модуль mVesselMovement.
' ============================================================


Private Const VESSEL_TYPE_CCT As String = "ЦКТ"
Private Const VESSEL_TYPE_FORFAS As String = "Форфас"

Private Const OP_CCT_TO_FORFAS_FILTRATION As String = "ЦКТ - Фильтрация - Форфас"
Private Const OP_CCT_TO_KEG_FILLING As String = "ЦКТ - Розлив"
Private Const OP_CCT_ADJUSTMENT As String = "Корректировка ЦКТ"

' ------------------------------------------------------------
' Имена строк блока операции.
'
' Эти имена используются для скрытия/схлопывания ненужных полей.
'
' Если на форме есть label-подписи с такими именами, они тоже будут
' скрываться и получать высоту 0 вместе с рабочими полями.
'
' Если label-подписи называются иначе, код не упадет:
' он схлопнет только сами поля.
' ------------------------------------------------------------
Private Const LABEL_OPERATION_TYPE As String = "lblOperationTypeCaption"
Private Const LABEL_TARGET_FORFAS As String = "lblTargetForfasCaption"
Private Const LABEL_SOURCE_VOLUME As String = "lblSourceVolumeOperationCaption"
Private Const LABEL_TARGET_VOLUME As String = "lblTargetVolumeOperationCaption"
Private Const LABEL_FILTRATION_LOSS As String = "lblFiltrationLossCaption"
Private Const LABEL_PACKAGE As String = "lblPackageCaption"
Private Const LABEL_KEG_COUNT As String = "lblKegCountCaption"
Private Const LABEL_KEG_VOLUME As String = "lblKegVolumeCaption"
Private Const LABEL_KEG_TOTAL_VOLUME As String = "lblKegTotalVolumeCaption"
Private Const LABEL_ADJUSTMENT_VOLUME As String = "lblAdjustmentVolumeCaption"
Private Const LABEL_OPERATION_COMMENT As String = "lblOperationCommentCaption"

Private mSourceCctNumber As Long
Private mSourceCctId As Long
Private mInternalFormUpdate As Boolean


Private Sub Form_Load()

    ' Большая рабочая форма открывается на весь рабочий экран Access.
    DoCmd.Maximize

    ' Инициализируем форму.
    Call InitializeOperationForm

End Sub


Private Sub Form_Activate()

    ' При возврате на форму обновляем данные по ЦКТ.
    Call RefreshSourceCctData

End Sub


Private Sub cboOperationType_AfterUpdate()

    ' После выбора операции очищаем поля предыдущей операции
    ' и перестраиваем доступность полей под новый тип операции.
    '
    ' Это нужно, чтобы при переключении:
    '   ЦКТ - Розлив -> ЦКТ - Фильтрация - Форфас
    ' или обратно не оставались старые введенные значения.

    If mInternalFormUpdate = True Then
        Exit Sub
    End If

    Call ClearOperationFields
    Call ApplyOperationMode

End Sub


Private Sub cboPackage_AfterUpdate()

    ' После выбора тары подставляем объем единицы тары.
    Call ApplySelectedPackageToForm
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtSourceVolumeOperationL_AfterUpdate()

    ' Пересчитываем потери после изменения объема из ЦКТ.
    Call RecalculateFiltrationLoss

End Sub


Private Sub txtSourceVolumeOperationL_Change()

    ' Пересчитываем потери сразу при вводе объема из ЦКТ.
    Call RecalculateFiltrationLoss

End Sub


Private Sub txtTargetVolumeOperationL_AfterUpdate()

    ' Пересчитываем потери после изменения объема после фильтрации.
    Call RecalculateFiltrationLoss

End Sub


Private Sub txtTargetVolumeOperationL_Change()

    ' Пересчитываем потери сразу при вводе объема после фильтрации.
    Call RecalculateFiltrationLoss

End Sub


Private Sub txtKegCount_AfterUpdate()

    ' Пересчитываем объем розлива после изменения количества кег.
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegCount_Change()

    ' Пересчитываем объем розлива сразу при вводе количества кег.
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegVolumeL_AfterUpdate()

    ' Пересчитываем объем розлива после изменения объема одной кеги.
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegVolumeL_Change()

    ' Пересчитываем объем розлива сразу при вводе объема одной кеги.
    Call RecalculateKegTotalVolume

End Sub


Private Sub cmdExecuteOperation_Click()

    ' Выполняет выбранную операцию.
    Call ExecuteSelectedOperation

End Sub


Private Sub cmdCloseForm_Click()

    ' Закрывает форму операций.
    DoCmd.Close acForm, Me.Name

End Sub


Private Sub InitializeOperationForm()

    ' Начальная настройка формы:
    '   - получаем номер ЦКТ из OpenArgs;
    '   - настраиваем список форфасов;
    '   - настраиваем список операций;
    '   - загружаем состояние ЦКТ.

    On Error GoTo ErrorHandler

    mInternalFormUpdate = True

    Call LoadSourceCctFromOpenArgs
    Call RememberOperationControlsLayout
    Call ConfigureForfasCombo
    Call ConfigurePackageCombo
    Call ConfigureOperationTypeCombo
    Call RefreshSourceCctData

    If ControlExists("cboOperationType") = True Then
        Me.Controls("cboOperationType").Value = OP_CCT_TO_FORFAS_FILTRATION
    End If

    Call ApplyOperationMode
    Call ClearOperationFields

ExitPoint:

    mInternalFormUpdate = False
    Exit Sub

ErrorHandler:

    mInternalFormUpdate = False

    MsgBox "Не удалось инициализировать форму операций ЦКТ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

    Resume ExitPoint

End Sub


Private Sub LoadSourceCctFromOpenArgs()

    ' Получает номер ЦКТ из OpenArgs и определяет Код емкости.

    On Error GoTo ErrorHandler

    mSourceCctNumber = 0
    mSourceCctId = 0

    If Len(Nz(Me.OpenArgs, "")) = 0 Then
        Err.Raise vbObjectError + 4100, , "Форма открыта без номера ЦКТ в OpenArgs."
    End If

    mSourceCctNumber = CLng(Me.OpenArgs)

    If mSourceCctNumber <= 0 Then
        Err.Raise vbObjectError + 4101, , "Некорректный номер ЦКТ: " & CStr(Me.OpenArgs)
    End If

    mSourceCctId = GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, mSourceCctNumber)

    If mSourceCctId <= 0 Then
        Err.Raise vbObjectError + 4102, , _
            "Не найден ЦКТ" & mSourceCctNumber & " в справочнике tЕмкости."
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось определить исходный ЦКТ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub


Private Sub ConfigureForfasCombo()

    ' Настраивает выпадающий список форфасов.
    '
    ' Ожидаемый элемент:
    '   cboTargetForfas
    '
    ' Важно:
    '   ColumnWidths задаем без "cm", чтобы Access не ругался
    '   на региональные настройки и десятичный разделитель.

    On Error GoTo ErrorHandler

    If ControlExists("cboTargetForfas") = False Then
        Exit Sub
    End If

    With Me.Controls("cboTargetForfas")

        .RowSourceType = "Table/Query"

        .RowSource = _
            "SELECT " & _
            "   [Код], " & _
            "   [Название], " & _
            "   [Номер емкости], " & _
            "   [Максимальный объем(л)] " & _
            "FROM [tЕмкости] " & _
            "WHERE [Тип емкости] = 'Форфас' " & _
            "  AND [Активна] = True " & _
            "ORDER BY [Номер емкости];"

        ' 1-й столбец: Код — скрыт.
        ' 2-й столбец: Название — видим.
        ' 3-й столбец: Номер емкости — скрыт.
        ' 4-й столбец: Максимальный объем — скрыт.
        .ColumnCount = 4
        .BoundColumn = 1
        .ColumnWidths = "0;4;0;0"

        .LimitToList = True
        .Requery

    End With

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить список форфасов." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub


Private Sub ConfigureOperationTypeCombo()

    ' Настраивает список операций.
    '
    ' Ожидаемый элемент:
    '   cboOperationType

    On Error GoTo ErrorHandler

    If ControlExists("cboOperationType") = False Then
        Exit Sub
    End If

    With Me.Controls("cboOperationType")

        .RowSourceType = "Value List"
        .RowSource = _
            OP_CCT_TO_FORFAS_FILTRATION & ";" & _
            OP_CCT_TO_KEG_FILLING & ";" & _
            OP_CCT_ADJUSTMENT

        .ColumnCount = 1
        .BoundColumn = 1
        .LimitToList = True
        .Requery

    End With

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить список операций." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub

Private Sub ConfigurePackageCombo()

    ' Настраивает выпадающий список тары.
    '
    ' Ожидаемый элемент:
    '   cboPackage
    '
    ' Источник данных:
    '   tТара

    On Error GoTo ErrorHandler

    If ControlExists("cboPackage") = False Then
        Exit Sub
    End If

    With Me.Controls("cboPackage")

        .RowSourceType = "Table/Query"

        .RowSource = _
            "SELECT " & _
            "   [Код], " & _
            "   [Название тары], " & _
            "   [Тип тары], " & _
            "   [Объем единицы тары(л)] " & _
            "FROM [tТара] " & _
            "WHERE [Активна] = True " & _
            "ORDER BY [Тип тары], [Объем единицы тары(л)], [Название тары];"

        ' 1-й столбец: Код — скрыт.
        ' 2-й столбец: Название тары — видим.
        ' 3-й столбец: Тип тары — скрыт.
        ' 4-й столбец: Объем единицы тары — скрыт.
        .ColumnCount = 4
        .BoundColumn = 1
        .ColumnWidths = "0;4;0;0"

        .LimitToList = True
        .Requery

    End With

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить список тары." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub



Private Sub RefreshSourceCctData()

    ' Загружает текущее состояние исходного ЦКТ на форму.

    On Error GoTo ErrorHandler

    Dim sourceName As String
    Dim statusText As String
    Dim sortName As String
    Dim currentVolumeL As Double
    Dim freeVolumeL As Double
    Dim fermentationNumber As Variant
    Dim brewNumbers As String
    Dim lastBrewDate As Variant
    Dim yeastRemoved As Boolean

    If mSourceCctId <= 0 Then
        Exit Sub
    End If

    sourceName = GetVesselNameById(mSourceCctId)
    statusText = Nz(GetVesselStateValue(mSourceCctId, "Статус"), "Свободен")
    sortName = Nz(GetVesselStateValue(mSourceCctId, "Сорт"), "")

    currentVolumeL = GetVesselCurrentVolume(mSourceCctId)
    freeVolumeL = GetVesselFreeVolume(mSourceCctId)

    fermentationNumber = GetVesselStateValue(mSourceCctId, "Номер брожения")
    brewNumbers = Nz(GetVesselStateValue(mSourceCctId, "Номера варок"), "")

    lastBrewDate = GetVesselStateValue(mSourceCctId, "Дата последней варки")
    yeastRemoved = Nz(GetVesselStateValue(mSourceCctId, "Снятие дрожжей"), False)

    If sourceName = "" Then
        sourceName = "ЦКТ" & mSourceCctNumber
    End If

    Call SetControlValue("txtOperationTitle", "Операции по " & sourceName)

    Call SetControlValue("txtSourceCctNumber", mSourceCctNumber)
    Call SetControlValue("txtSourceCctName", sourceName)
    Call SetControlValue("txtSourceStatus", statusText)
    Call SetControlValue("txtSourceSort", NullIfEmpty(sortName))
    Call SetControlValue("txtSourceVolumeL", Format(currentVolumeL, "0") & " л")
    Call SetControlValue("txtSourceFreeVolumeL", Format(freeVolumeL, "0") & " л")

    If IsNull(fermentationNumber) Or Nz(fermentationNumber, 0) = 0 Then
        Call SetControlValue("txtSourceFermentationNumber", Null)
    Else
        Call SetControlValue("txtSourceFermentationNumber", fermentationNumber)
    End If

    Call SetControlValue("txtSourceBrewNumbers", NullIfEmpty(brewNumbers))

    If IsNull(lastBrewDate) Then
        Call SetControlValue("txtSourceLastBrewDate", Null)
    Else
        Call SetControlValue("txtSourceLastBrewDate", Format(CDate(lastBrewDate), "dd.mm.yyyy"))
    End If

    If ControlExists("chkSourceYeastRemoved") = True Then
        Me.Controls("chkSourceYeastRemoved").Value = yeastRemoved
        Me.Controls("chkSourceYeastRemoved").Enabled = True
        Me.Controls("chkSourceYeastRemoved").Locked = True
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось обновить данные исходного ЦКТ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub


Private Sub ApplyOperationMode()

    ' Управляет доступностью и видимостью полей
    ' в зависимости от выбранной операции.

    On Error GoTo ErrorHandler

    Dim operationType As String

    operationType = Nz(GetControlValue("cboOperationType"), "")

    Call HideAllOperationSpecificRows

    Select Case operationType

        Case OP_CCT_TO_FORFAS_FILTRATION

            Call SetOperationRowVisible("cboTargetForfas", LABEL_TARGET_FORFAS, True, False)

            Call SetOperationRowVisible("txtSourceVolumeOperationL", LABEL_SOURCE_VOLUME, True, False)
            Call SetOperationRowVisible("txtTargetVolumeOperationL", LABEL_TARGET_VOLUME, True, False)
            Call SetOperationRowVisible("txtFiltrationLossL", LABEL_FILTRATION_LOSS, True, True)

            Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, False, False)
            Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, False, False)
            Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, False, True)
            Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, False, True)

            Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, False, False)
            Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, True, False)

            Call SetControlEnabled("cmdExecuteOperation", True)

        Case OP_CCT_TO_KEG_FILLING

            Call SetOperationRowVisible("cboTargetForfas", LABEL_TARGET_FORFAS, False, False)
            Call SetOperationRowVisible("txtSourceVolumeOperationL", LABEL_SOURCE_VOLUME, False, False)
            Call SetOperationRowVisible("txtTargetVolumeOperationL", LABEL_TARGET_VOLUME, False, False)
            Call SetOperationRowVisible("txtFiltrationLossL", LABEL_FILTRATION_LOSS, False, True)

            ' Розлив теперь работает через универсальную тару.
            Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, True, False)
            Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, True, False)
            Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, True, True)
            Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, True, True)

            Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, False, False)
            Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, True, False)

            Call SetControlEnabled("cmdExecuteOperation", True)
            Call RecalculateKegTotalVolume

        Case OP_CCT_ADJUSTMENT

            Call SetOperationRowVisible("cboTargetForfas", LABEL_TARGET_FORFAS, False, False)
            Call SetOperationRowVisible("txtSourceVolumeOperationL", LABEL_SOURCE_VOLUME, False, False)
            Call SetOperationRowVisible("txtTargetVolumeOperationL", LABEL_TARGET_VOLUME, False, False)
            Call SetOperationRowVisible("txtFiltrationLossL", LABEL_FILTRATION_LOSS, False, True)

            Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, False, False)
            Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, False, False)
            Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, False, True)
            Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, False, True)

            Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, True, False)
            Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, True, False)

            Call SetControlEnabled("cmdExecuteOperation", True)

        Case Else

            Call HideAllOperationSpecificRows
            Call SetControlEnabled("cmdExecuteOperation", False)

    End Select

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось применить режим операции." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub


Private Sub RecalculateFiltrationLoss()

    ' Рассчитывает потери фильтрации:
    '   Потери = Объем из ЦКТ - Объем в форфас.

    On Error GoTo ErrorHandler

    Dim sourceVolumeL As Double
    Dim targetVolumeL As Double

    If TryParseNumber(Nz(GetControlTextOrValue("txtSourceVolumeOperationL"), ""), sourceVolumeL) = False Then
        Call SetControlValue("txtFiltrationLossL", Null)
        Exit Sub
    End If

    If TryParseNumber(Nz(GetControlTextOrValue("txtTargetVolumeOperationL"), ""), targetVolumeL) = False Then
        Call SetControlValue("txtFiltrationLossL", Null)
        Exit Sub
    End If

    Call SetControlValue("txtFiltrationLossL", FormatVolumeText(sourceVolumeL - targetVolumeL))

    Exit Sub

ErrorHandler:

    Call SetControlValue("txtFiltrationLossL", Null)

End Sub



Private Sub RecalculateKegTotalVolume()

    ' Рассчитывает объем розлива:
    '   Объем розлива = Количество кег * Объем одной кеги.

    On Error GoTo ErrorHandler

    Dim kegCount As Long
    Dim kegVolumeL As Double
    Dim totalVolumeL As Double

    If TryParseLongValue(Nz(GetControlTextOrValue("txtKegCount"), ""), kegCount) = False Then
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    If TryParseNumber(Nz(GetControlTextOrValue("txtKegVolumeL"), ""), kegVolumeL) = False Then
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    If kegCount <= 0 Or kegVolumeL <= 0 Then
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    totalVolumeL = kegCount * kegVolumeL

    Call SetControlValue("txtKegTotalVolumeL", FormatVolumeText(totalVolumeL))

    Exit Sub

ErrorHandler:

    Call SetControlValue("txtKegTotalVolumeL", Null)

End Sub


Private Sub ExecuteSelectedOperation()

    ' Выполняет выбранную операцию.

    On Error GoTo ErrorHandler

    Dim operationType As String

    operationType = Nz(GetControlValue("cboOperationType"), "")

    Select Case operationType

        Case OP_CCT_TO_FORFAS_FILTRATION

            Call ExecuteCctToForfasWithFiltration

        Case OP_CCT_TO_KEG_FILLING

            Call ExecuteCctToKegFilling

        Case OP_CCT_ADJUSTMENT

            Call ExecuteCctAdjustment

        Case Else

            MsgBox "Не выбран тип операции.", _
                   vbExclamation, _
                   "Операции ЦКТ"

    End Select

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить операцию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub


Private Sub ExecuteCctToForfasWithFiltration()

    ' Выполняет операцию:
    '   ЦКТ - Фильтрация - Форфас.

    On Error GoTo ErrorHandler

    Dim targetForfasId As Long
    Dim sourceVolumeL As Double
    Dim targetVolumeL As Double
    Dim lossVolumeL As Double

    Dim sourceName As String
    Dim targetName As String
    Dim commentText As String

    Dim sourceCurrentVolumeL As Double
    Dim yeastRemoved As Boolean
    Dim userAnswer As VbMsgBoxResult

    ' ------------------------------------------------------------
    ' Проверка исходного ЦКТ
    ' ------------------------------------------------------------
    If mSourceCctId <= 0 Then

        MsgBox "Не определен исходный ЦКТ.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceCurrentVolumeL = GetVesselCurrentVolume(mSourceCctId)

    If sourceCurrentVolumeL <= 0 Then

        MsgBox "Исходный ЦКТ свободен. Фильтровать нечего.", _
               vbInformation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceName = GetVesselNameById(mSourceCctId)

    If sourceName = "" Then
        sourceName = "ЦКТ" & mSourceCctNumber
    End If

    ' ------------------------------------------------------------
    ' Проверка форфаса
    ' ------------------------------------------------------------
    If IsNull(GetControlValue("cboTargetForfas")) Then

        MsgBox "Не выбран форфас-приемник.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    targetForfasId = CLng(GetControlValue("cboTargetForfas"))

    If targetForfasId <= 0 Then

        MsgBox "Не выбран форфас-приемник.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    targetName = GetVesselNameById(targetForfasId)

    If targetName = "" Then
        targetName = "Форфас с кодом " & targetForfasId
    End If

    ' ------------------------------------------------------------
    ' Проверка объемов
    ' ------------------------------------------------------------
    If TryParseNumber(Nz(GetControlValue("txtSourceVolumeOperationL"), ""), sourceVolumeL) = False Then

        MsgBox "Не удалось распознать объем из ЦКТ." & vbCrLf & _
               "Введите число, например 1000 или 1000,5.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If TryParseNumber(Nz(GetControlValue("txtTargetVolumeOperationL"), ""), targetVolumeL) = False Then

        MsgBox "Не удалось распознать объем в форфас после фильтрации." & vbCrLf & _
               "Введите число, например 970 или 970,5.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If sourceVolumeL <= 0 Then

        MsgBox "Объем из ЦКТ должен быть больше 0.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If targetVolumeL <= 0 Then

        MsgBox "Объем в форфас должен быть больше 0.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If sourceVolumeL > sourceCurrentVolumeL Then

        MsgBox "Нельзя отправить на фильтрацию больше, чем есть в ЦКТ." & vbCrLf & vbCrLf & _
               "В " & sourceName & ": " & sourceCurrentVolumeL & " л" & vbCrLf & _
               "Объем операции: " & sourceVolumeL & " л", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    lossVolumeL = sourceVolumeL - targetVolumeL

    If lossVolumeL < 0 Then

        MsgBox "Объем после фильтрации не может быть больше объема из ЦКТ." & vbCrLf & vbCrLf & _
               "Объем из ЦКТ: " & sourceVolumeL & " л" & vbCrLf & _
               "Объем в форфас: " & targetVolumeL & " л", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    Call SetControlValue("txtFiltrationLossL", FormatVolumeText(lossVolumeL))

    ' ------------------------------------------------------------
    ' Предупреждение по дрожжам
    ' ------------------------------------------------------------
    yeastRemoved = Nz(GetVesselStateValue(mSourceCctId, "Снятие дрожжей"), False)

    If yeastRemoved = False Then

        userAnswer = MsgBox( _
            "В " & sourceName & " не отмечено снятие дрожжей." & vbCrLf & vbCrLf & _
            "Продолжить фильтрацию?", _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            "Снятие дрожжей" _
        )

        If userAnswer <> vbYes Then
            Exit Sub
        End If

    End If

    ' ------------------------------------------------------------
    ' Подтверждение операции
    ' ------------------------------------------------------------
    commentText = Nz(GetControlValue("txtOperationComment"), "")

    userAnswer = MsgBox( _
        "Выполнить операцию?" & vbCrLf & vbCrLf & _
        "Операция: " & OP_CCT_TO_FORFAS_FILTRATION & vbCrLf & _
        "Источник: " & sourceName & vbCrLf & _
        "Приемник: " & targetName & vbCrLf & _
        "Объем из ЦКТ: " & sourceVolumeL & " л" & vbCrLf & _
        "Объем в форфас: " & targetVolumeL & " л" & vbCrLf & _
        "Потери фильтрации: " & lossVolumeL & " л", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Подтверждение операции" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    ' ------------------------------------------------------------
    ' Регистрация операции через mVesselMovement
    ' ------------------------------------------------------------
    If RegisterCctToForfasWithFiltration( _
        sourceCctId:=mSourceCctId, _
        targetForfasId:=targetForfasId, _
        sourceVolumeL:=sourceVolumeL, _
        targetVolumeL:=targetVolumeL, _
        commentText:=commentText _
    ) = False Then

        Exit Sub

    End If

    MsgBox "Операция выполнена." & vbCrLf & vbCrLf & _
           "Источник: " & sourceName & vbCrLf & _
           "Приемник: " & targetName & vbCrLf & _
           "Потери фильтрации: " & lossVolumeL & " л", _
           vbInformation, _
           "Операции ЦКТ"

    Call RefreshSourceCctData
    Call ClearOperationFields
    Call RefreshMainFormAfterOperation

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить операцию ЦКТ - Фильтрация - Форфас." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub



Private Sub ExecuteCctToKegFilling()

    ' Выполняет операцию:
    '   ЦКТ - Розлив.
    '
    ' Одна операция розлива = один вид тары.

    On Error GoTo ErrorHandler

    Dim packageId As Long
    Dim packageType As String
    Dim packageName As String
    Dim packageCount As Long
    Dim packageUnitVolumeL As Double
    Dim fillingVolumeL As Double

    Dim sourceName As String
    Dim commentText As String
    Dim sourceCurrentVolumeL As Double
    Dim yeastRemoved As Boolean
    Dim userAnswer As VbMsgBoxResult

    If mSourceCctId <= 0 Then

        MsgBox "Не определен исходный ЦКТ.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceCurrentVolumeL = GetVesselCurrentVolume(mSourceCctId)

    If sourceCurrentVolumeL <= 0 Then

        MsgBox "Исходный ЦКТ свободен. Разливать нечего.", _
               vbInformation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceName = GetVesselNameById(mSourceCctId)

    If sourceName = "" Then
        sourceName = "ЦКТ" & mSourceCctNumber
    End If

    If GetSelectedPackageData(packageId, packageType, packageName, packageUnitVolumeL) = False Then

        MsgBox "Не выбрана тара для розлива." & vbCrLf & _
               "Выберите тару из списка, например Кега 30 л или ПЭТ 1,5 л.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If TryParseLongValue(Nz(GetControlValue("txtKegCount"), ""), packageCount) = False Then

        MsgBox "Не удалось распознать количество тары." & vbCrLf & _
               "Введите целое число, например 5.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If packageCount <= 0 Then

        MsgBox "Количество тары должно быть больше 0.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If packageUnitVolumeL <= 0 Then

        MsgBox "Объем единицы тары должен быть больше 0.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    fillingVolumeL = packageCount * packageUnitVolumeL

    If fillingVolumeL > sourceCurrentVolumeL Then

        MsgBox "Нельзя разлить больше, чем есть в ЦКТ." & vbCrLf & vbCrLf & _
               "В " & sourceName & ": " & FormatVolumeText(sourceCurrentVolumeL) & " л" & vbCrLf & _
               "Тара: " & packageName & vbCrLf & _
               "Количество тары: " & packageCount & vbCrLf & _
               "Объем единицы тары: " & FormatVolumeText(packageUnitVolumeL) & " л" & vbCrLf & _
               "Объем розлива: " & FormatVolumeText(fillingVolumeL) & " л", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    Call SetControlValue("txtKegVolumeL", FormatVolumeText(packageUnitVolumeL))
    Call SetControlValue("txtKegTotalVolumeL", FormatVolumeText(fillingVolumeL))

    yeastRemoved = Nz(GetVesselStateValue(mSourceCctId, "Снятие дрожжей"), False)

    If yeastRemoved = False Then

        userAnswer = MsgBox( _
            "В " & sourceName & " не отмечено снятие дрожжей." & vbCrLf & vbCrLf & _
            "Продолжить розлив?", _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            "Снятие дрожжей" _
        )

        If userAnswer <> vbYes Then
            Exit Sub
        End If

    End If

    commentText = Nz(GetControlValue("txtOperationComment"), "")

    userAnswer = MsgBox( _
        "Выполнить операцию?" & vbCrLf & vbCrLf & _
        "Операция: " & OP_CCT_TO_KEG_FILLING & vbCrLf & _
        "Источник: " & sourceName & vbCrLf & _
        "Тара: " & packageName & vbCrLf & _
        "Количество тары: " & packageCount & vbCrLf & _
        "Объем единицы тары: " & FormatVolumeText(packageUnitVolumeL) & " л" & vbCrLf & _
        "Объем розлива: " & FormatVolumeText(fillingVolumeL) & " л", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Подтверждение операции" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    If RegisterCctToKegFilling( _
        sourceCctId:=mSourceCctId, _
        packageId:=packageId, _
        packageCount:=packageCount, _
        packageUnitVolumeL:=packageUnitVolumeL, _
        packageType:=packageType, _
        packageName:=packageName, _
        commentText:=commentText _
    ) = False Then

        Exit Sub

    End If

    MsgBox "Операция выполнена." & vbCrLf & vbCrLf & _
           "Источник: " & sourceName & vbCrLf & _
           "Тара: " & packageName & vbCrLf & _
           "Количество тары: " & packageCount & vbCrLf & _
           "Объем розлива: " & FormatVolumeText(fillingVolumeL) & " л", _
           vbInformation, _
           "Операции ЦКТ"

    Call RefreshSourceCctData
    Call ClearOperationFields
    Call RefreshMainFormAfterOperation

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить операцию ЦКТ - Розлив." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub



Private Sub RememberOperationControlsLayout()

    ' Запоминает исходную высоту строк операции.
    '
    ' Это нужно, чтобы после схлопывания поля до высоты 0
    ' можно было вернуть его к исходной высоте.
    '
    ' Значения сохраняются в Tag самих элементов.
    ' Если у элемента уже есть Tag, мы его не используем в другой логике.

    On Error Resume Next

    Call RememberControlHeight("cboTargetForfas")
    Call RememberControlHeight(LABEL_TARGET_FORFAS)

    Call RememberControlHeight("txtSourceVolumeOperationL")
    Call RememberControlHeight(LABEL_SOURCE_VOLUME)

    Call RememberControlHeight("txtTargetVolumeOperationL")
    Call RememberControlHeight(LABEL_TARGET_VOLUME)

    Call RememberControlHeight("txtFiltrationLossL")
    Call RememberControlHeight(LABEL_FILTRATION_LOSS)

    Call RememberControlHeight("cboPackage")
    Call RememberControlHeight(LABEL_PACKAGE)

    Call RememberControlHeight("txtKegCount")
    Call RememberControlHeight(LABEL_KEG_COUNT)

    Call RememberControlHeight("txtKegVolumeL")
    Call RememberControlHeight(LABEL_KEG_VOLUME)

    Call RememberControlHeight("txtKegTotalVolumeL")
    Call RememberControlHeight(LABEL_KEG_TOTAL_VOLUME)

    Call RememberControlHeight("txtAdjustmentVolumeL")
    Call RememberControlHeight(LABEL_ADJUSTMENT_VOLUME)

    Call RememberControlHeight("txtOperationComment")
    Call RememberControlHeight(LABEL_OPERATION_COMMENT)

End Sub


Private Sub RememberControlHeight(ByVal controlName As String)

    ' Запоминает исходную высоту элемента в Tag.
    '
    ' Если элемент не найден, просто выходим.

    On Error GoTo ExitPoint

    If ControlExists(controlName) = False Then
        GoTo ExitPoint
    End If

    If Trim(Nz(Me.Controls(controlName).Tag, "")) = "" Then
        Me.Controls(controlName).Tag = CStr(Me.Controls(controlName).Height)
    End If

ExitPoint:

End Sub


Private Function GetRememberedControlHeight(ByVal controlName As String) As Long

    ' Возвращает исходную высоту элемента.
    '
    ' Если высота не была запомнена, возвращает текущую высоту.
    ' Если текущая высота уже 0, возвращает безопасное значение 300 твипов.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetRememberedControlHeight = 0
        Exit Function
    End If

    If Trim(Nz(Me.Controls(controlName).Tag, "")) <> "" Then

        GetRememberedControlHeight = CLng(Me.Controls(controlName).Tag)

    ElseIf Me.Controls(controlName).Height > 0 Then

        GetRememberedControlHeight = Me.Controls(controlName).Height

    Else

        GetRememberedControlHeight = 300

    End If

    Exit Function

ErrorHandler:

    GetRememberedControlHeight = 300

End Function


Private Sub HideAllOperationSpecificRows()

    ' Скрывает и схлопывает все строки,
    ' которые зависят от типа операции.
    '
    ' Сам cboOperationType не скрываем.

    On Error Resume Next

    Call SetOperationRowVisible("cboTargetForfas", LABEL_TARGET_FORFAS, False, False)

    Call SetOperationRowVisible("txtSourceVolumeOperationL", LABEL_SOURCE_VOLUME, False, False)
    Call SetOperationRowVisible("txtTargetVolumeOperationL", LABEL_TARGET_VOLUME, False, False)
    Call SetOperationRowVisible("txtFiltrationLossL", LABEL_FILTRATION_LOSS, False, True)

    Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, False, False)
    Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, False, False)
    Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, False, False)
    Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, False, True)

    Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, False, False)

    Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, False, False)

End Sub


Private Sub SetOperationRowVisible( _
    ByVal controlName As String, _
    ByVal labelName As String, _
    ByVal visibleValue As Boolean, _
    ByVal lockedValue As Boolean _
)

    ' Показывает или скрывает строку операции.
    '
    ' Что делает:
    '   - Visible = True/False;
    '   - Height = исходная высота или 0;
    '   - Enabled = True/False;
    '   - Locked = по параметру lockedValue.
    '
    ' labelName необязателен фактически:
    ' если такой подписи на форме нет, код просто пропустит ее.

    On Error Resume Next

    Call SetSingleControlCollapsedState(controlName, visibleValue, lockedValue, True)

    If Trim(Nz(labelName, "")) <> "" Then
        Call SetSingleControlCollapsedState(labelName, visibleValue, True, False)
    End If

End Sub


Private Sub SetSingleControlCollapsedState( _
    ByVal controlName As String, _
    ByVal visibleValue As Boolean, _
    ByVal lockedValue As Boolean, _
    ByVal canLock As Boolean _
)

    ' Применяет видимость и высоту к одному элементу.

    On Error GoTo ExitPoint

    If ControlExists(controlName) = False Then
        GoTo ExitPoint
    End If

    If visibleValue = True Then

        Me.Controls(controlName).Visible = True
        Me.Controls(controlName).Height = GetRememberedControlHeight(controlName)
        Me.Controls(controlName).Enabled = True

        If canLock = True Then
            Me.Controls(controlName).Locked = lockedValue
        End If

    Else

        If canLock = True Then
            Me.Controls(controlName).Locked = True
        End If

        Me.Controls(controlName).Enabled = False
        Me.Controls(controlName).Height = 0
        Me.Controls(controlName).Visible = False

    End If

ExitPoint:

End Sub



Private Sub ExecuteCctAdjustment()

    ' Выполняет операцию:
    '   Корректировка ЦКТ.
    '
    ' Объем корректировки:
    '   > 0  — добавить объем;
    '   < 0  — уменьшить объем.
    '
    ' Комментарий обязателен.

    On Error GoTo ErrorHandler

    Dim adjustmentVolumeL As Double
    Dim sourceName As String
    Dim commentText As String
    Dim sourceCurrentVolumeL As Double
    Dim sourceNewVolumeL As Double
    Dim userAnswer As VbMsgBoxResult

    ' ------------------------------------------------------------
    ' Проверка исходного ЦКТ
    ' ------------------------------------------------------------
    If mSourceCctId <= 0 Then

        MsgBox "Не определен исходный ЦКТ.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceCurrentVolumeL = GetVesselCurrentVolume(mSourceCctId)

    If sourceCurrentVolumeL <= 0 Then

        MsgBox "Исходный ЦКТ свободен. Корректировать нечего.", _
               vbInformation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceName = GetVesselNameById(mSourceCctId)

    If sourceName = "" Then
        sourceName = "ЦКТ" & mSourceCctNumber
    End If

    ' ------------------------------------------------------------
    ' Проверка объема корректировки
    ' ------------------------------------------------------------
    If TryParseNumber(Nz(GetControlValue("txtAdjustmentVolumeL"), ""), adjustmentVolumeL) = False Then

        MsgBox "Не удалось распознать объем корректировки." & vbCrLf & _
               "Введите число, например 50 или -50.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    If adjustmentVolumeL = 0 Then

        MsgBox "Объем корректировки не может быть равен 0.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    sourceNewVolumeL = sourceCurrentVolumeL + adjustmentVolumeL

    If sourceNewVolumeL < 0 Then

        MsgBox "Корректировка невозможна: итоговый объем станет отрицательным." & vbCrLf & vbCrLf & _
               "Текущий объем: " & FormatVolumeText(sourceCurrentVolumeL) & " л" & vbCrLf & _
               "Корректировка: " & FormatVolumeText(adjustmentVolumeL) & " л" & vbCrLf & _
               "Итоговый объем: " & FormatVolumeText(sourceNewVolumeL) & " л", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    ' ------------------------------------------------------------
    ' Комментарий обязателен
    ' ------------------------------------------------------------
    commentText = Trim(Nz(GetControlValue("txtOperationComment"), ""))

    If commentText = "" Then

        MsgBox "Для корректировки ЦКТ необходимо указать комментарий.", _
               vbExclamation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    ' ------------------------------------------------------------
    ' Подтверждение операции
    ' ------------------------------------------------------------
    userAnswer = MsgBox( _
        "Выполнить корректировку ЦКТ?" & vbCrLf & vbCrLf & _
        "Источник: " & sourceName & vbCrLf & _
        "Текущий объем: " & FormatVolumeText(sourceCurrentVolumeL) & " л" & vbCrLf & _
        "Корректировка: " & FormatVolumeText(adjustmentVolumeL) & " л" & vbCrLf & _
        "Итоговый объем: " & FormatVolumeText(sourceNewVolumeL) & " л" & vbCrLf & vbCrLf & _
        "Комментарий: " & commentText, _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Подтверждение корректировки" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    ' ------------------------------------------------------------
    ' Регистрация операции через mVesselMovement
    ' ------------------------------------------------------------
    If RegisterCctAdjustment( _
        sourceCctId:=mSourceCctId, _
        adjustmentVolumeL:=adjustmentVolumeL, _
        commentText:=commentText _
    ) = False Then

        Exit Sub

    End If

    MsgBox "Корректировка выполнена." & vbCrLf & vbCrLf & _
           "Источник: " & sourceName & vbCrLf & _
           "Корректировка: " & FormatVolumeText(adjustmentVolumeL) & " л" & vbCrLf & _
           "Итоговый объем: " & FormatVolumeText(sourceNewVolumeL) & " л", _
           vbInformation, _
           "Операции ЦКТ"

    Call RefreshSourceCctData
    Call ClearOperationFields
    Call RefreshMainFormAfterOperation

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить корректировку ЦКТ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub



Private Sub ApplySelectedPackageToForm()

    ' Подставляет объем единицы выбранной тары в поле txtKegVolumeL.

    On Error GoTo ErrorHandler

    Dim packageId As Long
    Dim packageType As String
    Dim packageName As String
    Dim packageUnitVolumeL As Double

    If GetSelectedPackageData(packageId, packageType, packageName, packageUnitVolumeL) = False Then
        Call SetControlValue("txtKegVolumeL", Null)
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    Call SetControlValue("txtKegVolumeL", FormatVolumeText(packageUnitVolumeL))

    Exit Sub

ErrorHandler:

    Call SetControlValue("txtKegVolumeL", Null)
    Call SetControlValue("txtKegTotalVolumeL", Null)

End Sub


Private Function GetSelectedPackageData( _
    ByRef packageId As Long, _
    ByRef packageType As String, _
    ByRef packageName As String, _
    ByRef packageUnitVolumeL As Double _
) As Boolean

    ' Возвращает данные выбранной тары из cboPackage.

    On Error GoTo ErrorHandler

    GetSelectedPackageData = False

    packageId = 0
    packageType = ""
    packageName = ""
    packageUnitVolumeL = 0

    If ControlExists("cboPackage") = False Then
        Exit Function
    End If

    If IsNull(Me.Controls("cboPackage").Value) Then
        Exit Function
    End If

    packageId = CLng(Me.Controls("cboPackage").Value)
    packageName = Nz(Me.Controls("cboPackage").Column(1), "")
    packageType = Nz(Me.Controls("cboPackage").Column(2), "")
    packageUnitVolumeL = CDbl(Nz(Me.Controls("cboPackage").Column(3), 0))

    If packageId <= 0 Then
        Exit Function
    End If

    If packageName = "" Then
        Exit Function
    End If

    If packageUnitVolumeL <= 0 Then
        Exit Function
    End If

    GetSelectedPackageData = True

    Exit Function

ErrorHandler:

    GetSelectedPackageData = False

End Function


Private Sub ClearOperationFields()

    ' Очищает поля текущей операции.
    '
    ' Вызывается:
    '   - после успешного выполнения операции;
    '   - при переключении типа операции.
    '
    ' Важно:
    '   Тип операции cboOperationType здесь не очищаем.
    '   Поля, которые в текущем режиме не нужны,
    '   дополнительно скрываются и схлопываются в ApplyOperationMode.

    On Error Resume Next

    Call SetControlValue("cboTargetForfas", Null)
    Call SetControlValue("txtSourceVolumeOperationL", Null)
    Call SetControlValue("txtTargetVolumeOperationL", Null)
    Call SetControlValue("txtFiltrationLossL", Null)

    Call SetControlValue("cboPackage", Null)
    Call SetControlValue("txtKegCount", Null)
    Call SetControlValue("txtKegVolumeL", Null)
    Call SetControlValue("txtKegTotalVolumeL", Null)

    Call SetControlValue("txtAdjustmentVolumeL", Null)

    Call SetControlValue("txtOperationComment", Null)

End Sub


Private Function GetVesselStateValue( _
    ByVal vesselId As Long, _
    ByVal fieldName As String _
) As Variant

    ' Возвращает значение поля состояния емкости.

    On Error GoTo ErrorHandler

    GetVesselStateValue = DLookup( _
        "[" & fieldName & "]", _
        "tСостояниеЕмкостей", _
        "[Код емкости] = " & vesselId _
    )

    Exit Function

ErrorHandler:

    GetVesselStateValue = Null

End Function


Private Function TryParseNumber( _
    ByVal sourceText As String, _
    ByRef resultValue As Double _
) As Boolean

    ' Безопасно преобразует строку в число.
    '
    ' Поддерживает ввод с точкой и с запятой:
    '   10.5
    '   10,5

    On Error GoTo ErrorHandler

    Dim normalizedText As String
    Dim decimalSeparator As String

    decimalSeparator = Mid(CStr(1.1), 2, 1)

    normalizedText = Trim(sourceText)
    normalizedText = Replace(normalizedText, " ", "")
    normalizedText = Replace(normalizedText, ".", decimalSeparator)
    normalizedText = Replace(normalizedText, ",", decimalSeparator)

    resultValue = CDbl(normalizedText)

    TryParseNumber = True

    Exit Function

ErrorHandler:

    resultValue = 0
    TryParseNumber = False

End Function


Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    Set ctl = Me.Controls(controlName)

    ControlExists = True

    Exit Function

ErrorHandler:

    ControlExists = False

End Function


Private Function GetControlTextOrValue(ByVal controlName As String) As Variant

    ' Возвращает текущий текст элемента, если пользователь прямо сейчас
    ' вводит значение в это поле.
    '
    ' Зачем нужно:
    '   В событии Change значение TextBox.Value еще может быть старым,
    '   а TextBox.Text уже содержит то, что пользователь набирает.
    '
    ' Если поле не активно, возвращает обычное Value.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetControlTextOrValue = Null
        Exit Function
    End If

    If Me.ActiveControl.Name = controlName Then
        GetControlTextOrValue = Me.Controls(controlName).Text
    Else
        GetControlTextOrValue = Me.Controls(controlName).Value
    End If

    Exit Function

ErrorHandler:

    On Error Resume Next
    GetControlTextOrValue = Me.Controls(controlName).Value

End Function


Private Function GetControlValue(ByVal controlName As String) As Variant

    ' Безопасно получает значение элемента управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetControlValue = Null
        Exit Function
    End If

    GetControlValue = Me.Controls(controlName).Value

    Exit Function

ErrorHandler:

    GetControlValue = Null

End Function


Private Sub SetControlValue( _
    ByVal controlName As String, _
    ByVal controlValue As Variant _
)

    ' Безопасно записывает значение в элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Value = controlValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlValue для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlEnabled( _
    ByVal controlName As String, _
    ByVal enabledValue As Boolean _
)

    ' Безопасно включает или отключает элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Enabled = enabledValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlEnabled для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlLocked( _
    ByVal controlName As String, _
    ByVal lockedValue As Boolean _
)

    ' Безопасно блокирует или разблокирует элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Locked = lockedValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlLocked для " & controlName & ": " & Err.Description

End Sub




Private Function TryParseLongValue( _
    ByVal sourceText As String, _
    ByRef resultValue As Long _
) As Boolean

    ' Безопасно преобразует строку в целое число.
    '
    ' Используется для количества кег.

    On Error GoTo ErrorHandler

    Dim numericValue As Double

    If TryParseNumber(sourceText, numericValue) = False Then
        resultValue = 0
        TryParseLongValue = False
        Exit Function
    End If

    If numericValue <> Fix(numericValue) Then
        resultValue = 0
        TryParseLongValue = False
        Exit Function
    End If

    resultValue = CLng(numericValue)
    TryParseLongValue = True

    Exit Function

ErrorHandler:

    resultValue = 0
    TryParseLongValue = False

End Function


Private Function FormatVolumeText(ByVal volumeValue As Double) As String

    ' Форматирует объем без лишней запятой в конце.
    '
    ' Примеры:
    '   100     -> "100"
    '   100,5   -> "100,5"
    '   100,125 -> "100,125"

    Dim resultText As String
    Dim decimalSeparator As String

    decimalSeparator = Mid(CStr(1.1), 2, 1)

    resultText = Format(volumeValue, "0.###")

    ' Убираем лишний десятичный разделитель в конце:
    '   "100," -> "100"
    '   "100." -> "100"
    If Len(resultText) > 0 Then

        If Right(resultText, 1) = decimalSeparator _
           Or Right(resultText, 1) = "." _
           Or Right(resultText, 1) = "," Then

            resultText = Left(resultText, Len(resultText) - 1)

        End If

    End If

    FormatVolumeText = resultText

End Function


Private Function NullIfEmpty(ByVal sourceText As String) As Variant

    ' Возвращает Null, если строка пустая.
    ' Иначе возвращает саму строку.

    If Trim(Nz(sourceText, "")) = "" Then
        NullIfEmpty = Null
    Else
        NullIfEmpty = sourceText
    End If

End Function

' ============================================================
' Обновление главной формы после операций
' ============================================================

Private Sub RefreshMainFormAfterOperation()

    ' Обновляет главную форму после успешной операции ЦКТ.
    '
    ' fОперацияЦКТ открывается отдельной формой,
    ' поэтому обращаемся к fГлавная напрямую.
    '
    ' Это нужно, чтобы встроенные панели на fГлавная
    ' сразу увидели изменения в tСостояниеЕмкостей
    ' без закрытия и повторного открытия главной формы.

    On Error Resume Next

    DBEngine.Idle dbRefreshCache
    DoEvents

    If CurrentProject.AllForms("fГлавная").IsLoaded Then
        Forms("fГлавная").RefreshEmbeddedWorkingForms
    End If

End Sub


```

### fOperationForfas_AutoRefresh_Full_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fОперацияФорфас — операции форфаса, розлив, корректировки, автообновление главной формы.  
**SHA256:** `1b131aa2eb4a59dec850c2cea00c9be7bcb8b9511fc20492a458ce47e0eaa2cd`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fОперацияФорфас
'
' Назначение:
'   Выполнение операций по выбранному форфасу.
'
' Открывается из формы fФорфас_Панель:
'   OpenArgs = номер форфаса: 1 или 2.
'
' Реализованные операции:
'   - Форфас - Розлив;
'   - Корректировка Форфаса.
'
' Важно:
'   Эта форма несвязанная.
'   Все изменения выполняются через модуль mVesselMovement.
' ============================================================


Private Const VESSEL_TYPE_FORFAS As String = "Форфас"

Private Const OP_FORFAS_TO_KEG_FILLING As String = "Форфас - Розлив"
Private Const OP_FORFAS_ADJUSTMENT As String = "Корректировка Форфаса"

Private Const LABEL_PACKAGE As String = "lblPackageCaption"
Private Const LABEL_KEG_COUNT As String = "lblKegCountCaption"
Private Const LABEL_KEG_VOLUME As String = "lblKegVolumeCaption"
Private Const LABEL_KEG_TOTAL_VOLUME As String = "lblKegTotalVolumeCaption"
Private Const LABEL_ADJUSTMENT_VOLUME As String = "lblAdjustmentVolumeCaption"
Private Const LABEL_OPERATION_COMMENT As String = "lblOperationCommentCaption"

Private mSourceForfasNumber As Long
Private mSourceForfasId As Long
Private mInternalFormUpdate As Boolean


Private Sub Form_Load()

    ' Большая рабочая форма открывается на весь рабочий экран Access.
    DoCmd.Maximize

    ' Инициализируем форму.
    Call InitializeOperationForm

End Sub


Private Sub Form_Activate()

    ' При возврате на форму обновляем данные по форфасу.
    Call RefreshSourceForfasData

End Sub


Private Sub cboOperationType_AfterUpdate()

    ' После выбора операции очищаем поля предыдущей операции
    ' и перестраиваем доступность полей под новый тип операции.

    If mInternalFormUpdate = True Then
        Exit Sub
    End If

    Call ClearOperationFields
    Call ApplyOperationMode

End Sub


Private Sub cboPackage_AfterUpdate()

    ' После выбора тары подставляем объем единицы тары.
    Call ApplySelectedPackageToForm
    Call RecalculateKegTotalVolume

End Sub


Private Sub cboPackage_Click()

    ' Дополнительная страховка для подстановки объема тары
    ' при выборе мышью из выпадающего списка.
    Call ApplySelectedPackageToForm
    Call RecalculateKegTotalVolume

End Sub


Private Sub cboPackage_LostFocus()

    ' Дополнительная страховка: если AfterUpdate по каким-то причинам
    ' не сработал, подставляем объем при выходе из поля.
    Call ApplySelectedPackageToForm
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegCount_AfterUpdate()

    ' Пересчитываем объем розлива после изменения количества кег.
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegCount_Change()

    ' Пересчитываем объем розлива сразу при вводе количества кег.
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegVolumeL_AfterUpdate()

    ' Пересчитываем объем розлива после изменения объема одной кеги.
    Call RecalculateKegTotalVolume

End Sub


Private Sub txtKegVolumeL_Change()

    ' Пересчитываем объем розлива сразу при вводе объема одной кеги.
    Call RecalculateKegTotalVolume

End Sub


Private Sub cmdExecuteOperation_Click()

    ' Выполняет выбранную операцию.
    Call ExecuteSelectedOperation

End Sub


Private Sub cmdCloseForm_Click()

    ' Закрывает форму операций.
    DoCmd.Close acForm, Me.Name

End Sub


Private Sub InitializeOperationForm()

    ' Начальная настройка формы:
    '   - получаем номер форфаса из OpenArgs;
    '   - запоминаем высоты полей для схлопывания;
    '   - настраиваем список операций;
    '   - загружаем состояние форфаса.

    On Error GoTo ErrorHandler

    mInternalFormUpdate = True

    Call LoadSourceForfasFromOpenArgs
    Call RememberOperationControlsLayout
    Call ConfigurePackageCombo
    Call ConfigureOperationTypeCombo
    Call RefreshSourceForfasData

    If ControlExists("cboOperationType") = True Then
        Me.Controls("cboOperationType").Value = OP_FORFAS_TO_KEG_FILLING
    End If

    Call ApplyOperationMode
    Call ClearOperationFields

ExitPoint:

    mInternalFormUpdate = False
    Exit Sub

ErrorHandler:

    mInternalFormUpdate = False

    MsgBox "Не удалось инициализировать форму операций форфаса." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

    Resume ExitPoint

End Sub


Private Sub LoadSourceForfasFromOpenArgs()

    ' Получает номер форфаса из OpenArgs и определяет Код емкости.

    On Error GoTo ErrorHandler

    mSourceForfasNumber = 0
    mSourceForfasId = 0

    If Len(Nz(Me.OpenArgs, "")) = 0 Then
        Err.Raise vbObjectError + 5100, , "Форма открыта без номера форфаса в OpenArgs."
    End If

    mSourceForfasNumber = CLng(Me.OpenArgs)

    If mSourceForfasNumber <= 0 Then
        Err.Raise vbObjectError + 5101, , "Некорректный номер форфаса: " & CStr(Me.OpenArgs)
    End If

    mSourceForfasId = GetVesselIdByTypeAndNumber(VESSEL_TYPE_FORFAS, mSourceForfasNumber)

    If mSourceForfasId <= 0 Then
        Err.Raise vbObjectError + 5102, , _
            "Не найден Форфас" & mSourceForfasNumber & " в справочнике tЕмкости."
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось определить исходный форфас." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub


Private Sub ConfigureOperationTypeCombo()

    ' Настраивает список операций.
    '
    ' Ожидаемый элемент:
    '   cboOperationType

    On Error GoTo ErrorHandler

    If ControlExists("cboOperationType") = False Then
        Exit Sub
    End If

    With Me.Controls("cboOperationType")

        .RowSourceType = "Value List"
        .RowSource = _
            OP_FORFAS_TO_KEG_FILLING & ";" & _
            OP_FORFAS_ADJUSTMENT

        .ColumnCount = 1
        .BoundColumn = 1
        .LimitToList = True
        .Requery

    End With

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить список операций." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub

Private Sub ConfigurePackageCombo()

    ' Настраивает выпадающий список тары.
    '
    ' Ожидаемый элемент:
    '   cboPackage
    '
    ' Источник данных:
    '   tТара

    On Error GoTo ErrorHandler

    If ControlExists("cboPackage") = False Then
        Exit Sub
    End If

    With Me.Controls("cboPackage")

        .RowSourceType = "Table/Query"

        .RowSource = _
            "SELECT " & _
            "   [Код], " & _
            "   [Название тары], " & _
            "   [Тип тары], " & _
            "   [Объем единицы тары(л)] " & _
            "FROM [tТара] " & _
            "WHERE [Активна] = True " & _
            "ORDER BY [Тип тары], [Объем единицы тары(л)], [Название тары];"

        .ColumnCount = 4
        .BoundColumn = 1
        .ColumnWidths = "0;4;0;0"

        .LimitToList = True
        .Requery

    End With

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить список тары." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub



Private Sub RefreshSourceForfasData()

    ' Загружает текущее состояние исходного форфаса на форму.

    On Error GoTo ErrorHandler

    Dim sourceName As String
    Dim statusText As String
    Dim sortName As String
    Dim currentVolumeL As Double
    Dim freeVolumeL As Double
    Dim fermentationNumber As Variant
    Dim brewNumbers As String
    Dim firstFillDate As Variant
    Dim lastBrewDate As Variant

    If mSourceForfasId <= 0 Then
        Exit Sub
    End If

    sourceName = GetVesselNameById(mSourceForfasId)
    statusText = Nz(GetVesselStateValue(mSourceForfasId, "Статус"), "Свободен")
    sortName = Nz(GetVesselStateValue(mSourceForfasId, "Сорт"), "")

    currentVolumeL = GetVesselCurrentVolume(mSourceForfasId)
    freeVolumeL = GetVesselFreeVolume(mSourceForfasId)

    fermentationNumber = GetVesselStateValue(mSourceForfasId, "Номер брожения")
    brewNumbers = Nz(GetVesselStateValue(mSourceForfasId, "Номера варок"), "")

    firstFillDate = GetVesselStateValue(mSourceForfasId, "Дата")
    lastBrewDate = GetVesselStateValue(mSourceForfasId, "Дата последней варки")

    If sourceName = "" Then
        sourceName = "Форфас" & mSourceForfasNumber
    End If

    Call SetControlValue("txtOperationTitle", "Операции по " & sourceName)

    Call SetControlValue("txtSourceForfasNumber", mSourceForfasNumber)
    Call SetControlValue("txtSourceForfasName", sourceName)
    Call SetControlValue("txtSourceStatus", statusText)
    Call SetControlValue("txtSourceSort", NullIfEmpty(sortName))
    Call SetControlValue("txtSourceVolumeL", FormatVolumeText(currentVolumeL) & " л")
    Call SetControlValue("txtSourceFreeVolumeL", FormatVolumeText(freeVolumeL) & " л")

    If IsNull(fermentationNumber) Or Nz(fermentationNumber, 0) = 0 Then
        Call SetControlValue("txtSourceFermentationNumber", Null)
    Else
        Call SetControlValue("txtSourceFermentationNumber", fermentationNumber)
    End If

    Call SetControlValue("txtSourceBrewNumbers", NullIfEmpty(brewNumbers))

    If IsNull(firstFillDate) Then
        Call SetControlValue("txtSourceFirstFillDate", Null)
    Else
        Call SetControlValue("txtSourceFirstFillDate", Format(CDate(firstFillDate), "dd.mm.yyyy"))
    End If

    If IsNull(lastBrewDate) Then
        Call SetControlValue("txtSourceLastBrewDate", Null)
    Else
        Call SetControlValue("txtSourceLastBrewDate", Format(CDate(lastBrewDate), "dd.mm.yyyy"))
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось обновить данные исходного форфаса." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub


Private Sub ApplyOperationMode()

    ' Управляет доступностью и видимостью полей
    ' в зависимости от выбранной операции.

    On Error GoTo ErrorHandler

    Dim operationType As String

    operationType = Nz(GetControlValue("cboOperationType"), "")

    Call HideAllOperationSpecificRows

    Select Case operationType

        Case OP_FORFAS_TO_KEG_FILLING

            ' Розлив теперь работает через универсальную тару.
            Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, True, False)
            Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, True, False)
            Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, True, True)
            Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, True, True)

            Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, False, False)
            Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, True, False)

            Call SetControlEnabled("cmdExecuteOperation", True)
            Call RecalculateKegTotalVolume

        Case OP_FORFAS_ADJUSTMENT

            Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, False, False)
            Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, False, False)
            Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, False, True)
            Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, False, True)

            Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, True, False)
            Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, True, False)

            Call SetControlEnabled("cmdExecuteOperation", True)

        Case Else

            Call HideAllOperationSpecificRows
            Call SetControlEnabled("cmdExecuteOperation", False)

    End Select

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось применить режим операции." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub


Private Sub RecalculateKegTotalVolume()

    ' Рассчитывает объем розлива:
    '   Объем розлива = Количество тары * Объем единицы тары.
    '
    ' Дополнительная защита:
    '   если пользователь выбрал тару, но событие cboPackage_AfterUpdate
    '   по какой-то причине не отработало, пробуем подставить объем
    '   единицы тары прямо перед расчетом.

    On Error GoTo ErrorHandler

    Dim packageId As Long
    Dim packageType As String
    Dim packageName As String
    Dim packageUnitVolumeL As Double

    Dim kegCount As Long
    Dim kegVolumeL As Double
    Dim totalVolumeL As Double

    If Trim(Nz(GetControlTextOrValue("txtKegVolumeL"), "")) = "" Then

        If GetSelectedPackageData(packageId, packageType, packageName, packageUnitVolumeL) = True Then
            Call SetControlValue("txtKegVolumeL", FormatVolumeText(packageUnitVolumeL))
        End If

    End If

    If TryParseLongValue(Nz(GetControlTextOrValue("txtKegCount"), ""), kegCount) = False Then
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    If TryParseNumber(Nz(GetControlTextOrValue("txtKegVolumeL"), ""), kegVolumeL) = False Then
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    If kegCount <= 0 Or kegVolumeL <= 0 Then
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    totalVolumeL = kegCount * kegVolumeL

    Call SetControlValue("txtKegTotalVolumeL", FormatVolumeText(totalVolumeL))

    Exit Sub

ErrorHandler:

    Call SetControlValue("txtKegTotalVolumeL", Null)

End Sub


Private Sub ExecuteSelectedOperation()

    ' Выполняет выбранную операцию.

    On Error GoTo ErrorHandler

    Dim operationType As String

    operationType = Nz(GetControlValue("cboOperationType"), "")

    Select Case operationType

        Case OP_FORFAS_TO_KEG_FILLING

            Call ExecuteForfasToKegFilling

        Case OP_FORFAS_ADJUSTMENT

            Call ExecuteForfasAdjustment

        Case Else

            MsgBox "Не выбран тип операции.", _
                   vbExclamation, _
                   "Операции форфаса"

    End Select

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить операцию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub


Private Sub ExecuteForfasToKegFilling()

    ' Выполняет операцию:
    '   Форфас - Розлив.
    '
    ' Одна операция розлива = один вид тары.

    On Error GoTo ErrorHandler

    Dim packageId As Long
    Dim packageType As String
    Dim packageName As String
    Dim packageCount As Long
    Dim packageUnitVolumeL As Double
    Dim fillingVolumeL As Double

    Dim sourceName As String
    Dim commentText As String
    Dim sourceCurrentVolumeL As Double
    Dim userAnswer As VbMsgBoxResult

    If mSourceForfasId <= 0 Then

        MsgBox "Не определен исходный форфас.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    sourceCurrentVolumeL = GetVesselCurrentVolume(mSourceForfasId)

    If sourceCurrentVolumeL <= 0 Then

        MsgBox "Исходный форфас свободен. Разливать нечего.", _
               vbInformation, _
               "Операции форфаса"

        Exit Sub

    End If

    sourceName = GetVesselNameById(mSourceForfasId)

    If sourceName = "" Then
        sourceName = "Форфас" & mSourceForfasNumber
    End If

    If GetSelectedPackageData(packageId, packageType, packageName, packageUnitVolumeL) = False Then

        MsgBox "Не выбрана тара для розлива." & vbCrLf & _
               "Выберите тару из списка, например Кега 30 л или ПЭТ 1,5 л.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    If TryParseLongValue(Nz(GetControlValue("txtKegCount"), ""), packageCount) = False Then

        MsgBox "Не удалось распознать количество тары." & vbCrLf & _
               "Введите целое число, например 5.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    If packageCount <= 0 Then

        MsgBox "Количество тары должно быть больше 0.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    If packageUnitVolumeL <= 0 Then

        MsgBox "Объем единицы тары должен быть больше 0.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    fillingVolumeL = packageCount * packageUnitVolumeL

    If fillingVolumeL > sourceCurrentVolumeL Then

        MsgBox "Нельзя разлить больше, чем есть в форфасе." & vbCrLf & vbCrLf & _
               "В " & sourceName & ": " & FormatVolumeText(sourceCurrentVolumeL) & " л" & vbCrLf & _
               "Тара: " & packageName & vbCrLf & _
               "Количество тары: " & packageCount & vbCrLf & _
               "Объем единицы тары: " & FormatVolumeText(packageUnitVolumeL) & " л" & vbCrLf & _
               "Объем розлива: " & FormatVolumeText(fillingVolumeL) & " л", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    Call SetControlValue("txtKegVolumeL", FormatVolumeText(packageUnitVolumeL))
    Call SetControlValue("txtKegTotalVolumeL", FormatVolumeText(fillingVolumeL))

    commentText = Nz(GetControlValue("txtOperationComment"), "")

    userAnswer = MsgBox( _
        "Выполнить операцию?" & vbCrLf & vbCrLf & _
        "Операция: " & OP_FORFAS_TO_KEG_FILLING & vbCrLf & _
        "Источник: " & sourceName & vbCrLf & _
        "Тара: " & packageName & vbCrLf & _
        "Количество тары: " & packageCount & vbCrLf & _
        "Объем единицы тары: " & FormatVolumeText(packageUnitVolumeL) & " л" & vbCrLf & _
        "Объем розлива: " & FormatVolumeText(fillingVolumeL) & " л", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Подтверждение операции" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    If RegisterForfasToKegFilling( _
        sourceForfasId:=mSourceForfasId, _
        packageId:=packageId, _
        packageCount:=packageCount, _
        packageUnitVolumeL:=packageUnitVolumeL, _
        packageType:=packageType, _
        packageName:=packageName, _
        commentText:=commentText _
    ) = False Then

        Exit Sub

    End If

    MsgBox "Операция выполнена." & vbCrLf & vbCrLf & _
           "Источник: " & sourceName & vbCrLf & _
           "Тара: " & packageName & vbCrLf & _
           "Количество тары: " & packageCount & vbCrLf & _
           "Объем розлива: " & FormatVolumeText(fillingVolumeL) & " л", _
           vbInformation, _
           "Операции форфаса"

    Call RefreshSourceForfasData
    Call ClearOperationFields
    Call RefreshMainFormAfterOperation

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить операцию Форфас - Розлив." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub


Private Sub ExecuteForfasAdjustment()

    ' Выполняет операцию:
    '   Корректировка Форфаса.

    On Error GoTo ErrorHandler

    Dim adjustmentVolumeL As Double
    Dim sourceName As String
    Dim commentText As String
    Dim sourceCurrentVolumeL As Double
    Dim sourceNewVolumeL As Double
    Dim userAnswer As VbMsgBoxResult

    If mSourceForfasId <= 0 Then

        MsgBox "Не определен исходный форфас.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    sourceCurrentVolumeL = GetVesselCurrentVolume(mSourceForfasId)

    If sourceCurrentVolumeL <= 0 Then

        MsgBox "Исходный форфас свободен. Корректировать нечего.", _
               vbInformation, _
               "Операции форфаса"

        Exit Sub

    End If

    sourceName = GetVesselNameById(mSourceForfasId)

    If sourceName = "" Then
        sourceName = "Форфас" & mSourceForfasNumber
    End If

    If TryParseNumber(Nz(GetControlValue("txtAdjustmentVolumeL"), ""), adjustmentVolumeL) = False Then

        MsgBox "Не удалось распознать объем корректировки." & vbCrLf & _
               "Введите число, например 50 или -50.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    If adjustmentVolumeL = 0 Then

        MsgBox "Объем корректировки не может быть равен 0.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    sourceNewVolumeL = sourceCurrentVolumeL + adjustmentVolumeL

    If sourceNewVolumeL < 0 Then

        MsgBox "Корректировка невозможна: итоговый объем станет отрицательным." & vbCrLf & vbCrLf & _
               "Текущий объем: " & FormatVolumeText(sourceCurrentVolumeL) & " л" & vbCrLf & _
               "Корректировка: " & FormatVolumeText(adjustmentVolumeL) & " л" & vbCrLf & _
               "Итоговый объем: " & FormatVolumeText(sourceNewVolumeL) & " л", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    commentText = Trim(Nz(GetControlValue("txtOperationComment"), ""))

    If commentText = "" Then

        MsgBox "Для корректировки форфаса необходимо указать комментарий.", _
               vbExclamation, _
               "Операции форфаса"

        Exit Sub

    End If

    userAnswer = MsgBox( _
        "Выполнить корректировку форфаса?" & vbCrLf & vbCrLf & _
        "Источник: " & sourceName & vbCrLf & _
        "Текущий объем: " & FormatVolumeText(sourceCurrentVolumeL) & " л" & vbCrLf & _
        "Корректировка: " & FormatVolumeText(adjustmentVolumeL) & " л" & vbCrLf & _
        "Итоговый объем: " & FormatVolumeText(sourceNewVolumeL) & " л" & vbCrLf & vbCrLf & _
        "Комментарий: " & commentText, _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Подтверждение корректировки" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    If RegisterForfasAdjustment( _
        sourceForfasId:=mSourceForfasId, _
        adjustmentVolumeL:=adjustmentVolumeL, _
        commentText:=commentText _
    ) = False Then

        Exit Sub

    End If

    MsgBox "Корректировка выполнена." & vbCrLf & vbCrLf & _
           "Источник: " & sourceName & vbCrLf & _
           "Корректировка: " & FormatVolumeText(adjustmentVolumeL) & " л" & vbCrLf & _
           "Итоговый объем: " & FormatVolumeText(sourceNewVolumeL) & " л", _
           vbInformation, _
           "Операции форфаса"

    Call RefreshSourceForfasData
    Call ClearOperationFields
    Call RefreshMainFormAfterOperation

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить корректировку форфаса." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub



Private Sub ApplySelectedPackageToForm()

    ' Подставляет объем единицы выбранной тары в поле txtKegVolumeL
    ' и сразу пересчитывает общий объем розлива.

    On Error GoTo ErrorHandler

    Dim packageId As Long
    Dim packageType As String
    Dim packageName As String
    Dim packageUnitVolumeL As Double

    If GetSelectedPackageData(packageId, packageType, packageName, packageUnitVolumeL) = False Then
        Call SetControlValue("txtKegVolumeL", Null)
        Call SetControlValue("txtKegTotalVolumeL", Null)
        Exit Sub
    End If

    Call SetControlValue("txtKegVolumeL", FormatVolumeText(packageUnitVolumeL))

    Exit Sub

ErrorHandler:

    Call SetControlValue("txtKegVolumeL", Null)
    Call SetControlValue("txtKegTotalVolumeL", Null)

End Sub


Private Function GetSelectedPackageData( _
    ByRef packageId As Long, _
    ByRef packageType As String, _
    ByRef packageName As String, _
    ByRef packageUnitVolumeL As Double _
) As Boolean

    ' Возвращает данные выбранной тары.
    '
    ' Основной способ — по значению cboPackage.Value, то есть по [Код].
    ' Это надежнее, чем брать данные только через cboPackage.Column(),
    ' потому что Column() может не вернуть ожидаемые значения при ручной
    ' настройке комбобокса или при незаданном событии.

    On Error GoTo ErrorHandler

    Dim packageWhere As String

    GetSelectedPackageData = False

    packageId = 0
    packageType = ""
    packageName = ""
    packageUnitVolumeL = 0

    If ControlExists("cboPackage") = False Then
        Exit Function
    End If

    If IsNull(Me.Controls("cboPackage").Value) Then
        Exit Function
    End If

    packageId = CLng(Me.Controls("cboPackage").Value)

    If packageId <= 0 Then
        Exit Function
    End If

    packageWhere = "[Код] = " & packageId

    packageType = Nz(DLookup("[Тип тары]", "tТара", packageWhere), "")
    packageName = Nz(DLookup("[Название тары]", "tТара", packageWhere), "")
    packageUnitVolumeL = CDbl(Nz(DLookup("[Объем единицы тары(л)]", "tТара", packageWhere), 0))

    If packageName = "" Then
        Exit Function
    End If

    If packageUnitVolumeL <= 0 Then
        Exit Function
    End If

    GetSelectedPackageData = True

    Exit Function

ErrorHandler:

    GetSelectedPackageData = False

End Function


Private Sub RememberOperationControlsLayout()

    ' Запоминает исходную высоту строк операции.
    '
    ' Это нужно, чтобы после схлопывания поля до высоты 0
    ' можно было вернуть его к исходной высоте.

    On Error Resume Next

    Call RememberControlHeight("cboPackage")
    Call RememberControlHeight(LABEL_PACKAGE)

    Call RememberControlHeight("txtKegCount")
    Call RememberControlHeight(LABEL_KEG_COUNT)

    Call RememberControlHeight("txtKegVolumeL")
    Call RememberControlHeight(LABEL_KEG_VOLUME)

    Call RememberControlHeight("txtKegTotalVolumeL")
    Call RememberControlHeight(LABEL_KEG_TOTAL_VOLUME)

    Call RememberControlHeight("txtAdjustmentVolumeL")
    Call RememberControlHeight(LABEL_ADJUSTMENT_VOLUME)

    Call RememberControlHeight("txtOperationComment")
    Call RememberControlHeight(LABEL_OPERATION_COMMENT)

End Sub


Private Sub RememberControlHeight(ByVal controlName As String)

    ' Запоминает исходную высоту элемента в Tag.

    On Error GoTo ExitPoint

    If ControlExists(controlName) = False Then
        GoTo ExitPoint
    End If

    If Trim(Nz(Me.Controls(controlName).Tag, "")) = "" Then
        Me.Controls(controlName).Tag = CStr(Me.Controls(controlName).Height)
    End If

ExitPoint:

End Sub


Private Function GetRememberedControlHeight(ByVal controlName As String) As Long

    ' Возвращает исходную высоту элемента.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetRememberedControlHeight = 0
        Exit Function
    End If

    If Trim(Nz(Me.Controls(controlName).Tag, "")) <> "" Then

        GetRememberedControlHeight = CLng(Me.Controls(controlName).Tag)

    ElseIf Me.Controls(controlName).Height > 0 Then

        GetRememberedControlHeight = Me.Controls(controlName).Height

    Else

        GetRememberedControlHeight = 300

    End If

    Exit Function

ErrorHandler:

    GetRememberedControlHeight = 300

End Function


Private Sub HideAllOperationSpecificRows()

    ' Скрывает и схлопывает все строки,
    ' которые зависят от типа операции.

    On Error Resume Next

    Call SetOperationRowVisible("cboPackage", LABEL_PACKAGE, False, False)
    Call SetOperationRowVisible("txtKegCount", LABEL_KEG_COUNT, False, False)
    Call SetOperationRowVisible("txtKegVolumeL", LABEL_KEG_VOLUME, False, False)
    Call SetOperationRowVisible("txtKegTotalVolumeL", LABEL_KEG_TOTAL_VOLUME, False, True)

    Call SetOperationRowVisible("txtAdjustmentVolumeL", LABEL_ADJUSTMENT_VOLUME, False, False)

    Call SetOperationRowVisible("txtOperationComment", LABEL_OPERATION_COMMENT, False, False)

End Sub


Private Sub SetOperationRowVisible( _
    ByVal controlName As String, _
    ByVal labelName As String, _
    ByVal visibleValue As Boolean, _
    ByVal lockedValue As Boolean _
)

    ' Показывает или скрывает строку операции.

    On Error Resume Next

    Call SetSingleControlCollapsedState(controlName, visibleValue, lockedValue, True)

    If Trim(Nz(labelName, "")) <> "" Then
        Call SetSingleControlCollapsedState(labelName, visibleValue, True, False)
    End If

End Sub


Private Sub SetSingleControlCollapsedState( _
    ByVal controlName As String, _
    ByVal visibleValue As Boolean, _
    ByVal lockedValue As Boolean, _
    ByVal canLock As Boolean _
)

    ' Применяет видимость и высоту к одному элементу.

    On Error GoTo ExitPoint

    If ControlExists(controlName) = False Then
        GoTo ExitPoint
    End If

    If visibleValue = True Then

        Me.Controls(controlName).Visible = True
        Me.Controls(controlName).Height = GetRememberedControlHeight(controlName)
        Me.Controls(controlName).Enabled = True

        If canLock = True Then
            Me.Controls(controlName).Locked = lockedValue
        End If

    Else

        If canLock = True Then
            Me.Controls(controlName).Locked = True
        End If

        Me.Controls(controlName).Enabled = False
        Me.Controls(controlName).Height = 0
        Me.Controls(controlName).Visible = False

    End If

ExitPoint:

End Sub


Private Sub ClearOperationFields()

    ' Очищает поля текущей операции.
    '
    ' Тип операции cboOperationType здесь не очищаем.

    On Error Resume Next

    Call SetControlValue("cboPackage", Null)
    Call SetControlValue("txtKegCount", Null)
    Call SetControlValue("txtKegVolumeL", Null)
    Call SetControlValue("txtKegTotalVolumeL", Null)

    Call SetControlValue("txtAdjustmentVolumeL", Null)

    Call SetControlValue("txtOperationComment", Null)

End Sub


Private Function GetVesselStateValue( _
    ByVal vesselId As Long, _
    ByVal fieldName As String _
) As Variant

    ' Возвращает значение поля состояния емкости.

    On Error GoTo ErrorHandler

    GetVesselStateValue = DLookup( _
        "[" & fieldName & "]", _
        "tСостояниеЕмкостей", _
        "[Код емкости] = " & vesselId _
    )

    Exit Function

ErrorHandler:

    GetVesselStateValue = Null

End Function


Private Function TryParseNumber( _
    ByVal sourceText As String, _
    ByRef resultValue As Double _
) As Boolean

    ' Безопасно преобразует строку в число.
    '
    ' Поддерживает ввод с точкой и с запятой:
    '   10.5
    '   10,5

    On Error GoTo ErrorHandler

    Dim normalizedText As String
    Dim decimalSeparator As String

    decimalSeparator = Mid(CStr(1.1), 2, 1)

    normalizedText = Trim(sourceText)
    normalizedText = Replace(normalizedText, " ", "")
    normalizedText = Replace(normalizedText, ".", decimalSeparator)
    normalizedText = Replace(normalizedText, ",", decimalSeparator)

    resultValue = CDbl(normalizedText)

    TryParseNumber = True

    Exit Function

ErrorHandler:

    resultValue = 0
    TryParseNumber = False

End Function


Private Function TryParseLongValue( _
    ByVal sourceText As String, _
    ByRef resultValue As Long _
) As Boolean

    ' Безопасно преобразует строку в целое число.
    '
    ' Используется для количества кег.

    On Error GoTo ErrorHandler

    Dim numericValue As Double

    If TryParseNumber(sourceText, numericValue) = False Then
        resultValue = 0
        TryParseLongValue = False
        Exit Function
    End If

    If numericValue <> Fix(numericValue) Then
        resultValue = 0
        TryParseLongValue = False
        Exit Function
    End If

    resultValue = CLng(numericValue)
    TryParseLongValue = True

    Exit Function

ErrorHandler:

    resultValue = 0
    TryParseLongValue = False

End Function


Private Function FormatVolumeText(ByVal volumeValue As Double) As String

    ' Форматирует объем без лишней запятой в конце.

    Dim resultText As String
    Dim decimalSeparator As String

    decimalSeparator = Mid(CStr(1.1), 2, 1)

    resultText = Format(volumeValue, "0.###")

    If Len(resultText) > 0 Then

        If Right(resultText, 1) = decimalSeparator _
           Or Right(resultText, 1) = "." _
           Or Right(resultText, 1) = "," Then

            resultText = Left(resultText, Len(resultText) - 1)

        End If

    End If

    FormatVolumeText = resultText

End Function


Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    Set ctl = Me.Controls(controlName)

    ControlExists = True

    Exit Function

ErrorHandler:

    ControlExists = False

End Function


Private Function GetControlTextOrValue(ByVal controlName As String) As Variant

    ' Возвращает текущий текст элемента, если пользователь прямо сейчас
    ' вводит значение в это поле.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetControlTextOrValue = Null
        Exit Function
    End If

    If Me.ActiveControl.Name = controlName Then
        GetControlTextOrValue = Me.Controls(controlName).Text
    Else
        GetControlTextOrValue = Me.Controls(controlName).Value
    End If

    Exit Function

ErrorHandler:

    On Error Resume Next
    GetControlTextOrValue = Me.Controls(controlName).Value

End Function


Private Function GetControlValue(ByVal controlName As String) As Variant

    ' Безопасно получает значение элемента управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetControlValue = Null
        Exit Function
    End If

    GetControlValue = Me.Controls(controlName).Value

    Exit Function

ErrorHandler:

    GetControlValue = Null

End Function


Private Sub SetControlValue( _
    ByVal controlName As String, _
    ByVal controlValue As Variant _
)

    ' Безопасно записывает значение в элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Value = controlValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlValue для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlEnabled( _
    ByVal controlName As String, _
    ByVal enabledValue As Boolean _
)

    ' Безопасно включает или отключает элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Enabled = enabledValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlEnabled для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlLocked( _
    ByVal controlName As String, _
    ByVal lockedValue As Boolean _
)

    ' Безопасно блокирует или разблокирует элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Locked = lockedValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlLocked для " & controlName & ": " & Err.Description

End Sub


Private Function NullIfEmpty(ByVal sourceText As String) As Variant

    ' Возвращает Null, если строка пустая.
    ' Иначе возвращает саму строку.

    If Trim(Nz(sourceText, "")) = "" Then
        NullIfEmpty = Null
    Else
        NullIfEmpty = sourceText
    End If

End Function

' ============================================================
' Обновление главной формы после операций
' ============================================================

Private Sub RefreshMainFormAfterOperation()

    ' Обновляет главную форму после успешной операции форфаса.
    '
    ' fОперацияФорфас открывается отдельной формой,
    ' поэтому обращаемся к fГлавная напрямую.
    '
    ' Это нужно, чтобы встроенные панели на fГлавная
    ' сразу увидели изменения в tСостояниеЕмкостей
    ' без закрытия и повторного открытия главной формы.

    On Error Resume Next

    DBEngine.Idle dbRefreshCache
    DoEvents

    If CurrentProject.AllForms("fГлавная").IsLoaded Then
        Forms("fГлавная").RefreshEmbeddedWorkingForms
    End If

End Sub


```

### mVesselMovement_Full_Code_ForfasFirstFillDateFix.bas

**Группа:** `final_preferred`  
**Назначение:** mVesselMovement — основная бизнес-логика емкостей, форфасы, тара, розлив, фиксация даты первого наполнения форфаса.  
**SHA256:** `40f4fb9c38886c92d859286f32154dbf047661de639e4bb266810fa1688e9483`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Модуль: mVesselMovement
'
' Назначение:
'   Операции движения продукта после этапа Варка - ЦКТ.
'
' Используется для:
'   - ЦКТ - Фильтрация - Форфас;
'   - ЦКТ - Розлив;
'   - Корректировка объема ЦКТ;
'   - Форфас - Розлив;
'   - Корректировка объема Форфаса.
'
' Важно:
'   tИсточникиЦКТ остается журналом только для Варка - ЦКТ.
'   Все последующие движения пишем в tДвиженияЕмкостей.
'
' Зависимости:
'   Использует публичные функции из mBeerMovement:
'   - GetVesselIdByTypeAndNumber
'   - GetVesselNameById
'   - GetVesselTypeById
'   - GetVesselMaxVolume
'   - GetVesselCurrentVolume
'   - GetVesselFreeVolume
' ============================================================


' -----------------------------
' Типы емкостей
' -----------------------------
Private Const VESSEL_TYPE_CCT As String = "ЦКТ"
Private Const VESSEL_TYPE_FORFAS As String = "Форфас"


' -----------------------------
' Статусы емкостей
' -----------------------------
Private Const VESSEL_STATUS_FREE As String = "Свободен"
Private Const VESSEL_STATUS_BUSY As String = "Занят"


' -----------------------------
' Этапы операций
' -----------------------------
Private Const STAGE_CCT_TO_FORFAS_FILTRATION As String = "ЦКТ - Фильтрация - Форфас"
Private Const STAGE_CCT_TO_KEG_FILLING As String = "ЦКТ - Розлив"
Private Const STAGE_CCT_ADJUSTMENT As String = "Корректировка ЦКТ"

Private Const STAGE_FORFAS_TO_KEG_FILLING As String = "Форфас - Розлив"
Private Const STAGE_FORFAS_ADJUSTMENT As String = "Корректировка Форфаса"


' -----------------------------
' Типы операций
' -----------------------------
Private Const OPERATION_FILTRATION As String = "Фильтрация"
Private Const OPERATION_FILLING As String = "Розлив"
Private Const OPERATION_ADJUSTMENT As String = "Корректировка"


' -----------------------------
' Прочие константы
' -----------------------------
Private Const DEFAULT_KEG_VOLUME_L As Double = 30


Private Function EscapeSqlValue(ByVal sourceText As String) As String

    ' Экранирует одинарные кавычки для безопасной подстановки текста в SQL.

    EscapeSqlValue = Replace(sourceText, "'", "''")

End Function


Private Function GetVesselStateFieldValue( _
    ByVal vesselId As Long, _
    ByVal fieldName As String _
) As Variant

    ' Возвращает значение поля из tСостояниеЕмкостей по коду емкости.
    '
    ' Пример:
    '   GetVesselStateFieldValue(1, "Сорт")
    '   GetVesselStateFieldValue(1, "Номер брожения")

    On Error GoTo ErrorHandler

    GetVesselStateFieldValue = DLookup( _
        "[" & fieldName & "]", _
        "tСостояниеЕмкостей", _
        "[Код емкости] = " & vesselId _
    )

    Exit Function

ErrorHandler:

    GetVesselStateFieldValue = Null

End Function


Private Function GetVesselSort(ByVal vesselId As Long) As String

    ' Возвращает сорт продукта в емкости.

    On Error GoTo ErrorHandler

    GetVesselSort = Nz(GetVesselStateFieldValue(vesselId, "Сорт"), "")

    Exit Function

ErrorHandler:

    GetVesselSort = ""

End Function


Private Function GetVesselBrewNumbers(ByVal vesselId As Long) As String

    ' Возвращает список номеров варок в емкости.

    On Error GoTo ErrorHandler

    GetVesselBrewNumbers = Nz(GetVesselStateFieldValue(vesselId, "Номера варок"), "")

    Exit Function

ErrorHandler:

    GetVesselBrewNumbers = ""

End Function


Private Function GetVesselFermentationNumber(ByVal vesselId As Long) As Long

    ' Возвращает номер брожения из состояния емкости.

    On Error GoTo ErrorHandler

    GetVesselFermentationNumber = Nz(GetVesselStateFieldValue(vesselId, "Номер брожения"), 0)

    Exit Function

ErrorHandler:

    GetVesselFermentationNumber = 0

End Function


Private Function GetVesselBusyState(ByVal vesselId As Long) As Boolean

    ' Возвращает признак занятости емкости.
    '
    ' Если объем больше 0, считаем емкость занятой,
    ' даже если флаг [Занят] по какой-то причине не установлен.

    On Error GoTo ErrorHandler

    Dim currentVolumeL As Double
    Dim busyFlag As Boolean

    currentVolumeL = GetVesselCurrentVolume(vesselId)
    busyFlag = Nz(GetVesselStateFieldValue(vesselId, "Занят"), False)

    If currentVolumeL > 0 Then
        GetVesselBusyState = True
    Else
        GetVesselBusyState = busyFlag
    End If

    Exit Function

ErrorHandler:

    GetVesselBusyState = False

End Function


Private Function CalculateFiltrationLossL( _
    ByVal sourceVolumeL As Double, _
    ByVal targetVolumeL As Double _
) As Double

    ' Рассчитывает потери на фильтрации.
    '
    ' Потери = объем из источника - объем в приемник.

    CalculateFiltrationLossL = sourceVolumeL - targetVolumeL

End Function


Private Function IsValidPositiveVolume(ByVal volumeL As Double) As Boolean

    ' Проверяет, что объем положительный.

    IsValidPositiveVolume = (volumeL > 0)

End Function


Public Function RegisterCctToForfasWithFiltration( _
    ByVal sourceCctId As Long, _
    ByVal targetForfasId As Long, _
    ByVal sourceVolumeL As Double, _
    ByVal targetVolumeL As Double, _
    Optional ByVal commentText As String = "" _
) As Boolean

    ' Регистрирует операцию:
    '   ЦКТ - Фильтрация - Форфас
    '
    ' sourceCctId:
    '   Код емкости источника, то есть ЦКТ.
    '
    ' targetForfasId:
    '   Код емкости приемника, то есть Форфас.
    '
    ' sourceVolumeL:
    '   Объем, который уходит из ЦКТ на фильтрацию.
    '
    ' targetVolumeL:
    '   Объем, который приходит в форфас после фильтрации.
    '
    ' Потери фильтрации:
    '   sourceVolumeL - targetVolumeL
    '
    ' Важно:
    '   tИсточникиЦКТ не используется.
    '   Все движения после этапа Варка - ЦКТ пишутся в tДвиженияЕмкостей.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim rsMovement As DAO.Recordset
    Dim rsSourceState As DAO.Recordset
    Dim rsTargetState As DAO.Recordset

    Dim transactionStarted As Boolean
    Dim stepName As String
    Dim errorDescription As String

    Dim sourceType As String
    Dim targetType As String

    Dim sourceName As String
    Dim targetName As String

    Dim sourceCurrentVolumeL As Double
    Dim targetCurrentVolumeL As Double

    Dim sourceNewVolumeL As Double
    Dim targetNewVolumeL As Double

    Dim targetMaxVolumeL As Double
    Dim filtrationLossL As Double

    Dim sourceSort As String
    Dim targetSort As String

    Dim sourceBrewNumbers As String
    Dim targetBrewNumbers As String
    Dim mergedBrewNumbers As String

    Dim sourceFermentationNumber As Long
    Dim targetFermentationNumber As Long
    Dim resultFermentationNumber As Long

    Dim sourceLastBrewDate As Variant
    Dim targetLastBrewDate As Variant
    Dim resultLastBrewDate As Variant

    RegisterCctToForfasWithFiltration = False
    transactionStarted = False

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ' ------------------------------------------------------------
    ' Проверка исходных данных
    ' ------------------------------------------------------------
    stepName = "Проверка исходных данных"

    If sourceCctId <= 0 Then
        Err.Raise vbObjectError + 3000, , "Не указан Код ЦКТ-источника."
    End If

    If targetForfasId <= 0 Then
        Err.Raise vbObjectError + 3001, , "Не указан Код форфаса-приемника."
    End If

    If sourceCctId = targetForfasId Then
        Err.Raise vbObjectError + 3002, , "Источник и приемник не могут быть одной и той же емкостью."
    End If

    If sourceVolumeL <= 0 Then
        Err.Raise vbObjectError + 3003, , "Объем из ЦКТ должен быть больше 0."
    End If

    If targetVolumeL <= 0 Then
        Err.Raise vbObjectError + 3004, , "Объем после фильтрации должен быть больше 0."
    End If

    filtrationLossL = CalculateFiltrationLossL(sourceVolumeL, targetVolumeL)

    If filtrationLossL < 0 Then
        Err.Raise vbObjectError + 3005, , _
            "Объем после фильтрации не может быть больше объема из источника." & vbCrLf & _
            "Объем из ЦКТ: " & sourceVolumeL & " л" & vbCrLf & _
            "Объем в форфас: " & targetVolumeL & " л"
    End If

    ' ------------------------------------------------------------
    ' Проверка типов емкостей
    ' ------------------------------------------------------------
    stepName = "Проверка типов емкостей"

    sourceType = GetVesselTypeById(sourceCctId)
    targetType = GetVesselTypeById(targetForfasId)

    sourceName = GetVesselNameById(sourceCctId)
    targetName = GetVesselNameById(targetForfasId)

    If sourceType <> VESSEL_TYPE_CCT Then
        Err.Raise vbObjectError + 3006, , _
            "Источник должен быть ЦКТ." & vbCrLf & _
            "Фактический тип источника: " & sourceType
    End If

    If targetType <> VESSEL_TYPE_FORFAS Then
        Err.Raise vbObjectError + 3007, , _
            "Приемник должен быть форфасом." & vbCrLf & _
            "Фактический тип приемника: " & targetType
    End If

    If sourceName = "" Then
        sourceName = "ЦКТ с кодом " & sourceCctId
    End If

    If targetName = "" Then
        targetName = "Форфас с кодом " & targetForfasId
    End If

    ' ------------------------------------------------------------
    ' Гарантируем наличие строк состояния
    ' ------------------------------------------------------------
    stepName = "Проверка строк состояния емкостей"

    If EnsureVesselStateRecordForMovement(sourceCctId) = False Then
        Err.Raise vbObjectError + 3008, , "Не удалось проверить состояние ЦКТ."
    End If

    If EnsureVesselStateRecordForMovement(targetForfasId) = False Then
        Err.Raise vbObjectError + 3009, , "Не удалось проверить состояние форфаса."
    End If

    ' ------------------------------------------------------------
    ' Получаем состояния емкостей
    ' ------------------------------------------------------------
    stepName = "Получение состояния емкостей"

    Set rsSourceState = db.OpenRecordset( _
        "SELECT * FROM [tСостояниеЕмкостей] " & _
        "WHERE [Код емкости] = " & sourceCctId & ";", _
        dbOpenDynaset _
    )

    Set rsTargetState = db.OpenRecordset( _
        "SELECT * FROM [tСостояниеЕмкостей] " & _
        "WHERE [Код емкости] = " & targetForfasId & ";", _
        dbOpenDynaset _
    )

    If rsSourceState.EOF Then
        Err.Raise vbObjectError + 3010, , "Не найдена строка состояния ЦКТ."
    End If

    If rsTargetState.EOF Then
        Err.Raise vbObjectError + 3011, , "Не найдена строка состояния форфаса."
    End If

    sourceCurrentVolumeL = Nz(rsSourceState.Fields("Объем(л)").Value, 0)
    targetCurrentVolumeL = Nz(rsTargetState.Fields("Объем(л)").Value, 0)

    sourceSort = Nz(rsSourceState.Fields("Сорт").Value, "")
    targetSort = Nz(rsTargetState.Fields("Сорт").Value, "")

    sourceBrewNumbers = Nz(rsSourceState.Fields("Номера варок").Value, "")
    targetBrewNumbers = Nz(rsTargetState.Fields("Номера варок").Value, "")

    sourceFermentationNumber = Nz(rsSourceState.Fields("Номер брожения").Value, 0)
    targetFermentationNumber = Nz(rsTargetState.Fields("Номер брожения").Value, 0)

    sourceLastBrewDate = rsSourceState.Fields("Дата последней варки").Value
    targetLastBrewDate = rsTargetState.Fields("Дата последней варки").Value

    ' ------------------------------------------------------------
    ' Проверка ЦКТ
    ' ------------------------------------------------------------
    stepName = "Проверка ЦКТ-источника"

    If sourceCurrentVolumeL <= 0 Then
        Err.Raise vbObjectError + 3012, , sourceName & " свободен. Фильтровать нечего."
    End If

    If sourceVolumeL > sourceCurrentVolumeL Then
        Err.Raise vbObjectError + 3013, , _
            "Нельзя отправить на фильтрацию больше, чем есть в ЦКТ." & vbCrLf & _
            "В " & sourceName & ": " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Объем операции: " & sourceVolumeL & " л"
    End If

    If sourceSort = "" Then
        Err.Raise vbObjectError + 3014, , sourceName & " занят, но сорт не указан."
    End If

    If sourceFermentationNumber <= 0 Then
        Err.Raise vbObjectError + 3015, , sourceName & " занят, но номер брожения не указан."
    End If

    ' ------------------------------------------------------------
    ' Проверка форфаса
    ' ------------------------------------------------------------
    stepName = "Проверка форфаса-приемника"

    targetMaxVolumeL = GetVesselMaxVolume(targetForfasId)

    If targetMaxVolumeL <= 0 Then
        Err.Raise vbObjectError + 3016, , "Для " & targetName & " не указан максимальный объем."
    End If

    If targetCurrentVolumeL > 0 Then

        If StrComp(Trim(targetSort), Trim(sourceSort), vbTextCompare) <> 0 Then
            Err.Raise vbObjectError + 3017, , _
                targetName & " уже занят сортом """ & targetSort & """." & vbCrLf & _
                "Нельзя добавить сорт """ & sourceSort & """."
        End If

    End If

    targetNewVolumeL = targetCurrentVolumeL + targetVolumeL

    If targetNewVolumeL > targetMaxVolumeL Then
        Err.Raise vbObjectError + 3018, , _
            "Операция невозможна: будет превышен максимальный объем " & targetName & "." & vbCrLf & _
            "Текущий объем: " & targetCurrentVolumeL & " л" & vbCrLf & _
            "Объем в приемник: " & targetVolumeL & " л" & vbCrLf & _
            "Итоговый объем: " & targetNewVolumeL & " л" & vbCrLf & _
            "Максимальный объем: " & targetMaxVolumeL & " л"
    End If

    sourceNewVolumeL = sourceCurrentVolumeL - sourceVolumeL

    ' ------------------------------------------------------------
    ' Подготовка итоговых служебных данных для форфаса
    ' ------------------------------------------------------------
    stepName = "Подготовка данных для форфаса"

    If targetCurrentVolumeL <= 0 Then

        ' Если форфас был свободен, копируем служебные данные из ЦКТ.
        resultFermentationNumber = sourceFermentationNumber
        mergedBrewNumbers = sourceBrewNumbers
        resultLastBrewDate = sourceLastBrewDate

    Else

        ' Если форфас уже занят тем же сортом,
        ' сохраняем его номер брожения, но объединяем номера варок.
        If targetFermentationNumber > 0 Then
            resultFermentationNumber = targetFermentationNumber
        Else
            resultFermentationNumber = sourceFermentationNumber
        End If

        mergedBrewNumbers = MergeDelimitedTextLists(targetBrewNumbers, sourceBrewNumbers)
        resultLastBrewDate = GetLaterDateValue(targetLastBrewDate, sourceLastBrewDate)

    End If

    ' ------------------------------------------------------------
    ' Транзакция
    ' ------------------------------------------------------------
    stepName = "Начало транзакции"

    ws.BeginTrans
    transactionStarted = True

    ' ------------------------------------------------------------
    ' Запись в журнал tДвиженияЕмкостей
    ' ------------------------------------------------------------
    stepName = "Создание записи движения"

    Set rsMovement = db.OpenRecordset("tДвиженияЕмкостей", dbOpenDynaset)

    rsMovement.AddNew

    rsMovement.Fields("Дата операции").Value = Now()
    rsMovement.Fields("Этап операции").Value = STAGE_CCT_TO_FORFAS_FILTRATION
    rsMovement.Fields("Тип операции").Value = OPERATION_FILTRATION

    rsMovement.Fields("Код емкости источника").Value = sourceCctId
    rsMovement.Fields("Код емкости приемника").Value = targetForfasId

    rsMovement.Fields("Номер брожения").Value = sourceFermentationNumber
    rsMovement.Fields("Сорт").Value = sourceSort
    rsMovement.Fields("Номера варок").Value = sourceBrewNumbers

    rsMovement.Fields("Объем из источника(л)").Value = sourceVolumeL
    rsMovement.Fields("Объем в приемник(л)").Value = targetVolumeL
    rsMovement.Fields("Потери(л)").Value = filtrationLossL

    rsMovement.Fields("Количество кег").Value = Null
    rsMovement.Fields("Объем кеги(л)").Value = Null

    rsMovement.Fields("Комментарий").Value = commentText
    rsMovement.Fields("Отменена").Value = False

    rsMovement.Update

    ' ------------------------------------------------------------
    ' Обновление ЦКТ-источника
    ' ------------------------------------------------------------
    stepName = "Обновление ЦКТ-источника"

    rsSourceState.Edit

    If sourceNewVolumeL <= 0 Then

        ' Если из ЦКТ ушел весь объем, освобождаем емкость.
        rsSourceState.Fields("Дата").Value = Null
        rsSourceState.Fields("Сорт").Value = Null
        rsSourceState.Fields("Объем(л)").Value = 0
        rsSourceState.Fields("Занят").Value = False
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_FREE
        rsSourceState.Fields("Номер брожения").Value = Null
        rsSourceState.Fields("Номера варок").Value = Null
        rsSourceState.Fields("Дата последней варки").Value = Null
        rsSourceState.Fields("Снятие дрожжей").Value = False
        rsSourceState.Fields("Дата снятия дрожжей").Value = Null

    Else

        ' Если часть объема осталась, меняем только объем.
        rsSourceState.Fields("Объем(л)").Value = sourceNewVolumeL
        rsSourceState.Fields("Занят").Value = True
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_BUSY

    End If

    rsSourceState.Update

    ' ------------------------------------------------------------
    ' Обновление форфаса-приемника
    ' ------------------------------------------------------------
    stepName = "Обновление форфаса-приемника"

    rsTargetState.Edit

    ' Для форфаса поле [Дата] трактуем как дату первого наполнения
    ' форфаса в текущем цикле хранения.
    '
    ' Поэтому:
    '   - если форфас был свободен до операции, ставим текущую дату;
    '   - если форфас уже был занят и мы только доливаем продукт,
    '     дату первого наполнения НЕ меняем.
    '
    ' Иначе показатель "Дней в форфасе" будет ошибочно обнуляться
    ' при каждой последующей добавке продукта в уже занятый форфас.
    If targetCurrentVolumeL <= 0 Or IsNull(rsTargetState.Fields("Дата").Value) Then
        rsTargetState.Fields("Дата").Value = Date()
    End If

    rsTargetState.Fields("Сорт").Value = sourceSort
    rsTargetState.Fields("Объем(л)").Value = targetNewVolumeL
    rsTargetState.Fields("Занят").Value = True
    rsTargetState.Fields("Статус").Value = VESSEL_STATUS_BUSY
    rsTargetState.Fields("Номер брожения").Value = resultFermentationNumber
    rsTargetState.Fields("Номера варок").Value = mergedBrewNumbers
    rsTargetState.Fields("Дата последней варки").Value = resultLastBrewDate

    ' Для форфаса поле снятия дрожжей не является рабочей логикой.
    ' Оставляем его сброшенным, чтобы оно не влияло на будущие панели.
    rsTargetState.Fields("Снятие дрожжей").Value = False
    rsTargetState.Fields("Дата снятия дрожжей").Value = Null

    rsTargetState.Update

    ' ------------------------------------------------------------
    ' Подтверждение транзакции
    ' ------------------------------------------------------------
    stepName = "Подтверждение транзакции"

    If transactionStarted = True Then
        ws.CommitTrans
        transactionStarted = False
    End If

    RegisterCctToForfasWithFiltration = True

ExitPoint:

    On Error Resume Next

    If Not rsMovement Is Nothing Then
        rsMovement.Close
    End If

    If Not rsSourceState Is Nothing Then
        rsSourceState.Close
    End If

    If Not rsTargetState Is Nothing Then
        rsTargetState.Close
    End If

    Set rsMovement = Nothing
    Set rsSourceState = Nothing
    Set rsTargetState = Nothing
    Set db = Nothing
    Set ws = Nothing

    Exit Function

ErrorHandler:

    errorDescription = Err.Description

    On Error Resume Next

    If transactionStarted = True Then
        ws.Rollback
        transactionStarted = False
    End If

    RegisterCctToForfasWithFiltration = False

    MsgBox "Не удалось выполнить операцию ЦКТ - Фильтрация - Форфас." & vbCrLf & vbCrLf & _
           "Шаг: " & stepName & vbCrLf & _
           "Ошибка: " & errorDescription, _
           vbExclamation, _
           "Движение емкостей"

    Resume ExitPoint

End Function




Public Function RegisterCctToKegFilling( _
    ByVal sourceCctId As Long, _
    ByVal packageId As Long, _
    ByVal packageCount As Long, _
    ByVal packageUnitVolumeL As Double, _
    ByVal packageType As String, _
    ByVal packageName As String, _
    Optional ByVal commentText As String = "" _
) As Boolean

    ' Регистрирует операцию:
    '   ЦКТ - Розлив
    '
    ' Сейчас это универсальный розлив в тару:
    '   Кега 30 л, Кега 50 л, ПЭТ 1,5 л и т.д.
    '
    ' Для совместимости со старой структурой дополнительно
    ' заполняются поля [Количество кег] и [Объем кеги(л)].
    ' В интерфейсе их нужно трактовать как:
    '   [Количество тары]
    '   [Объем единицы тары(л)]

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim rsMovement As DAO.Recordset
    Dim rsSourceState As DAO.Recordset

    Dim transactionStarted As Boolean
    Dim stepName As String
    Dim errorDescription As String

    Dim sourceType As String
    Dim sourceName As String

    Dim sourceCurrentVolumeL As Double
    Dim sourceNewVolumeL As Double
    Dim fillingVolumeL As Double

    Dim sourceSort As String
    Dim sourceBrewNumbers As String
    Dim sourceFermentationNumber As Long

    RegisterCctToKegFilling = False
    transactionStarted = False

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ' ------------------------------------------------------------
    ' Проверка исходных данных
    ' ------------------------------------------------------------
    stepName = "Проверка исходных данных"

    If sourceCctId <= 0 Then
        Err.Raise vbObjectError + 3200, , "Не указан Код ЦКТ-источника."
    End If

    If packageId <= 0 Then
        Err.Raise vbObjectError + 3201, , "Не выбрана тара."
    End If

    If Trim(packageType) = "" Then
        Err.Raise vbObjectError + 3202, , "Не указан тип тары."
    End If

    If Trim(packageName) = "" Then
        Err.Raise vbObjectError + 3203, , "Не указано название тары."
    End If

    If packageCount <= 0 Then
        Err.Raise vbObjectError + 3204, , "Количество тары должно быть больше 0."
    End If

    If packageUnitVolumeL <= 0 Then
        Err.Raise vbObjectError + 3205, , "Объем единицы тары должен быть больше 0."
    End If

    fillingVolumeL = packageCount * packageUnitVolumeL

    If fillingVolumeL <= 0 Then
        Err.Raise vbObjectError + 3206, , "Объем розлива должен быть больше 0."
    End If

    ' ------------------------------------------------------------
    ' Проверка типа емкости
    ' ------------------------------------------------------------
    stepName = "Проверка типа емкости"

    sourceType = GetVesselTypeById(sourceCctId)
    sourceName = GetVesselNameById(sourceCctId)

    If sourceType <> VESSEL_TYPE_CCT Then
        Err.Raise vbObjectError + 3207, , _
            "Источник должен быть ЦКТ." & vbCrLf & _
            "Фактический тип источника: " & sourceType
    End If

    If sourceName = "" Then
        sourceName = "ЦКТ с кодом " & sourceCctId
    End If

    ' ------------------------------------------------------------
    ' Гарантируем наличие строки состояния
    ' ------------------------------------------------------------
    stepName = "Проверка строки состояния ЦКТ"

    If EnsureVesselStateRecordForMovement(sourceCctId) = False Then
        Err.Raise vbObjectError + 3208, , "Не удалось проверить состояние ЦКТ."
    End If

    ' ------------------------------------------------------------
    ' Получаем состояние ЦКТ
    ' ------------------------------------------------------------
    stepName = "Получение состояния ЦКТ"

    Set rsSourceState = db.OpenRecordset( _
        "SELECT * FROM [tСостояниеЕмкостей] " & _
        "WHERE [Код емкости] = " & sourceCctId & ";", _
        dbOpenDynaset _
    )

    If rsSourceState.EOF Then
        Err.Raise vbObjectError + 3209, , "Не найдена строка состояния ЦКТ."
    End If

    sourceCurrentVolumeL = Nz(rsSourceState.Fields("Объем(л)").Value, 0)
    sourceSort = Nz(rsSourceState.Fields("Сорт").Value, "")
    sourceBrewNumbers = Nz(rsSourceState.Fields("Номера варок").Value, "")
    sourceFermentationNumber = Nz(rsSourceState.Fields("Номер брожения").Value, 0)

    ' ------------------------------------------------------------
    ' Проверка ЦКТ
    ' ------------------------------------------------------------
    stepName = "Проверка ЦКТ-источника"

    If sourceCurrentVolumeL <= 0 Then
        Err.Raise vbObjectError + 3210, , sourceName & " свободен. Разливать нечего."
    End If

    If fillingVolumeL > sourceCurrentVolumeL Then
        Err.Raise vbObjectError + 3211, , _
            "Нельзя разлить больше, чем есть в ЦКТ." & vbCrLf & _
            "В " & sourceName & ": " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Тара: " & packageName & vbCrLf & _
            "Количество тары: " & packageCount & vbCrLf & _
            "Объем единицы тары: " & packageUnitVolumeL & " л" & vbCrLf & _
            "Объем розлива: " & fillingVolumeL & " л"
    End If

    If sourceSort = "" Then
        Err.Raise vbObjectError + 3212, , sourceName & " занят, но сорт не указан."
    End If

    If sourceFermentationNumber <= 0 Then
        Err.Raise vbObjectError + 3213, , sourceName & " занят, но номер брожения не указан."
    End If

    sourceNewVolumeL = sourceCurrentVolumeL - fillingVolumeL

    ' ------------------------------------------------------------
    ' Транзакция
    ' ------------------------------------------------------------
    stepName = "Начало транзакции"

    ws.BeginTrans
    transactionStarted = True

    ' ------------------------------------------------------------
    ' Запись в журнал tДвиженияЕмкостей
    ' ------------------------------------------------------------
    stepName = "Создание записи движения"

    Set rsMovement = db.OpenRecordset("tДвиженияЕмкостей", dbOpenDynaset)

    rsMovement.AddNew

    rsMovement.Fields("Дата операции").Value = Now()
    rsMovement.Fields("Этап операции").Value = STAGE_CCT_TO_KEG_FILLING
    rsMovement.Fields("Тип операции").Value = OPERATION_FILLING

    rsMovement.Fields("Код емкости источника").Value = sourceCctId
    rsMovement.Fields("Код емкости приемника").Value = Null

    rsMovement.Fields("Номер брожения").Value = sourceFermentationNumber
    rsMovement.Fields("Сорт").Value = sourceSort
    rsMovement.Fields("Номера варок").Value = sourceBrewNumbers

    rsMovement.Fields("Объем из источника(л)").Value = fillingVolumeL
    rsMovement.Fields("Объем в приемник(л)").Value = fillingVolumeL
    rsMovement.Fields("Потери(л)").Value = 0

    ' Старые поля оставляем для совместимости.
    rsMovement.Fields("Количество кег").Value = packageCount
    rsMovement.Fields("Объем кеги(л)").Value = packageUnitVolumeL

    ' Новые универсальные поля тары.
    rsMovement.Fields("Код тары").Value = packageId
    rsMovement.Fields("Тип тары").Value = packageType
    rsMovement.Fields("Название тары").Value = packageName
    rsMovement.Fields("Количество тары").Value = packageCount
    rsMovement.Fields("Объем единицы тары(л)").Value = packageUnitVolumeL

    rsMovement.Fields("Комментарий").Value = commentText
    rsMovement.Fields("Отменена").Value = False

    rsMovement.Update

    ' ------------------------------------------------------------
    ' Обновление ЦКТ-источника
    ' ------------------------------------------------------------
    stepName = "Обновление ЦКТ-источника"

    rsSourceState.Edit

    If sourceNewVolumeL <= 0 Then

        ' Если из ЦКТ ушел весь объем, освобождаем емкость.
        rsSourceState.Fields("Дата").Value = Null
        rsSourceState.Fields("Сорт").Value = Null
        rsSourceState.Fields("Объем(л)").Value = 0
        rsSourceState.Fields("Занят").Value = False
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_FREE
        rsSourceState.Fields("Номер брожения").Value = Null
        rsSourceState.Fields("Номера варок").Value = Null
        rsSourceState.Fields("Дата последней варки").Value = Null
        rsSourceState.Fields("Снятие дрожжей").Value = False
        rsSourceState.Fields("Дата снятия дрожжей").Value = Null

    Else

        ' Если часть объема осталась, меняем только объем.
        rsSourceState.Fields("Объем(л)").Value = sourceNewVolumeL
        rsSourceState.Fields("Занят").Value = True
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_BUSY

    End If

    rsSourceState.Update

    ' ------------------------------------------------------------
    ' Подтверждение транзакции
    ' ------------------------------------------------------------
    stepName = "Подтверждение транзакции"

    If transactionStarted = True Then
        ws.CommitTrans
        transactionStarted = False
    End If

    RegisterCctToKegFilling = True

ExitPoint:

    On Error Resume Next

    If Not rsMovement Is Nothing Then
        rsMovement.Close
    End If

    If Not rsSourceState Is Nothing Then
        rsSourceState.Close
    End If

    Set rsMovement = Nothing
    Set rsSourceState = Nothing
    Set db = Nothing
    Set ws = Nothing

    Exit Function

ErrorHandler:

    errorDescription = Err.Description

    On Error Resume Next

    If transactionStarted = True Then
        ws.Rollback
        transactionStarted = False
    End If

    RegisterCctToKegFilling = False

    MsgBox "Не удалось выполнить операцию ЦКТ - Розлив." & vbCrLf & vbCrLf & _
           "Шаг: " & stepName & vbCrLf & _
           "Ошибка: " & errorDescription, _
           vbExclamation, _
           "Движение емкостей"

    Resume ExitPoint

End Function



Public Function RegisterCctAdjustment( _
    ByVal sourceCctId As Long, _
    ByVal adjustmentVolumeL As Double, _
    ByVal commentText As String _
) As Boolean

    ' Регистрирует операцию:
    '   Корректировка ЦКТ
    '
    ' adjustmentVolumeL:
    '   > 0  — положительная корректировка объема;
    '   < 0  — отрицательная корректировка объема;
    '   = 0  — запрещено.
    '
    ' Комментарий обязателен для любой корректировки.
    '
    ' Важно:
    '   Корректировка не меняет сорт, номер брожения,
    '   номера варок и дату последней варки.
    '
    '   Если после отрицательной корректировки объем стал 0,
    '   ЦКТ освобождается.
    '
    '   Свободный ЦКТ нельзя начать с корректировки,
    '   потому что неизвестны сорт, номер брожения и номера варок.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim rsMovement As DAO.Recordset
    Dim rsSourceState As DAO.Recordset

    Dim transactionStarted As Boolean
    Dim stepName As String
    Dim errorDescription As String

    Dim sourceType As String
    Dim sourceName As String

    Dim sourceCurrentVolumeL As Double
    Dim sourceNewVolumeL As Double
    Dim sourceMaxVolumeL As Double

    Dim sourceSort As String
    Dim sourceBrewNumbers As String
    Dim sourceFermentationNumber As Long

    RegisterCctAdjustment = False
    transactionStarted = False

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ' ------------------------------------------------------------
    ' Проверка исходных данных
    ' ------------------------------------------------------------
    stepName = "Проверка исходных данных"

    If sourceCctId <= 0 Then
        Err.Raise vbObjectError + 3400, , "Не указан Код ЦКТ."
    End If

    If adjustmentVolumeL = 0 Then
        Err.Raise vbObjectError + 3401, , "Объем корректировки не может быть равен 0."
    End If

    If Trim(Nz(commentText, "")) = "" Then
        Err.Raise vbObjectError + 3402, , "Для корректировки ЦКТ необходимо указать комментарий."
    End If

    ' ------------------------------------------------------------
    ' Проверка типа емкости
    ' ------------------------------------------------------------
    stepName = "Проверка типа емкости"

    sourceType = GetVesselTypeById(sourceCctId)
    sourceName = GetVesselNameById(sourceCctId)

    If sourceType <> VESSEL_TYPE_CCT Then
        Err.Raise vbObjectError + 3403, , _
            "Источник должен быть ЦКТ." & vbCrLf & _
            "Фактический тип источника: " & sourceType
    End If

    If sourceName = "" Then
        sourceName = "ЦКТ с кодом " & sourceCctId
    End If

    ' ------------------------------------------------------------
    ' Гарантируем наличие строки состояния
    ' ------------------------------------------------------------
    stepName = "Проверка строки состояния ЦКТ"

    If EnsureVesselStateRecordForMovement(sourceCctId) = False Then
        Err.Raise vbObjectError + 3404, , "Не удалось проверить состояние ЦКТ."
    End If

    ' ------------------------------------------------------------
    ' Получаем состояние ЦКТ
    ' ------------------------------------------------------------
    stepName = "Получение состояния ЦКТ"

    Set rsSourceState = db.OpenRecordset( _
        "SELECT * FROM [tСостояниеЕмкостей] " & _
        "WHERE [Код емкости] = " & sourceCctId & ";", _
        dbOpenDynaset _
    )

    If rsSourceState.EOF Then
        Err.Raise vbObjectError + 3405, , "Не найдена строка состояния ЦКТ."
    End If

    sourceCurrentVolumeL = Nz(rsSourceState.Fields("Объем(л)").Value, 0)
    sourceSort = Nz(rsSourceState.Fields("Сорт").Value, "")
    sourceBrewNumbers = Nz(rsSourceState.Fields("Номера варок").Value, "")
    sourceFermentationNumber = Nz(rsSourceState.Fields("Номер брожения").Value, 0)
    sourceMaxVolumeL = GetVesselMaxVolume(sourceCctId)

    ' ------------------------------------------------------------
    ' Проверка ЦКТ
    ' ------------------------------------------------------------
    stepName = "Проверка ЦКТ"

    If sourceCurrentVolumeL <= 0 Then
        Err.Raise vbObjectError + 3406, , sourceName & " свободен. Корректировать нечего."
    End If

    If sourceSort = "" Then
        Err.Raise vbObjectError + 3407, , sourceName & " занят, но сорт не указан."
    End If

    If sourceFermentationNumber <= 0 Then
        Err.Raise vbObjectError + 3408, , sourceName & " занят, но номер брожения не указан."
    End If

    If sourceMaxVolumeL <= 0 Then
        Err.Raise vbObjectError + 3409, , "Для " & sourceName & " не указан максимальный объем."
    End If

    sourceNewVolumeL = sourceCurrentVolumeL + adjustmentVolumeL

    If sourceNewVolumeL < 0 Then
        Err.Raise vbObjectError + 3410, , _
            "Корректировка невозможна: итоговый объем станет отрицательным." & vbCrLf & _
            "Текущий объем: " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Корректировка: " & adjustmentVolumeL & " л" & vbCrLf & _
            "Итоговый объем: " & sourceNewVolumeL & " л"
    End If

    If sourceNewVolumeL > sourceMaxVolumeL Then
        Err.Raise vbObjectError + 3411, , _
            "Корректировка невозможна: будет превышен максимальный объем " & sourceName & "." & vbCrLf & _
            "Текущий объем: " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Корректировка: " & adjustmentVolumeL & " л" & vbCrLf & _
            "Итоговый объем: " & sourceNewVolumeL & " л" & vbCrLf & _
            "Максимальный объем: " & sourceMaxVolumeL & " л"
    End If

    ' ------------------------------------------------------------
    ' Транзакция
    ' ------------------------------------------------------------
    stepName = "Начало транзакции"

    ws.BeginTrans
    transactionStarted = True

    ' ------------------------------------------------------------
    ' Запись в журнал tДвиженияЕмкостей
    ' ------------------------------------------------------------
    stepName = "Создание записи движения"

    Set rsMovement = db.OpenRecordset("tДвиженияЕмкостей", dbOpenDynaset)

    rsMovement.AddNew

    rsMovement.Fields("Дата операции").Value = Now()
    rsMovement.Fields("Этап операции").Value = STAGE_CCT_ADJUSTMENT
    rsMovement.Fields("Тип операции").Value = OPERATION_ADJUSTMENT

    rsMovement.Fields("Код емкости источника").Value = sourceCctId
    rsMovement.Fields("Код емкости приемника").Value = Null

    rsMovement.Fields("Номер брожения").Value = sourceFermentationNumber
    rsMovement.Fields("Сорт").Value = sourceSort
    rsMovement.Fields("Номера варок").Value = sourceBrewNumbers

    ' Для корректировки здесь хранится знаковая дельта объема.
    rsMovement.Fields("Объем из источника(л)").Value = adjustmentVolumeL
    rsMovement.Fields("Объем в приемник(л)").Value = Null
    rsMovement.Fields("Потери(л)").Value = 0

    rsMovement.Fields("Количество кег").Value = Null
    rsMovement.Fields("Объем кеги(л)").Value = Null

    rsMovement.Fields("Комментарий").Value = commentText
    rsMovement.Fields("Отменена").Value = False

    rsMovement.Update

    ' ------------------------------------------------------------
    ' Обновление ЦКТ
    ' ------------------------------------------------------------
    stepName = "Обновление ЦКТ"

    rsSourceState.Edit

    If sourceNewVolumeL <= 0 Then

        ' Если после корректировки объем стал 0,
        ' освобождаем ЦКТ.
        rsSourceState.Fields("Дата").Value = Null
        rsSourceState.Fields("Сорт").Value = Null
        rsSourceState.Fields("Объем(л)").Value = 0
        rsSourceState.Fields("Занят").Value = False
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_FREE
        rsSourceState.Fields("Номер брожения").Value = Null
        rsSourceState.Fields("Номера варок").Value = Null
        rsSourceState.Fields("Дата последней варки").Value = Null
        rsSourceState.Fields("Снятие дрожжей").Value = False
        rsSourceState.Fields("Дата снятия дрожжей").Value = Null

    Else

        ' Если объем остался положительным,
        ' меняем только объем и статус занятости.
        rsSourceState.Fields("Объем(л)").Value = sourceNewVolumeL
        rsSourceState.Fields("Занят").Value = True
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_BUSY

    End If

    rsSourceState.Update

    ' ------------------------------------------------------------
    ' Подтверждение транзакции
    ' ------------------------------------------------------------
    stepName = "Подтверждение транзакции"

    If transactionStarted = True Then
        ws.CommitTrans
        transactionStarted = False
    End If

    RegisterCctAdjustment = True

ExitPoint:

    On Error Resume Next

    If Not rsMovement Is Nothing Then
        rsMovement.Close
    End If

    If Not rsSourceState Is Nothing Then
        rsSourceState.Close
    End If

    Set rsMovement = Nothing
    Set rsSourceState = Nothing
    Set db = Nothing
    Set ws = Nothing

    Exit Function

ErrorHandler:

    errorDescription = Err.Description

    On Error Resume Next

    If transactionStarted = True Then
        ws.Rollback
        transactionStarted = False
    End If

    RegisterCctAdjustment = False

    MsgBox "Не удалось выполнить операцию Корректировка ЦКТ." & vbCrLf & vbCrLf & _
           "Шаг: " & stepName & vbCrLf & _
           "Ошибка: " & errorDescription, _
           vbExclamation, _
           "Движение емкостей"

    Resume ExitPoint

End Function



Public Function RegisterForfasToKegFilling( _
    ByVal sourceForfasId As Long, _
    ByVal packageId As Long, _
    ByVal packageCount As Long, _
    ByVal packageUnitVolumeL As Double, _
    ByVal packageType As String, _
    ByVal packageName As String, _
    Optional ByVal commentText As String = "" _
) As Boolean

    ' Регистрирует операцию:
    '   Форфас - Розлив
    '
    ' Сейчас это универсальный розлив в тару:
    '   Кега 30 л, Кега 50 л, ПЭТ 1,5 л и т.д.
    '
    ' Для совместимости со старой структурой дополнительно
    ' заполняются поля [Количество кег] и [Объем кеги(л)].
    ' В интерфейсе их нужно трактовать как:
    '   [Количество тары]
    '   [Объем единицы тары(л)]

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim rsMovement As DAO.Recordset
    Dim rsSourceState As DAO.Recordset

    Dim transactionStarted As Boolean
    Dim stepName As String
    Dim errorDescription As String

    Dim sourceType As String
    Dim sourceName As String

    Dim sourceCurrentVolumeL As Double
    Dim sourceNewVolumeL As Double
    Dim fillingVolumeL As Double

    Dim sourceSort As String
    Dim sourceBrewNumbers As String
    Dim sourceFermentationNumber As Long

    RegisterForfasToKegFilling = False
    transactionStarted = False

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ' ------------------------------------------------------------
    ' Проверка исходных данных
    ' ------------------------------------------------------------
    stepName = "Проверка исходных данных"

    If sourceForfasId <= 0 Then
        Err.Raise vbObjectError + 3200, , "Не указан Код форфаса-источника."
    End If

    If packageId <= 0 Then
        Err.Raise vbObjectError + 3201, , "Не выбрана тара."
    End If

    If Trim(packageType) = "" Then
        Err.Raise vbObjectError + 3202, , "Не указан тип тары."
    End If

    If Trim(packageName) = "" Then
        Err.Raise vbObjectError + 3203, , "Не указано название тары."
    End If

    If packageCount <= 0 Then
        Err.Raise vbObjectError + 3204, , "Количество тары должно быть больше 0."
    End If

    If packageUnitVolumeL <= 0 Then
        Err.Raise vbObjectError + 3205, , "Объем единицы тары должен быть больше 0."
    End If

    fillingVolumeL = packageCount * packageUnitVolumeL

    If fillingVolumeL <= 0 Then
        Err.Raise vbObjectError + 3206, , "Объем розлива должен быть больше 0."
    End If

    ' ------------------------------------------------------------
    ' Проверка типа емкости
    ' ------------------------------------------------------------
    stepName = "Проверка типа емкости"

    sourceType = GetVesselTypeById(sourceForfasId)
    sourceName = GetVesselNameById(sourceForfasId)

    If sourceType <> VESSEL_TYPE_FORFAS Then
        Err.Raise vbObjectError + 3207, , _
            "Источник должен быть форфасом." & vbCrLf & _
            "Фактический тип источника: " & sourceType
    End If

    If sourceName = "" Then
        sourceName = "Форфас с кодом " & sourceForfasId
    End If

    ' ------------------------------------------------------------
    ' Гарантируем наличие строки состояния
    ' ------------------------------------------------------------
    stepName = "Проверка строки состояния форфаса"

    If EnsureVesselStateRecordForMovement(sourceForfasId) = False Then
        Err.Raise vbObjectError + 3208, , "Не удалось проверить состояние форфаса."
    End If

    ' ------------------------------------------------------------
    ' Получаем состояние ЦКТ
    ' ------------------------------------------------------------
    stepName = "Получение состояния форфаса"

    Set rsSourceState = db.OpenRecordset( _
        "SELECT * FROM [tСостояниеЕмкостей] " & _
        "WHERE [Код емкости] = " & sourceForfasId & ";", _
        dbOpenDynaset _
    )

    If rsSourceState.EOF Then
        Err.Raise vbObjectError + 3209, , "Не найдена строка состояния форфаса."
    End If

    sourceCurrentVolumeL = Nz(rsSourceState.Fields("Объем(л)").Value, 0)
    sourceSort = Nz(rsSourceState.Fields("Сорт").Value, "")
    sourceBrewNumbers = Nz(rsSourceState.Fields("Номера варок").Value, "")
    sourceFermentationNumber = Nz(rsSourceState.Fields("Номер брожения").Value, 0)

    ' ------------------------------------------------------------
    ' Проверка ЦКТ
    ' ------------------------------------------------------------
    stepName = "Проверка форфаса-источника"

    If sourceCurrentVolumeL <= 0 Then
        Err.Raise vbObjectError + 3210, , sourceName & " свободен. Разливать нечего."
    End If

    If fillingVolumeL > sourceCurrentVolumeL Then
        Err.Raise vbObjectError + 3211, , _
            "Нельзя разлить больше, чем есть в форфасе." & vbCrLf & _
            "В " & sourceName & ": " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Тара: " & packageName & vbCrLf & _
            "Количество тары: " & packageCount & vbCrLf & _
            "Объем единицы тары: " & packageUnitVolumeL & " л" & vbCrLf & _
            "Объем розлива: " & fillingVolumeL & " л"
    End If

    If sourceSort = "" Then
        Err.Raise vbObjectError + 3212, , sourceName & " занят, но сорт не указан."
    End If

    If sourceFermentationNumber <= 0 Then
        Err.Raise vbObjectError + 3213, , sourceName & " занят, но номер брожения не указан."
    End If

    sourceNewVolumeL = sourceCurrentVolumeL - fillingVolumeL

    ' ------------------------------------------------------------
    ' Транзакция
    ' ------------------------------------------------------------
    stepName = "Начало транзакции"

    ws.BeginTrans
    transactionStarted = True

    ' ------------------------------------------------------------
    ' Запись в журнал tДвиженияЕмкостей
    ' ------------------------------------------------------------
    stepName = "Создание записи движения"

    Set rsMovement = db.OpenRecordset("tДвиженияЕмкостей", dbOpenDynaset)

    rsMovement.AddNew

    rsMovement.Fields("Дата операции").Value = Now()
    rsMovement.Fields("Этап операции").Value = STAGE_FORFAS_TO_KEG_FILLING
    rsMovement.Fields("Тип операции").Value = OPERATION_FILLING

    rsMovement.Fields("Код емкости источника").Value = sourceForfasId
    rsMovement.Fields("Код емкости приемника").Value = Null

    rsMovement.Fields("Номер брожения").Value = sourceFermentationNumber
    rsMovement.Fields("Сорт").Value = sourceSort
    rsMovement.Fields("Номера варок").Value = sourceBrewNumbers

    rsMovement.Fields("Объем из источника(л)").Value = fillingVolumeL
    rsMovement.Fields("Объем в приемник(л)").Value = fillingVolumeL
    rsMovement.Fields("Потери(л)").Value = 0

    ' Старые поля оставляем для совместимости.
    rsMovement.Fields("Количество кег").Value = packageCount
    rsMovement.Fields("Объем кеги(л)").Value = packageUnitVolumeL

    ' Новые универсальные поля тары.
    rsMovement.Fields("Код тары").Value = packageId
    rsMovement.Fields("Тип тары").Value = packageType
    rsMovement.Fields("Название тары").Value = packageName
    rsMovement.Fields("Количество тары").Value = packageCount
    rsMovement.Fields("Объем единицы тары(л)").Value = packageUnitVolumeL

    rsMovement.Fields("Комментарий").Value = commentText
    rsMovement.Fields("Отменена").Value = False

    rsMovement.Update

    ' ------------------------------------------------------------
    ' Обновление форфаса-источника
    ' ------------------------------------------------------------
    stepName = "Обновление форфаса-источника"

    rsSourceState.Edit

    If sourceNewVolumeL <= 0 Then

        ' Если из форфаса ушел весь объем, освобождаем емкость.
        rsSourceState.Fields("Дата").Value = Null
        rsSourceState.Fields("Сорт").Value = Null
        rsSourceState.Fields("Объем(л)").Value = 0
        rsSourceState.Fields("Занят").Value = False
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_FREE
        rsSourceState.Fields("Номер брожения").Value = Null
        rsSourceState.Fields("Номера варок").Value = Null
        rsSourceState.Fields("Дата последней варки").Value = Null
        rsSourceState.Fields("Снятие дрожжей").Value = False
        rsSourceState.Fields("Дата снятия дрожжей").Value = Null

    Else

        ' Если часть объема осталась, меняем только объем.
        rsSourceState.Fields("Объем(л)").Value = sourceNewVolumeL
        rsSourceState.Fields("Занят").Value = True
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_BUSY

    End If

    rsSourceState.Update

    ' ------------------------------------------------------------
    ' Подтверждение транзакции
    ' ------------------------------------------------------------
    stepName = "Подтверждение транзакции"

    If transactionStarted = True Then
        ws.CommitTrans
        transactionStarted = False
    End If

    RegisterForfasToKegFilling = True

ExitPoint:

    On Error Resume Next

    If Not rsMovement Is Nothing Then
        rsMovement.Close
    End If

    If Not rsSourceState Is Nothing Then
        rsSourceState.Close
    End If

    Set rsMovement = Nothing
    Set rsSourceState = Nothing
    Set db = Nothing
    Set ws = Nothing

    Exit Function

ErrorHandler:

    errorDescription = Err.Description

    On Error Resume Next

    If transactionStarted = True Then
        ws.Rollback
        transactionStarted = False
    End If

    RegisterForfasToKegFilling = False

    MsgBox "Не удалось выполнить операцию Форфас - Розлив." & vbCrLf & vbCrLf & _
           "Шаг: " & stepName & vbCrLf & _
           "Ошибка: " & errorDescription, _
           vbExclamation, _
           "Движение емкостей"

    Resume ExitPoint

End Function


Public Function RegisterForfasAdjustment( _
    ByVal sourceForfasId As Long, _
    ByVal adjustmentVolumeL As Double, _
    ByVal commentText As String _
) As Boolean

    ' Регистрирует операцию:
    '   Корректировка Форфаса
    '
    ' adjustmentVolumeL:
    '   > 0  — положительная корректировка объема;
    '   < 0  — отрицательная корректировка объема;
    '   = 0  — запрещено.
    '
    ' Комментарий обязателен для любой корректировки.
    '
    ' Корректировка не меняет сорт, номер брожения,
    ' номера варок, дату первого наполнения и дату последней варки.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim rsMovement As DAO.Recordset
    Dim rsSourceState As DAO.Recordset

    Dim transactionStarted As Boolean
    Dim stepName As String
    Dim errorDescription As String

    Dim sourceType As String
    Dim sourceName As String

    Dim sourceCurrentVolumeL As Double
    Dim sourceNewVolumeL As Double
    Dim sourceMaxVolumeL As Double

    Dim sourceSort As String
    Dim sourceBrewNumbers As String
    Dim sourceFermentationNumber As Long

    RegisterForfasAdjustment = False
    transactionStarted = False

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ' ------------------------------------------------------------
    ' Проверка исходных данных
    ' ------------------------------------------------------------
    stepName = "Проверка исходных данных"

    If sourceForfasId <= 0 Then
        Err.Raise vbObjectError + 3800, , "Не указан Код форфаса."
    End If

    If adjustmentVolumeL = 0 Then
        Err.Raise vbObjectError + 3801, , "Объем корректировки не может быть равен 0."
    End If

    If Trim(Nz(commentText, "")) = "" Then
        Err.Raise vbObjectError + 3802, , "Для корректировки форфаса необходимо указать комментарий."
    End If

    ' ------------------------------------------------------------
    ' Проверка типа емкости
    ' ------------------------------------------------------------
    stepName = "Проверка типа емкости"

    sourceType = GetVesselTypeById(sourceForfasId)
    sourceName = GetVesselNameById(sourceForfasId)

    If sourceType <> VESSEL_TYPE_FORFAS Then
        Err.Raise vbObjectError + 3803, , _
            "Источник должен быть форфасом." & vbCrLf & _
            "Фактический тип источника: " & sourceType
    End If

    If sourceName = "" Then
        sourceName = "Форфас с кодом " & sourceForfasId
    End If

    ' ------------------------------------------------------------
    ' Гарантируем наличие строки состояния
    ' ------------------------------------------------------------
    stepName = "Проверка строки состояния форфаса"

    If EnsureVesselStateRecordForMovement(sourceForfasId) = False Then
        Err.Raise vbObjectError + 3804, , "Не удалось проверить состояние форфаса."
    End If

    ' ------------------------------------------------------------
    ' Получаем состояние форфаса
    ' ------------------------------------------------------------
    stepName = "Получение состояния форфаса"

    Set rsSourceState = db.OpenRecordset( _
        "SELECT * FROM [tСостояниеЕмкостей] " & _
        "WHERE [Код емкости] = " & sourceForfasId & ";", _
        dbOpenDynaset _
    )

    If rsSourceState.EOF Then
        Err.Raise vbObjectError + 3805, , "Не найдена строка состояния форфаса."
    End If

    sourceCurrentVolumeL = Nz(rsSourceState.Fields("Объем(л)").Value, 0)
    sourceSort = Nz(rsSourceState.Fields("Сорт").Value, "")
    sourceBrewNumbers = Nz(rsSourceState.Fields("Номера варок").Value, "")
    sourceFermentationNumber = Nz(rsSourceState.Fields("Номер брожения").Value, 0)
    sourceMaxVolumeL = GetVesselMaxVolume(sourceForfasId)

    ' ------------------------------------------------------------
    ' Проверка форфаса
    ' ------------------------------------------------------------
    stepName = "Проверка форфаса"

    If sourceCurrentVolumeL <= 0 Then
        Err.Raise vbObjectError + 3806, , sourceName & " свободен. Корректировать нечего."
    End If

    If sourceSort = "" Then
        Err.Raise vbObjectError + 3807, , sourceName & " занят, но сорт не указан."
    End If

    If sourceFermentationNumber <= 0 Then
        Err.Raise vbObjectError + 3808, , sourceName & " занят, но номер брожения не указан."
    End If

    If sourceMaxVolumeL <= 0 Then
        Err.Raise vbObjectError + 3809, , "Для " & sourceName & " не указан максимальный объем."
    End If

    sourceNewVolumeL = sourceCurrentVolumeL + adjustmentVolumeL

    If sourceNewVolumeL < 0 Then
        Err.Raise vbObjectError + 3810, , _
            "Корректировка невозможна: итоговый объем станет отрицательным." & vbCrLf & _
            "Текущий объем: " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Корректировка: " & adjustmentVolumeL & " л" & vbCrLf & _
            "Итоговый объем: " & sourceNewVolumeL & " л"
    End If

    If sourceNewVolumeL > sourceMaxVolumeL Then
        Err.Raise vbObjectError + 3811, , _
            "Корректировка невозможна: будет превышен максимальный объем " & sourceName & "." & vbCrLf & _
            "Текущий объем: " & sourceCurrentVolumeL & " л" & vbCrLf & _
            "Корректировка: " & adjustmentVolumeL & " л" & vbCrLf & _
            "Итоговый объем: " & sourceNewVolumeL & " л" & vbCrLf & _
            "Максимальный объем: " & sourceMaxVolumeL & " л"
    End If

    ' ------------------------------------------------------------
    ' Транзакция
    ' ------------------------------------------------------------
    stepName = "Начало транзакции"

    ws.BeginTrans
    transactionStarted = True

    ' ------------------------------------------------------------
    ' Запись в журнал tДвиженияЕмкостей
    ' ------------------------------------------------------------
    stepName = "Создание записи движения"

    Set rsMovement = db.OpenRecordset("tДвиженияЕмкостей", dbOpenDynaset)

    rsMovement.AddNew

    rsMovement.Fields("Дата операции").Value = Now()
    rsMovement.Fields("Этап операции").Value = STAGE_FORFAS_ADJUSTMENT
    rsMovement.Fields("Тип операции").Value = OPERATION_ADJUSTMENT

    rsMovement.Fields("Код емкости источника").Value = sourceForfasId
    rsMovement.Fields("Код емкости приемника").Value = Null

    rsMovement.Fields("Номер брожения").Value = sourceFermentationNumber
    rsMovement.Fields("Сорт").Value = sourceSort
    rsMovement.Fields("Номера варок").Value = sourceBrewNumbers

    ' Для корректировки здесь хранится знаковая дельта объема.
    rsMovement.Fields("Объем из источника(л)").Value = adjustmentVolumeL
    rsMovement.Fields("Объем в приемник(л)").Value = Null
    rsMovement.Fields("Потери(л)").Value = 0

    rsMovement.Fields("Количество кег").Value = Null
    rsMovement.Fields("Объем кеги(л)").Value = Null

    rsMovement.Fields("Комментарий").Value = commentText
    rsMovement.Fields("Отменена").Value = False

    rsMovement.Update

    ' ------------------------------------------------------------
    ' Обновление форфаса
    ' ------------------------------------------------------------
    stepName = "Обновление форфаса"

    rsSourceState.Edit

    If sourceNewVolumeL <= 0 Then

        ' Если после корректировки объем стал 0,
        ' освобождаем форфас.
        rsSourceState.Fields("Дата").Value = Null
        rsSourceState.Fields("Сорт").Value = Null
        rsSourceState.Fields("Объем(л)").Value = 0
        rsSourceState.Fields("Занят").Value = False
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_FREE
        rsSourceState.Fields("Номер брожения").Value = Null
        rsSourceState.Fields("Номера варок").Value = Null
        rsSourceState.Fields("Дата последней варки").Value = Null
        rsSourceState.Fields("Снятие дрожжей").Value = False
        rsSourceState.Fields("Дата снятия дрожжей").Value = Null

    Else

        ' Если объем остался положительным,
        ' меняем только объем и статус занятости.
        rsSourceState.Fields("Объем(л)").Value = sourceNewVolumeL
        rsSourceState.Fields("Занят").Value = True
        rsSourceState.Fields("Статус").Value = VESSEL_STATUS_BUSY

    End If

    rsSourceState.Update

    ' ------------------------------------------------------------
    ' Подтверждение транзакции
    ' ------------------------------------------------------------
    stepName = "Подтверждение транзакции"

    If transactionStarted = True Then
        ws.CommitTrans
        transactionStarted = False
    End If

    RegisterForfasAdjustment = True

ExitPoint:

    On Error Resume Next

    If Not rsMovement Is Nothing Then
        rsMovement.Close
    End If

    If Not rsSourceState Is Nothing Then
        rsSourceState.Close
    End If

    Set rsMovement = Nothing
    Set rsSourceState = Nothing
    Set db = Nothing
    Set ws = Nothing

    Exit Function

ErrorHandler:

    errorDescription = Err.Description

    On Error Resume Next

    If transactionStarted = True Then
        ws.Rollback
        transactionStarted = False
    End If

    RegisterForfasAdjustment = False

    MsgBox "Не удалось выполнить операцию Корректировка Форфаса." & vbCrLf & vbCrLf & _
           "Шаг: " & stepName & vbCrLf & _
           "Ошибка: " & errorDescription, _
           vbExclamation, _
           "Движение емкостей"

    Resume ExitPoint

End Function

Private Function EnsureVesselStateRecordForMovement(ByVal vesselId As Long) As Boolean

    ' Проверяет наличие строки состояния для емкости.
    '
    ' Если строки нет, создает начальное состояние:
    '   объем = 0;
    '   занята = Нет;
    '   статус = Свободен.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim stateCount As Long

    Set db = CurrentDb

    stateCount = DCount("*", "tСостояниеЕмкостей", "[Код емкости] = " & vesselId)

    If stateCount = 0 Then

        db.Execute _
            "INSERT INTO [tСостояниеЕмкостей] " & _
            "([Код емкости], [Объем(л)], [Занят], [Статус], [Снятие дрожжей]) " & _
            "VALUES " & _
            "(" & vesselId & ", 0, False, '" & VESSEL_STATUS_FREE & "', False);", _
            dbFailOnError

    End If

    EnsureVesselStateRecordForMovement = True

ExitPoint:

    Set db = Nothing
    Exit Function

ErrorHandler:

    EnsureVesselStateRecordForMovement = False
    Resume ExitPoint

End Function


Private Function MergeDelimitedTextLists( _
    ByVal firstText As String, _
    ByVal secondText As String _
) As String

    ' Объединяет два списка, разделенных точкой с запятой.
    '
    ' Пример:
    '   "12; 13" + "13; 14"
    '   результат: "12; 13; 14"

    On Error GoTo ErrorHandler

    Dim resultText As String

    resultText = ""

    Call AppendDelimitedItems(resultText, firstText)
    Call AppendDelimitedItems(resultText, secondText)

    MergeDelimitedTextLists = resultText

    Exit Function

ErrorHandler:

    MergeDelimitedTextLists = Trim(Nz(firstText, ""))

End Function


Private Sub AppendDelimitedItems( _
    ByRef resultText As String, _
    ByVal sourceText As String _
)

    ' Добавляет элементы из sourceText в resultText без дублей.

    On Error GoTo ExitPoint

    Dim items() As String
    Dim index As Long
    Dim itemText As String

    If Trim(Nz(sourceText, "")) = "" Then
        Exit Sub
    End If

    items = Split(sourceText, ";")

    For index = LBound(items) To UBound(items)

        itemText = Trim(items(index))

        If itemText <> "" Then

            If DelimitedTextContains(resultText, itemText) = False Then

                If resultText = "" Then
                    resultText = itemText
                Else
                    resultText = resultText & "; " & itemText
                End If

            End If

        End If

    Next index

ExitPoint:

End Sub


Private Function DelimitedTextContains( _
    ByVal sourceText As String, _
    ByVal itemText As String _
) As Boolean

    ' Проверяет наличие элемента в списке через точку с запятой.

    Dim normalizedSource As String
    Dim normalizedItem As String

    normalizedSource = "; " & Trim(Nz(sourceText, "")) & ";"
    normalizedSource = Replace(normalizedSource, ";;", ";")

    normalizedItem = "; " & Trim(Nz(itemText, "")) & ";"

    DelimitedTextContains = (InStr(1, normalizedSource, normalizedItem, vbTextCompare) > 0)

End Function


Private Function GetLaterDateValue( _
    ByVal firstDateValue As Variant, _
    ByVal secondDateValue As Variant _
) As Variant

    ' Возвращает более позднюю из двух дат.
    '
    ' Если одна дата пустая, возвращает другую.
    ' Если обе пустые, возвращает Null.

    If IsNull(firstDateValue) And IsNull(secondDateValue) Then

        GetLaterDateValue = Null

    ElseIf IsNull(firstDateValue) Then

        GetLaterDateValue = secondDateValue

    ElseIf IsNull(secondDateValue) Then

        GetLaterDateValue = firstDateValue

    ElseIf CDate(firstDateValue) >= CDate(secondDateValue) Then

        GetLaterDateValue = firstDateValue

    Else

        GetLaterDateValue = secondDateValue

    End If

End Function

```

### mDatabaseMaintenance_SoftClearWorkingData.bas

**Группа:** `final_preferred`  
**Назначение:** mDatabaseMaintenance — мягкая очистка рабочих данных без удаления справочников.  
**SHA256:** `31318ee5a75dda341aa75b03f0649c0aa25aa8cede98e7bdb1ec4848395719c4`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Модуль: mDatabaseMaintenance
'
' Назначение:
'   Сервисные процедуры обслуживания базы.
'
' Главная процедура:
'   SoftClearWorkingData
'
' Что делает мягкая очистка:
'   - удаляет рабочие движения продукта;
'   - удаляет отправки Варка - ЦКТ;
'   - удаляет варки;
'   - сбрасывает текущее состояние емкостей;
'   - НЕ трогает справочники: емкости, тара, рецепты и т.п.
' ============================================================

Public Sub SoftClearWorkingData()

    ' Мягкая очистка рабочих данных.
    '
    ' ВАЖНО:
    '   Перед выполнением желательно сделать резервную копию файла базы.
    '
    ' Эта процедура НЕ удаляет:
    '   - tЕмкости;
    '   - tТара;
    '   - рецепты;
    '   - справочники.
    '
    ' Эта процедура очищает:
    '   - tДвиженияЕмкостей;
    '   - tИсточникиЦКТ;
    '   - таблицу варок;
    '   - текущее состояние емкостей.

    On Error GoTo ErrorHandler

    Dim userAnswer As VbMsgBoxResult
    Dim userSecondAnswer As VbMsgBoxResult

    userAnswer = MsgBox( _
        "Будут удалены рабочие производственные данные:" & vbCrLf & vbCrLf & _
        "- варки;" & vbCrLf & _
        "- отправки Варка - ЦКТ;" & vbCrLf & _
        "- движения по емкостям;" & vbCrLf & _
        "- текущие объемы и состояния ЦКТ/форфасов будут сброшены." & vbCrLf & vbCrLf & _
        "Справочники емкостей, рецептов и тары останутся." & vbCrLf & vbCrLf & _
        "Продолжить?", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Мягкая очистка рабочих данных" _
    )

    If userAnswer <> vbYes Then
        Exit Sub
    End If

    userSecondAnswer = MsgBox( _
        "Подтвердите очистку еще раз." & vbCrLf & vbCrLf & _
        "Действие нельзя будет отменить штатной кнопкой Access." & vbCrLf & _
        "Перед очисткой рекомендуется сделать копию файла базы.", _
        vbExclamation + vbYesNo + vbDefaultButton2, _
        "Подтверждение очистки" _
    )

    If userSecondAnswer <> vbYes Then
        Exit Sub
    End If

    Call ExecuteSoftClearWorkingData

    MsgBox "Мягкая очистка рабочих данных выполнена." & vbCrLf & vbCrLf & _
           "Справочники сохранены." & vbCrLf & _
           "Состояние емкостей сброшено.", _
           vbInformation, _
           "Мягкая очистка"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить мягкую очистку рабочих данных." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbCritical, _
           "Мягкая очистка"

End Sub

Private Sub ExecuteSoftClearWorkingData()

    ' Выполняет фактическую очистку в транзакции.
    '
    ' Порядок важен:
    '   1. Сначала удаляем дочерние/журнальные записи.
    '   2. Потом удаляем варки.
    '   3. Потом сбрасываем состояния емкостей.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim ws As DAO.Workspace
    Dim transactionStarted As Boolean

    transactionStarted = False

    Set ws = DBEngine.Workspaces(0)
    Set db = CurrentDb

    ws.BeginTrans
    transactionStarted = True

    ' ------------------------------------------------------------
    ' 1. Очищаем универсальные движения емкостей.
    ' ------------------------------------------------------------
    Call DeleteAllRowsIfTableExists(db, "tДвиженияЕмкостей")

    ' ------------------------------------------------------------
    ' 2. Очищаем отправки Варка - ЦКТ.
    ' ------------------------------------------------------------
    Call DeleteAllRowsIfTableExists(db, "tИсточникиЦКТ")

    ' ------------------------------------------------------------
    ' 3. Очищаем таблицу варок.
    '
    ' В проекте форма называется fВарка.
    ' Фактическое имя таблицы может отличаться.
    ' Здесь заложены наиболее вероятные варианты.
    ' ------------------------------------------------------------
    Call DeleteAllRowsIfTableExists(db, "tВарка")
    Call DeleteAllRowsIfTableExists(db, "tВарки")
    Call DeleteAllRowsIfTableExists(db, "Варка")
    Call DeleteAllRowsIfTableExists(db, "Варки")

    ' ------------------------------------------------------------
    ' 4. Сбрасываем состояние емкостей.
    ' ------------------------------------------------------------
    Call ResetVesselStates(db)

    ws.CommitTrans
    transactionStarted = False

ExitPoint:

    On Error Resume Next

    Set db = Nothing
    Set ws = Nothing

    Exit Sub

ErrorHandler:

    On Error Resume Next

    If transactionStarted = True Then
        ws.Rollback
        transactionStarted = False
    End If

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Private Sub DeleteAllRowsIfTableExists( _
    ByVal db As DAO.Database, _
    ByVal tableName As String _
)

    ' Удаляет все строки из таблицы, если таблица существует.
    '
    ' Если таблицы нет — просто пропускает ее.

    On Error GoTo ErrorHandler

    If TableExists(tableName) = False Then
        Debug.Print "Таблица не найдена, пропущена: " & tableName
        Exit Sub
    End If

    db.Execute "DELETE FROM [" & tableName & "];", dbFailOnError

    Debug.Print "Очищена таблица: " & tableName

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, _
        "Ошибка очистки таблицы [" & tableName & "]: " & Err.Description

End Sub

Private Sub ResetVesselStates(ByVal db As DAO.Database)

    ' Сбрасывает текущее состояние всех емкостей.
    '
    ' Справочник tЕмкости не трогаем.
    ' Таблицу tСостояниеЕмкостей не удаляем.
    ' Только приводим емкости к свободному состоянию.

    On Error GoTo ErrorHandler

    If TableExists("tСостояниеЕмкостей") = False Then
        Debug.Print "Таблица tСостояниеЕмкостей не найдена, сброс состояния пропущен."
        Exit Sub
    End If

    db.Execute _
        "UPDATE [tСостояниеЕмкостей] SET " & _
        "[Дата] = Null, " & _
        "[Сорт] = Null, " & _
        "[Объем(л)] = 0, " & _
        "[Занят] = False, " & _
        "[Статус] = 'Свободен', " & _
        "[Номер брожения] = Null, " & _
        "[Номера варок] = Null, " & _
        "[Дата последней варки] = Null, " & _
        "[Снятие дрожжей] = False, " & _
        "[Дата снятия дрожжей] = Null;", _
        dbFailOnError

    Debug.Print "Состояние емкостей сброшено."

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, _
        "Ошибка сброса tСостояниеЕмкостей: " & Err.Description

End Sub

Private Function TableExists(ByVal tableName As String) As Boolean

    ' Проверяет, существует ли таблица с таким именем.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim tdf As DAO.TableDef

    Set db = CurrentDb

    For Each tdf In db.TableDefs

        If StrComp(tdf.Name, tableName, vbTextCompare) = 0 Then
            TableExists = True
            Exit Function
        End If

    Next tdf

    TableExists = False

    Exit Function

ErrorHandler:

    TableExists = False

End Function

```

### mExcelReports_SeparateTemplates_OpenFolder_Full_Code.bas

**Группа:** `final_preferred`  
**Назначение:** mExcelReports — Excel-отчеты по отдельным шаблонам, папки Templates/Reports.  
**SHA256:** `61c9e8f9f4aa54bae780b0d8d74b9f41b459f700942592b1b19c475131f4eb9f`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Модуль: mExcelReports
'
' Назначение:
'   Выгрузка отчетов проекта "Пивовар" в отдельные Excel-шаблоны.
'
' Архитектура:
'   - каждый отчет имеет отдельный файл-шаблон;
'   - каждый шаблон содержит один рабочий лист "Отчет";
'   - готовые файлы сохраняются в папку Reports рядом с базой;
'   - шаблоны должны лежать в папке Templates рядом с базой.
'
' Папка шаблонов:
'   CurrentProject.Path\Templates
'
' Папка отчетов:
'   CurrentProject.Path\Reports
'
' Шаблоны:
'   Pivovar_Report_Filling_Detail_Template.xlsx
'   Pivovar_Report_Filling_By_Package_Template.xlsx
'   Pivovar_Report_Filling_By_Sort_Template.xlsx
'   Pivovar_Report_Filling_By_Batch_Template.xlsx
'   Pivovar_Report_Filtration_Losses_Template.xlsx
'   Pivovar_Report_Batch_State_Template.xlsx
'
' Используется формой:
'   fОтчеты_Параметры
' ============================================================


Public Const REPORT_FILLING_DETAIL As String = "FILLING_DETAIL"
Public Const REPORT_FILLING_BY_PACKAGE As String = "FILLING_BY_PACKAGE"
Public Const REPORT_FILLING_BY_SORT As String = "FILLING_BY_SORT"
Public Const REPORT_FILLING_BY_BATCH As String = "FILLING_BY_BATCH"
Public Const REPORT_FILTRATION_LOSSES As String = "FILTRATION_LOSSES"
Public Const REPORT_BATCH_STATE As String = "BATCH_STATE"

Private Const TEMPLATE_FOLDER As String = "Templates"
Private Const REPORTS_FOLDER As String = "Reports"

Private Const REPORT_SHEET_NAME As String = "Отчет"

Private Const HEADER_ROW As Long = 5
Private Const DATA_START_ROW As Long = 6


' ============================================================
' Публичные процедуры
' ============================================================

Public Sub ExportPivovarReportToExcel( _
    ByVal reportCode As String, _
    Optional ByVal dateFrom As Variant, _
    Optional ByVal dateTo As Variant, _
    Optional ByVal sortValue As Variant, _
    Optional ByVal fermentationNumber As Variant, _
    Optional ByVal packageType As Variant, _
    Optional ByVal sourceType As Variant _
)

    ' Универсальная точка входа для выгрузки отчета в Excel.
    '
    ' Все фильтры необязательные.
    ' Если фильтр пустой / Null, он не применяется.

    On Error GoTo ErrorHandler

    Dim reportTitle As String
    Dim templateFileName As String
    Dim outputPrefix As String
    Dim sqlText As String
    Dim outputPath As String

    reportTitle = GetReportTitle(reportCode)
    templateFileName = GetReportTemplateFileName(reportCode)
    outputPrefix = GetReportOutputPrefix(reportCode)

    sqlText = BuildReportSql( _
        reportCode, _
        dateFrom, _
        dateTo, _
        sortValue, _
        fermentationNumber, _
        packageType, _
        sourceType _
    )

    If Len(sqlText) = 0 Then
        Err.Raise vbObjectError + 7000, , _
            "Не удалось построить SQL для отчета: " & reportCode
    End If

    outputPath = BuildReportOutputPath(outputPrefix)

    Call CopyTemplateToOutput(templateFileName, outputPath)

    Call FillExcelReport( _
        outputPath:=outputPath, _
        sheetName:=REPORT_SHEET_NAME, _
        reportTitle:=reportTitle, _
        sqlText:=sqlText, _
        dateFrom:=dateFrom, _
        dateTo:=dateTo, _
        sortValue:=sortValue, _
        fermentationNumber:=fermentationNumber, _
        packageType:=packageType, _
        sourceType:=sourceType _
    )

    Application.FollowHyperlink outputPath

    MsgBox "Отчет выгружен в Excel:" & vbCrLf & outputPath, _
           vbInformation, _
           "Выгрузка отчета"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выгрузить отчет в Excel." & vbCrLf & vbCrLf & _
           "Отчет: " & reportCode & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbCritical, _
           "Выгрузка отчета"

End Sub


Public Sub OpenPivovarReportsFolder()

    ' Открывает папку с выгруженными Excel-отчетами.
    '
    ' Папка:
    '   CurrentProject.Path\Reports
    '
    ' Если папки нет — создает ее.

    On Error GoTo ErrorHandler

    Dim reportsFolderPath As String

    reportsFolderPath = GetReportsFolderPath()

    If Len(Dir(reportsFolderPath, vbDirectory)) = 0 Then
        MkDir reportsFolderPath
    End If

    Shell "explorer.exe " & Chr$(34) & reportsFolderPath & Chr$(34), vbNormalFocus

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть папку с отчетами." & vbCrLf & _
           "Путь: " & reportsFolderPath & vbCrLf & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Папка отчетов"

End Sub


' ============================================================
' Построение SQL отчетов
' ============================================================

Private Function BuildReportSql( _
    ByVal reportCode As String, _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
) As String

    ' Формирует SQL для выбранного отчета.
    '
    ' Важно:
    '   Для итоговых отчетов по розливу агрегирование строится
    '   динамически от qРозлив_Свод, чтобы фильтр по датам работал
    '   корректно, а не только по месяцу/периоду.

    Select Case reportCode

        Case REPORT_FILLING_DETAIL

            BuildReportSql = BuildFillingDetailSql( _
                dateFrom, _
                dateTo, _
                sortValue, _
                fermentationNumber, _
                packageType, _
                sourceType _
            )

        Case REPORT_FILLING_BY_PACKAGE

            BuildReportSql = BuildFillingByPackageSql( _
                dateFrom, _
                dateTo, _
                sortValue, _
                fermentationNumber, _
                packageType, _
                sourceType _
            )

        Case REPORT_FILLING_BY_SORT

            BuildReportSql = BuildFillingBySortSql( _
                dateFrom, _
                dateTo, _
                sortValue, _
                fermentationNumber, _
                packageType, _
                sourceType _
            )

        Case REPORT_FILLING_BY_BATCH

            BuildReportSql = BuildFillingByBatchSql( _
                dateFrom, _
                dateTo, _
                sortValue, _
                fermentationNumber, _
                packageType, _
                sourceType _
            )

        Case REPORT_FILTRATION_LOSSES

            BuildReportSql = BuildFiltrationLossesSql( _
                dateFrom, _
                dateTo, _
                sortValue, _
                fermentationNumber _
            )

        Case REPORT_BATCH_STATE

            BuildReportSql = BuildBatchStateSql( _
                sortValue, _
                fermentationNumber _
            )

        Case Else

            BuildReportSql = ""

    End Select

End Function


Private Function BuildFillingDetailSql( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
) As String

    Dim whereText As String

    whereText = BuildFillingWhere( _
        dateFrom, _
        dateTo, _
        sortValue, _
        fermentationNumber, _
        packageType, _
        sourceType _
    )

    BuildFillingDetailSql = _
        "SELECT " & _
        "[Дата розлива], " & _
        "[Источник розлива], " & _
        "[Тип источника], " & _
        "[Сорт], " & _
        "[Номер брожения], " & _
        "[Номера варок], " & _
        "[Тип тары], " & _
        "[Название тары], " & _
        "[Количество тары], " & _
        "[Объем единицы тары(л)], " & _
        "[Объем розлива(л)], " & _
        "[Тара текст], " & _
        "[Комментарий] " & _
        "FROM [qРозлив_Свод] " & _
        whereText & _
        " ORDER BY [Дата розлива], [Код движения];"

End Function


Private Function BuildFillingByPackageSql( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
) As String

    Dim whereText As String

    whereText = BuildFillingWhere( _
        dateFrom, _
        dateTo, _
        sortValue, _
        fermentationNumber, _
        packageType, _
        sourceType _
    )

    BuildFillingByPackageSql = _
        "SELECT " & _
        "[Период], " & _
        "[Год], " & _
        "[Месяц], " & _
        "[Сорт], " & _
        "[Тип тары], " & _
        "[Название тары], " & _
        "[Объем единицы тары(л)], " & _
        "Sum(Nz([Количество тары], 0)) AS [Всего единиц тары], " & _
        "Sum(Nz([Объем розлива(л)], 0)) AS [Всего разлито(л)], " & _
        "Count([Код движения]) AS [Количество операций] " & _
        "FROM [qРозлив_Свод] " & _
        whereText & _
        " GROUP BY " & _
        "[Период], [Год], [Месяц], [Сорт], [Тип тары], [Название тары], [Объем единицы тары(л)] " & _
        " ORDER BY [Год] DESC, [Месяц] DESC, [Сорт], [Тип тары], [Название тары];"

End Function


Private Function BuildFillingBySortSql( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
) As String

    Dim whereText As String

    whereText = BuildFillingWhere( _
        dateFrom, _
        dateTo, _
        sortValue, _
        fermentationNumber, _
        packageType, _
        sourceType _
    )

    BuildFillingBySortSql = _
        "SELECT " & _
        "[Период], " & _
        "[Год], " & _
        "[Месяц], " & _
        "[Сорт], " & _
        "Sum(Nz([Объем розлива(л)], 0)) AS [Всего разлито(л)], " & _
        "Sum(Nz([Количество тары], 0)) AS [Всего единиц тары], " & _
        "Count([Код движения]) AS [Количество операций], " & _
        "Min([Дата розлива]) AS [Первый розлив], " & _
        "Max([Дата розлива]) AS [Последний розлив] " & _
        "FROM [qРозлив_Свод] " & _
        whereText & _
        " GROUP BY [Период], [Год], [Месяц], [Сорт] " & _
        " ORDER BY [Год] DESC, [Месяц] DESC, [Сорт];"

End Function


Private Function BuildFillingByBatchSql( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
) As String

    Dim whereText As String

    whereText = BuildFillingWhere( _
        dateFrom, _
        dateTo, _
        sortValue, _
        fermentationNumber, _
        packageType, _
        sourceType _
    )

    BuildFillingByBatchSql = _
        "SELECT " & _
        "[Номер брожения], " & _
        "[Сорт], " & _
        "[Номера варок], " & _
        "[Тип тары], " & _
        "[Название тары], " & _
        "[Объем единицы тары(л)], " & _
        "Sum(Nz([Количество тары], 0)) AS [Всего единиц тары], " & _
        "Sum(Nz([Объем розлива(л)], 0)) AS [Всего разлито(л)], " & _
        "Count([Код движения]) AS [Количество операций], " & _
        "Min([Дата розлива]) AS [Первый розлив], " & _
        "Max([Дата розлива]) AS [Последний розлив] " & _
        "FROM [qРозлив_Свод] " & _
        whereText & _
        " GROUP BY " & _
        "[Номер брожения], [Сорт], [Номера варок], [Тип тары], [Название тары], [Объем единицы тары(л)] " & _
        " ORDER BY [Номер брожения] DESC, [Сорт], [Тип тары], [Название тары];"

End Function


Private Function BuildFiltrationLossesSql( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant _
) As String

    Dim whereText As String

    whereText = BuildFiltrationWhere( _
        dateFrom, _
        dateTo, _
        sortValue, _
        fermentationNumber _
    )

    BuildFiltrationLossesSql = _
        "SELECT " & _
        "[Период], " & _
        "[Год], " & _
        "[Месяц], " & _
        "[Сорт], " & _
        "[Номер брожения], " & _
        "[Номера варок], " & _
        "Sum(Nz([Объем из ЦКТ(л)], 0)) AS [Всего из ЦКТ(л)], " & _
        "Sum(Nz([Объем в форфас(л)], 0)) AS [Всего в форфас(л)], " & _
        "Sum(Nz([Потери(л)], 0)) AS [Всего потери(л)], " & _
        "IIf(Sum(Nz([Объем из ЦКТ(л)], 0)) = 0, Null, " & _
        "Round(Sum(Nz([Потери(л)], 0)) / Sum(Nz([Объем из ЦКТ(л)], 0)) * 100, 2)) AS [Потери(%)], " & _
        "Count([Код движения]) AS [Количество операций], " & _
        "Min([Дата фильтрации]) AS [Первая фильтрация], " & _
        "Max([Дата фильтрации]) AS [Последняя фильтрация] " & _
        "FROM [qФильтрация_Потери] " & _
        whereText & _
        " GROUP BY " & _
        "[Период], [Год], [Месяц], [Сорт], [Номер брожения], [Номера варок] " & _
        " ORDER BY [Год] DESC, [Месяц] DESC, [Сорт], [Номер брожения];"

End Function


Private Function BuildBatchStateSql( _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant _
) As String

    Dim whereText As String

    whereText = ""

    If HasValue(sortValue) Then
        Call AddWherePart(whereText, "[Сорт] = " & SqlTextLiteral(sortValue))
    End If

    If HasValue(fermentationNumber) Then
        If IsNumeric(fermentationNumber) Then
            Call AddWherePart(whereText, "[Номер брожения] = " & CLng(fermentationNumber))
        End If
    End If

    If Len(whereText) > 0 Then
        whereText = " WHERE " & whereText
    End If

    BuildBatchStateSql = _
        "SELECT " & _
        "[Номер брожения], " & _
        "[Сорт], " & _
        "[Номера варок], " & _
        "[Всего поступило в ЦКТ(л)], " & _
        "[Потери фильтрации(л)], " & _
        "[Всего разлито(л)], " & _
        "[Всего корректировки(л)], " & _
        "[Расчетный остаток в емкостях(л)], " & _
        "[Фактический остаток в емкостях(л)], " & _
        "[Расхождение(л)], " & _
        "[Статус сверки], " & _
        "[Статус партии], " & _
        "[Разлито от поступившего(%)], " & _
        "[Потери от поступившего(%)] " & _
        "FROM [qПартии_Состояние] " & _
        whereText & _
        " ORDER BY [Номер брожения] DESC, [Сорт];"

End Function


' ============================================================
' WHERE-фильтры
' ============================================================

Private Function BuildFillingWhere( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
) As String

    Dim whereText As String

    whereText = ""

    If HasValue(dateFrom) Then
        If IsDate(dateFrom) Then
            Call AddWherePart(whereText, "[Дата розлива] >= " & SqlDateLiteral(dateFrom))
        End If
    End If

    If HasValue(dateTo) Then
        If IsDate(dateTo) Then
            Call AddWherePart(whereText, "[Дата розлива] < " & SqlDateLiteral(DateAdd("d", 1, CDate(dateTo))))
        End If
    End If

    If HasValue(sortValue) Then
        Call AddWherePart(whereText, "[Сорт] = " & SqlTextLiteral(sortValue))
    End If

    If HasValue(fermentationNumber) Then
        If IsNumeric(fermentationNumber) Then
            Call AddWherePart(whereText, "[Номер брожения] = " & CLng(fermentationNumber))
        End If
    End If

    If HasValue(packageType) Then
        Call AddWherePart(whereText, "[Тип тары] = " & SqlTextLiteral(packageType))
    End If

    If HasValue(sourceType) Then
        Call AddWherePart(whereText, "[Тип источника] = " & SqlTextLiteral(sourceType))
    End If

    If Len(whereText) > 0 Then
        BuildFillingWhere = " WHERE " & whereText
    Else
        BuildFillingWhere = ""
    End If

End Function


Private Function BuildFiltrationWhere( _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant _
) As String

    Dim whereText As String

    whereText = ""

    If HasValue(dateFrom) Then
        If IsDate(dateFrom) Then
            Call AddWherePart(whereText, "[Дата фильтрации] >= " & SqlDateLiteral(dateFrom))
        End If
    End If

    If HasValue(dateTo) Then
        If IsDate(dateTo) Then
            Call AddWherePart(whereText, "[Дата фильтрации] < " & SqlDateLiteral(DateAdd("d", 1, CDate(dateTo))))
        End If
    End If

    If HasValue(sortValue) Then
        Call AddWherePart(whereText, "[Сорт] = " & SqlTextLiteral(sortValue))
    End If

    If HasValue(fermentationNumber) Then
        If IsNumeric(fermentationNumber) Then
            Call AddWherePart(whereText, "[Номер брожения] = " & CLng(fermentationNumber))
        End If
    End If

    If Len(whereText) > 0 Then
        BuildFiltrationWhere = " WHERE " & whereText
    Else
        BuildFiltrationWhere = ""
    End If

End Function


' ============================================================
' Заполнение Excel
' ============================================================

Private Sub FillExcelReport( _
    ByVal outputPath As String, _
    ByVal sheetName As String, _
    ByVal reportTitle As String, _
    ByVal sqlText As String, _
    ByVal dateFrom As Variant, _
    ByVal dateTo As Variant, _
    ByVal sortValue As Variant, _
    ByVal fermentationNumber As Variant, _
    ByVal packageType As Variant, _
    ByVal sourceType As Variant _
)

    ' Заполняет лист Excel данными из Recordset.
    '
    ' В шаблоне используется один лист:
    '   Отчет
    '
    ' Параметры фильтров записываются в отдельные ячейки:
    '   B3 - Дата с
    '   D3 - Дата по
    '   F3 - Сорт
    '   H3 - Номер брожения
    '   J3 - Тип тары
    '   L3 - Источник

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object

    Dim rowIndex As Long
    Dim colIndex As Long
    Dim fieldIndex As Long
    Dim lastUsedRow As Long
    Dim lastUsedColumn As Long

    Set db = CurrentDb
    Set rs = db.OpenRecordset(sqlText, dbOpenSnapshot)

    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(outputPath)
    Set xlWs = xlWb.Worksheets(sheetName)

    ' ------------------------------------------------------------
    ' Заголовок и параметры.
    ' ------------------------------------------------------------
    xlWs.Cells(1, 1).Value = reportTitle

    xlWs.Cells(2, 1).Value = "Сформировано:"
    xlWs.Cells(2, 2).Value = Format(Now(), "dd.mm.yyyy hh:nn:ss")

    xlWs.Cells(3, 1).Value = "Дата с:"
    xlWs.Cells(3, 2).Value = FormatFilterDate(dateFrom)

    xlWs.Cells(3, 3).Value = "Дата по:"
    xlWs.Cells(3, 4).Value = FormatFilterDate(dateTo)

    xlWs.Cells(3, 5).Value = "Сорт:"
    xlWs.Cells(3, 6).Value = FormatFilterValue(sortValue)

    xlWs.Cells(3, 7).Value = "Номер брожения:"
    xlWs.Cells(3, 8).Value = FormatFilterValue(fermentationNumber)

    xlWs.Cells(3, 9).Value = "Тип тары:"
    xlWs.Cells(3, 10).Value = FormatFilterValue(packageType)

    xlWs.Cells(3, 11).Value = "Источник:"
    xlWs.Cells(3, 12).Value = FormatFilterValue(sourceType)

    ' ------------------------------------------------------------
    ' Очищаем старую табличную часть.
    ' ------------------------------------------------------------
    lastUsedRow = xlWs.UsedRange.Rows.Count
    lastUsedColumn = xlWs.UsedRange.Columns.Count

    If lastUsedRow < DATA_START_ROW Then
        lastUsedRow = DATA_START_ROW
    End If

    If lastUsedColumn < 1 Then
        lastUsedColumn = 1
    End If

    If xlWs.AutoFilterMode Then
        xlWs.AutoFilterMode = False
    End If

    xlWs.Range( _
        xlWs.Cells(HEADER_ROW, 1), _
        xlWs.Cells(lastUsedRow + 1000, lastUsedColumn + 50) _
    ).ClearContents

    ' ------------------------------------------------------------
    ' Заголовки колонок.
    ' ------------------------------------------------------------
    For fieldIndex = 0 To rs.Fields.Count - 1

        colIndex = fieldIndex + 1
        xlWs.Cells(HEADER_ROW, colIndex).Value = rs.Fields(fieldIndex).Name
        xlWs.Cells(HEADER_ROW, colIndex).Font.Bold = True

    Next fieldIndex

    ' ------------------------------------------------------------
    ' Данные.
    ' ------------------------------------------------------------
    rowIndex = DATA_START_ROW

    Do While Not rs.EOF

        For fieldIndex = 0 To rs.Fields.Count - 1

            colIndex = fieldIndex + 1
            xlWs.Cells(rowIndex, colIndex).Value = Nz(rs.Fields(fieldIndex).Value, "")

        Next fieldIndex

        rowIndex = rowIndex + 1
        rs.MoveNext

    Loop

    ' ------------------------------------------------------------
    ' Оформление.
    ' ------------------------------------------------------------
    If rs.Fields.Count > 0 Then

        xlWs.Range( _
            xlWs.Cells(HEADER_ROW, 1), _
            xlWs.Cells(HEADER_ROW, rs.Fields.Count) _
        ).AutoFilter

        xlWs.Columns.AutoFit

    End If

    xlWb.Save
    xlWb.Close SaveChanges:=True
    xlApp.Quit

ExitPoint:

    On Error Resume Next

    If Not rs Is Nothing Then
        rs.Close
    End If

    Set rs = Nothing
    Set db = Nothing

    Set xlWs = Nothing
    Set xlWb = Nothing

    If Not xlApp Is Nothing Then
        xlApp.Quit
    End If

    Set xlApp = Nothing

    Exit Sub

ErrorHandler:

    Dim errorDescription As String
    errorDescription = Err.Description

    On Error Resume Next

    If Not xlWb Is Nothing Then
        xlWb.Close SaveChanges:=False
    End If

    If Not xlApp Is Nothing Then
        xlApp.Quit
    End If

    Err.Raise vbObjectError + 7100, , _
        "Ошибка заполнения Excel-отчета: " & errorDescription

End Sub


' ============================================================
' Файлы, шаблоны и папки
' ============================================================

Private Sub CopyTemplateToOutput( _
    ByVal templateFileName As String, _
    ByVal outputPath As String _
)

    ' Копирует шаблон в новый файл отчета.

    On Error GoTo ErrorHandler

    Dim templatePath As String

    templatePath = GetTemplatePath(templateFileName)

    If Len(Dir(templatePath)) = 0 Then
        Err.Raise vbObjectError + 7200, , _
            "Не найден файл шаблона:" & vbCrLf & templatePath
    End If

    If Len(Dir(GetReportsFolderPath(), vbDirectory)) = 0 Then
        MkDir GetReportsFolderPath()
    End If

    FileCopy templatePath, outputPath

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function GetTemplatePath(ByVal templateFileName As String) As String

    GetTemplatePath = CurrentProject.Path & "\" & TEMPLATE_FOLDER & "\" & templateFileName

End Function


Private Function GetReportsFolderPath() As String

    GetReportsFolderPath = CurrentProject.Path & "\" & REPORTS_FOLDER

End Function


Private Function BuildReportOutputPath(ByVal outputPrefix As String) As String

    Dim fileName As String

    If Len(Dir(GetReportsFolderPath(), vbDirectory)) = 0 Then
        MkDir GetReportsFolderPath()
    End If

    fileName = outputPrefix & "_" & Format(Now(), "yyyymmdd_hhnnss") & ".xlsx"

    BuildReportOutputPath = GetReportsFolderPath() & "\" & fileName

End Function


' ============================================================
' Сопоставление отчетов с шаблонами и именами файлов
' ============================================================

Private Function GetReportTitle(ByVal reportCode As String) As String

    Select Case reportCode

        Case REPORT_FILLING_DETAIL
            GetReportTitle = "Розлив - детально"

        Case REPORT_FILLING_BY_PACKAGE
            GetReportTitle = "Розлив по таре"

        Case REPORT_FILLING_BY_SORT
            GetReportTitle = "Розлив по сортам"

        Case REPORT_FILLING_BY_BATCH
            GetReportTitle = "Розлив по партиям"

        Case REPORT_FILTRATION_LOSSES
            GetReportTitle = "Потери фильтрации"

        Case REPORT_BATCH_STATE
            GetReportTitle = "Состояние партий"

        Case Else
            GetReportTitle = "Отчет"

    End Select

End Function


Private Function GetReportTemplateFileName(ByVal reportCode As String) As String

    Select Case reportCode

        Case REPORT_FILLING_DETAIL
            GetReportTemplateFileName = "Pivovar_Report_Filling_Detail_Template.xlsx"

        Case REPORT_FILLING_BY_PACKAGE
            GetReportTemplateFileName = "Pivovar_Report_Filling_By_Package_Template.xlsx"

        Case REPORT_FILLING_BY_SORT
            GetReportTemplateFileName = "Pivovar_Report_Filling_By_Sort_Template.xlsx"

        Case REPORT_FILLING_BY_BATCH
            GetReportTemplateFileName = "Pivovar_Report_Filling_By_Batch_Template.xlsx"

        Case REPORT_FILTRATION_LOSSES
            GetReportTemplateFileName = "Pivovar_Report_Filtration_Losses_Template.xlsx"

        Case REPORT_BATCH_STATE
            GetReportTemplateFileName = "Pivovar_Report_Batch_State_Template.xlsx"

        Case Else
            GetReportTemplateFileName = ""

    End Select

End Function


Private Function GetReportOutputPrefix(ByVal reportCode As String) As String

    Select Case reportCode

        Case REPORT_FILLING_DETAIL
            GetReportOutputPrefix = "Розлив_Детально"

        Case REPORT_FILLING_BY_PACKAGE
            GetReportOutputPrefix = "Розлив_ПоТаре"

        Case REPORT_FILLING_BY_SORT
            GetReportOutputPrefix = "Розлив_ПоСортам"

        Case REPORT_FILLING_BY_BATCH
            GetReportOutputPrefix = "Розлив_ПоПартиям"

        Case REPORT_FILTRATION_LOSSES
            GetReportOutputPrefix = "Фильтрация_Потери"

        Case REPORT_BATCH_STATE
            GetReportOutputPrefix = "Партии_Состояние"

        Case Else
            GetReportOutputPrefix = "Отчет"

    End Select

End Function


' ============================================================
' Вспомогательные функции
' ============================================================

Private Sub AddWherePart( _
    ByRef whereText As String, _
    ByVal wherePart As String _
)

    If Len(whereText) > 0 Then
        whereText = whereText & " AND "
    End If

    whereText = whereText & wherePart

End Sub


Private Function HasValue(ByVal sourceValue As Variant) As Boolean

    On Error GoTo ErrorHandler

    If IsNull(sourceValue) Then
        HasValue = False
    ElseIf Len(Trim$(CStr(sourceValue))) = 0 Then
        HasValue = False
    Else
        HasValue = True
    End If

    Exit Function

ErrorHandler:

    HasValue = False

End Function


Private Function SqlTextLiteral(ByVal valueText As Variant) As String

    SqlTextLiteral = "'" & Replace(CStr(valueText), "'", "''") & "'"

End Function


Private Function SqlDateLiteral(ByVal dateValue As Variant) As String

    SqlDateLiteral = "#" & Format$(CDate(dateValue), "yyyy\/mm\/dd") & "#"

End Function


Private Function FormatFilterValue(ByVal sourceValue As Variant) As String

    If HasValue(sourceValue) Then
        FormatFilterValue = CStr(sourceValue)
    Else
        FormatFilterValue = "Все"
    End If

End Function


Private Function FormatFilterDate(ByVal sourceValue As Variant) As String

    If HasValue(sourceValue) Then

        If IsDate(sourceValue) Then
            FormatFilterDate = Format(CDate(sourceValue), "dd.mm.yyyy")
        Else
            FormatFilterDate = CStr(sourceValue)
        End If

    Else

        FormatFilterDate = "Все"

    End If

End Function

```

### fReportsParameters_Fixed_Full_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fОтчеты_Параметры — параметры отчетов и открытие папки Reports.  
**SHA256:** `fba7eb39d6cb0ba4d68e4819aea8d2699256b106a09f44594a91024b9466c008`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fОтчеты_Параметры
'
' Назначение:
'   Панель параметров выгрузки отчетов в Excel.
'
' Использование:
'   Форма встраивается как подчиненная форма на вкладку "Отчеты"
'   формы fГлавная.
'
' Форма несвязанная.
' Кнопки закрытия нет, потому что форма встроенная.
'
' Фильтры:
'   txtDateFrom
'   txtDateTo
'   cboSort
'   cboFermentationNumber
'   cboPackageType
'   cboSourceType
'
' Кнопки:
'   cmdExportFillingDetail
'   cmdExportFillingByPackage
'   cmdExportFillingBySort
'   cmdExportFillingByBatch
'   cmdExportFiltrationLosses
'   cmdExportBatchState
'   cmdClearFilters
'
' Важно:
'   В стандартном модуле должен быть добавлен mExcelReports.
' ============================================================


Private Sub Form_Load()

    On Error GoTo ErrorHandler

    Call WireEvents
    Call CheckRequiredControls
    Call InitializeFilterControls

    Exit Sub

ErrorHandler:

    MsgBox "Ошибка при загрузке формы fОтчеты_Параметры:" & vbCrLf & _
           Err.Description, _
           vbCritical, _
           "Параметры отчетов"

End Sub


Private Sub cmdExportFillingDetail_Click()

    ' Розлив - детально.
    Call ExportWithCurrentFilters(REPORT_FILLING_DETAIL)

End Sub


Private Sub cmdExportFillingByPackage_Click()

    ' Розлив по таре.
    Call ExportWithCurrentFilters(REPORT_FILLING_BY_PACKAGE)

End Sub


Private Sub cmdExportFillingBySort_Click()

    ' Розлив по сортам.
    Call ExportWithCurrentFilters(REPORT_FILLING_BY_SORT)

End Sub


Private Sub cmdExportFillingByBatch_Click()

    ' Розлив по партиям.
    Call ExportWithCurrentFilters(REPORT_FILLING_BY_BATCH)

End Sub


Private Sub cmdExportFiltrationLosses_Click()

    ' Потери фильтрации.
    Call ExportWithCurrentFilters(REPORT_FILTRATION_LOSSES)

End Sub


Private Sub cmdExportBatchState_Click()

    ' Состояние партий.
    Call ExportWithCurrentFilters(REPORT_BATCH_STATE)

End Sub


Private Sub cmdClearFilters_Click()

    ' Сброс фильтров отчетов.
    Call ClearFilterControls

End Sub


Private Sub ExportWithCurrentFilters(ByVal reportCode As String)

    ' Запускает выгрузку выбранного отчета с текущими фильтрами формы.

    On Error GoTo ErrorHandler

    If ValidateFilters() = False Then
        Exit Sub
    End If

    Call ExportPivovarReportToExcel( _
        reportCode:=reportCode, _
        dateFrom:=GetControlValue("txtDateFrom"), _
        dateTo:=GetControlValue("txtDateTo"), _
        sortValue:=GetControlValue("cboSort"), _
        fermentationNumber:=GetControlValue("cboFermentationNumber"), _
        packageType:=GetControlValue("cboPackageType"), _
        sourceType:=GetControlValue("cboSourceType") _
    )

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить выгрузку отчета." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbCritical, _
           "Выгрузка отчета"

End Sub


Private Sub InitializeFilterControls()

    ' Настраивает списки фильтров.
    '
    ' Для сортов и номеров брожения используем qПартии_Движение,
    ' потому что там есть общий набор партий.
    '
    ' Для типа тары и источника используем qРозлив_Свод,
    ' потому что эти признаки относятся к розливу.
    '
    ' Если qРозлив_Свод пустой, списки типа тары и источника тоже будут пустыми.
    ' Это нормальное поведение.

    On Error GoTo ErrorHandler

    If ControlExists("cboSort") Then

        Me.Controls("cboSort").RowSourceType = "Table/Query"
        Me.Controls("cboSort").RowSource = _
            "SELECT DISTINCT [Сорт] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Сорт] Is Not Null " & _
            "ORDER BY [Сорт];"

        Me.Controls("cboSort").ColumnCount = 1
        Me.Controls("cboSort").BoundColumn = 1
        Me.Controls("cboSort").LimitToList = False
        Me.Controls("cboSort").Requery

    End If

    If ControlExists("cboFermentationNumber") Then

        Me.Controls("cboFermentationNumber").RowSourceType = "Table/Query"
        Me.Controls("cboFermentationNumber").RowSource = _
            "SELECT DISTINCT [Номер брожения] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Номер брожения] Is Not Null " & _
            "ORDER BY [Номер брожения] DESC;"

        Me.Controls("cboFermentationNumber").ColumnCount = 1
        Me.Controls("cboFermentationNumber").BoundColumn = 1
        Me.Controls("cboFermentationNumber").LimitToList = False
        Me.Controls("cboFermentationNumber").Requery

    End If

    If ControlExists("cboPackageType") Then

        Me.Controls("cboPackageType").RowSourceType = "Table/Query"
        Me.Controls("cboPackageType").RowSource = _
            "SELECT DISTINCT [Тип тары] " & _
            "FROM [qРозлив_Свод] " & _
            "WHERE [Тип тары] Is Not Null " & _
            "ORDER BY [Тип тары];"

        Me.Controls("cboPackageType").ColumnCount = 1
        Me.Controls("cboPackageType").BoundColumn = 1
        Me.Controls("cboPackageType").LimitToList = False
        Me.Controls("cboPackageType").Requery

    End If

    If ControlExists("cboSourceType") Then

        Me.Controls("cboSourceType").RowSourceType = "Table/Query"
        Me.Controls("cboSourceType").RowSource = _
            "SELECT DISTINCT [Тип источника] " & _
            "FROM [qРозлив_Свод] " & _
            "WHERE [Тип источника] Is Not Null " & _
            "ORDER BY [Тип источника];"

        Me.Controls("cboSourceType").ColumnCount = 1
        Me.Controls("cboSourceType").BoundColumn = 1
        Me.Controls("cboSourceType").LimitToList = False
        Me.Controls("cboSourceType").Requery

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить списки фильтров отчетов." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Параметры отчетов"

End Sub


Private Function ValidateFilters() As Boolean

    ' Проверяет корректность дат.

    ValidateFilters = False

    If HasControlValue("txtDateFrom") Then

        If IsDate(Me.Controls("txtDateFrom").Value) = False Then

            MsgBox "Некорректная дата в поле 'Дата с'.", _
                   vbExclamation, _
                   "Параметры отчетов"

            Me.Controls("txtDateFrom").SetFocus
            Exit Function

        End If

    End If

    If HasControlValue("txtDateTo") Then

        If IsDate(Me.Controls("txtDateTo").Value) = False Then

            MsgBox "Некорректная дата в поле 'Дата по'.", _
                   vbExclamation, _
                   "Параметры отчетов"

            Me.Controls("txtDateTo").SetFocus
            Exit Function

        End If

    End If

    If HasControlValue("txtDateFrom") And HasControlValue("txtDateTo") Then

        If CDate(Me.Controls("txtDateFrom").Value) > CDate(Me.Controls("txtDateTo").Value) Then

            MsgBox "Дата с не может быть позже даты по.", _
                   vbExclamation, _
                   "Параметры отчетов"

            Me.Controls("txtDateFrom").SetFocus
            Exit Function

        End If

    End If

    ValidateFilters = True

End Function


Private Sub ClearFilterControls()

    ' Очищает все фильтры на форме.

    On Error Resume Next

    If ControlExists("txtDateFrom") Then
        Me.Controls("txtDateFrom").Value = Null
    End If

    If ControlExists("txtDateTo") Then
        Me.Controls("txtDateTo").Value = Null
    End If

    If ControlExists("cboSort") Then
        Me.Controls("cboSort").Value = Null
    End If

    If ControlExists("cboFermentationNumber") Then
        Me.Controls("cboFermentationNumber").Value = Null
    End If

    If ControlExists("cboPackageType") Then
        Me.Controls("cboPackageType").Value = Null
    End If

    If ControlExists("cboSourceType") Then
        Me.Controls("cboSourceType").Value = Null
    End If

End Sub


Private Sub WireEvents()

    ' Принудительно привязывает события кнопок.
    '
    ' Используем Me.Controls("ИмяЭлемента"), а не Me.cmd...
    ' Так форма не падает при компиляции, если элемент пока назван иначе.
    '
    ' Если элемента нет, процедура просто пропустит его.
    ' Отдельно CheckRequiredControls покажет список отсутствующих элементов.

    On Error Resume Next

    Call SetButtonClickEvent("cmdExportFillingDetail")
    Call SetButtonClickEvent("cmdExportFillingByPackage")
    Call SetButtonClickEvent("cmdExportFillingBySort")
    Call SetButtonClickEvent("cmdExportFillingByBatch")
    Call SetButtonClickEvent("cmdExportFiltrationLosses")
    Call SetButtonClickEvent("cmdExportBatchState")
    Call SetButtonClickEvent("cmdClearFilters")

End Sub


Private Sub SetButtonClickEvent(ByVal controlName As String)

    ' Привязывает событие OnClick к кнопке, если элемент найден.

    On Error Resume Next

    If ControlExists(controlName) Then
        Me.Controls(controlName).OnClick = "[Event Procedure]"
    End If

End Sub


Private Sub CheckRequiredControls()

    ' Проверяет наличие элементов, которые ожидает код.
    '
    ' Кнопка закрытия намеренно не проверяется,
    ' потому что fОтчеты_Параметры встроена в fГлавная.

    Dim missingControls As String

    missingControls = ""

    If ControlExists("txtDateFrom") = False Then
        missingControls = missingControls & "txtDateFrom" & vbCrLf
    End If

    If ControlExists("txtDateTo") = False Then
        missingControls = missingControls & "txtDateTo" & vbCrLf
    End If

    If ControlExists("cboSort") = False Then
        missingControls = missingControls & "cboSort" & vbCrLf
    End If

    If ControlExists("cboFermentationNumber") = False Then
        missingControls = missingControls & "cboFermentationNumber" & vbCrLf
    End If

    If ControlExists("cboPackageType") = False Then
        missingControls = missingControls & "cboPackageType" & vbCrLf
    End If

    If ControlExists("cboSourceType") = False Then
        missingControls = missingControls & "cboSourceType" & vbCrLf
    End If

    If ControlExists("cmdExportFillingDetail") = False Then
        missingControls = missingControls & "cmdExportFillingDetail" & vbCrLf
    End If

    If ControlExists("cmdExportFillingByPackage") = False Then
        missingControls = missingControls & "cmdExportFillingByPackage" & vbCrLf
    End If

    If ControlExists("cmdExportFillingBySort") = False Then
        missingControls = missingControls & "cmdExportFillingBySort" & vbCrLf
    End If

    If ControlExists("cmdExportFillingByBatch") = False Then
        missingControls = missingControls & "cmdExportFillingByBatch" & vbCrLf
    End If

    If ControlExists("cmdExportFiltrationLosses") = False Then
        missingControls = missingControls & "cmdExportFiltrationLosses" & vbCrLf
    End If

    If ControlExists("cmdExportBatchState") = False Then
        missingControls = missingControls & "cmdExportBatchState" & vbCrLf
    End If

    If ControlExists("cmdClearFilters") = False Then
        missingControls = missingControls & "cmdClearFilters" & vbCrLf
    End If

    If Len(missingControls) > 0 Then

        MsgBox "На форме fОтчеты_Параметры не найдены элементы:" & vbCrLf & vbCrLf & _
               missingControls & vbCrLf & _
               "Проверь свойство 'Имя' у элементов управления.", _
               vbExclamation, _
               "Проверка элементов формы"

    End If

End Sub


Private Function GetControlValue(ByVal controlName As String) As Variant

    ' Безопасно возвращает значение элемента фильтра.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        GetControlValue = Null
        Exit Function
    End If

    GetControlValue = Me.Controls(controlName).Value
    Exit Function

ErrorHandler:

    GetControlValue = Null

End Function


Private Function HasControlValue(ByVal controlName As String) As Boolean

    ' Проверяет, заполнено ли поле фильтра.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        HasControlValue = False
        Exit Function
    End If

    If IsNull(Me.Controls(controlName).Value) Then
        HasControlValue = False
    ElseIf Len(Trim$(CStr(Me.Controls(controlName).Value))) = 0 Then
        HasControlValue = False
    Else
        HasControlValue = True
    End If

    Exit Function

ErrorHandler:

    HasControlValue = False

End Function


Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.
    '
    ' Используем перебор с Trim, чтобы случайный пробел
    ' в имени элемента не ломал проверку.
    '
    ' Важно:
    '   Эта функция не обращается к Me.cmd..., поэтому не вызывает
    '   ошибку компиляции при неправильном имени элемента.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    For Each ctl In Me.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExists = True
            Exit Function
        End If

    Next ctl

    ControlExists = False

    Exit Function

ErrorHandler:

    ControlExists = False

End Function

```

### fForfas_Panel_Code_Only2Forfas.bas

**Группа:** `final_preferred`  
**Назначение:** fФорфас_Панель — панель 2 форфасов.  
**SHA256:** `1558bbc216b9b324dd80f5a1c73b27c412380c73e379583a0f621cb5666e1caa`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fФорфас_Панель
'
' Назначение:
'   Панель текущего состояния форфасов.
'
' Логика:
'   - форма несвязанная;
'   - данные читаются из qФорфас_ТекущееСостояние;
'   - каждая карточка форфаса заполняется через VBA;
'   - дрожжи на этой форме не отображаются, это логика ЦКТ;
'   - кнопки "Журнал" и "Операции" подготовлены под следующие формы.
'
' Важно:
'   Карточка — это не отдельный объект Access,
'   а группа обычных элементов управления на форме.
'
' Поддержка:
'   Код рассчитан на Форфас1...Форфас2.
'   В текущей конфигурации проекта форфасов всего 2.
' ============================================================


Private Const QUERY_FORFAS_STATE As String = "qФорфас_ТекущееСостояние"
Private Const VESSEL_TYPE_FORFAS As String = "Форфас"

Private Const FORM_FORFAS_JOURNAL As String = "fФорфас_Журнал"
Private Const FORM_FORFAS_OPERATION As String = "fОперацияФорфас"

Private Const FIRST_FORFAS_NUMBER As Long = 1
Private Const LAST_FORFAS_NUMBER As Long = 2


Private Sub Form_Load()

    ' Большая рабочая форма открывается на весь рабочий экран Access.
    DoCmd.Maximize

    ' При первом открытии формы заполняем карточки форфасов.
    Call RefreshForfasPanel

End Sub


Private Sub Form_Activate()

    ' При возврате на форму обновляем карточки.
    '
    ' Это пригодится после будущих форм операций и журналов.

    Call RefreshForfasPanel

End Sub


Private Sub cmdRefreshPanel_Click()

    ' Ручное обновление панели форфасов.
    Call RefreshForfasPanel

End Sub


' ============================================================
' Кнопки журнала по карточкам форфасов
' ============================================================

Private Sub cmdForfas1Journal_Click()
    Call OpenForfasJournal(1)
End Sub

Private Sub cmdForfas2Journal_Click()
    Call OpenForfasJournal(2)
End Sub






' ============================================================
' Кнопки операций по карточкам форфасов
' ============================================================

Private Sub cmdForfas1Operation_Click()
    Call OpenForfasOperation(1)
End Sub

Private Sub cmdForfas2Operation_Click()
    Call OpenForfasOperation(2)
End Sub






' ============================================================
' Основное обновление панели
' ============================================================

Private Sub RefreshForfasPanel()

    ' Обновляет карточки форфасов по запросу qФорфас_ТекущееСостояние.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim forfasNumber As Long

    ' Сначала очищаем все карточки.
    For forfasNumber = FIRST_FORFAS_NUMBER To LAST_FORFAS_NUMBER
        Call ClearForfasCard(forfasNumber)
    Next forfasNumber

    Set db = CurrentDb
    Set rs = db.OpenRecordset(QUERY_FORFAS_STATE, dbOpenSnapshot)

    Do While Not rs.EOF

        forfasNumber = Nz(rs.Fields("Номер емкости").Value, 0)

        If forfasNumber >= FIRST_FORFAS_NUMBER And forfasNumber <= LAST_FORFAS_NUMBER Then
            Call LoadForfasCard(forfasNumber, rs)
        End If

        rs.MoveNext

    Loop

ExitPoint:

    On Error Resume Next

    If Not rs Is Nothing Then
        rs.Close
    End If

    Set rs = Nothing
    Set db = Nothing

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось обновить панель форфасов." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Панель форфасов"

    Resume ExitPoint

End Sub


Private Sub LoadForfasCard( _
    ByVal forfasNumber As Long, _
    ByVal rs As DAO.Recordset _
)

    ' Заполняет одну карточку форфаса данными из текущей строки Recordset.

    On Error GoTo ErrorHandler

    Dim vesselName As String
    Dim statusText As String
    Dim sortName As String
    Dim volumeL As Double
    Dim freeVolumeL As Double
    Dim fermentationNumber As Variant
    Dim brewNumbers As String
    Dim firstFillDate As Variant
    Dim lastBrewDate As Variant
    Dim daysInForfas As Variant
    Dim isBusy As Boolean

    vesselName = Nz(rs.Fields("Название").Value, "Форфас" & forfasNumber)
    statusText = Nz(rs.Fields("Статус").Value, "Свободен")
    sortName = Nz(rs.Fields("Сорт").Value, "")

    volumeL = Nz(rs.Fields("Объем(л)").Value, 0)
    freeVolumeL = Nz(rs.Fields("Свободно(л)").Value, 0)

    fermentationNumber = rs.Fields("Номер брожения").Value
    brewNumbers = Nz(rs.Fields("Номера варок").Value, "")

    firstFillDate = rs.Fields("Дата первого наполнения").Value
    lastBrewDate = rs.Fields("Дата последней варки").Value
    daysInForfas = rs.Fields("Дней в форфасе").Value

    isBusy = Nz(rs.Fields("Занят").Value, False)

    ' Если объем больше 0, считаем емкость занятой даже при ошибочном флаге.
    If volumeL > 0 Then
        isBusy = True
    End If

    If isBusy = False Then
        statusText = "Свободен"
        sortName = ""
        brewNumbers = ""
    End If

    Call SetControlCaption("lblForfas" & forfasNumber & "Title", vesselName)

    Call SetControlValue("txtForfas" & forfasNumber & "Status", statusText)
    Call SetControlValue("txtForfas" & forfasNumber & "Sort", NullIfEmpty(sortName))
    Call SetControlValue("txtForfas" & forfasNumber & "VolumeL", FormatVolumeText(volumeL) & " л")
    Call SetControlValue("txtForfas" & forfasNumber & "FreeVolumeL", FormatVolumeText(freeVolumeL) & " л")

    If IsNull(fermentationNumber) Or Nz(fermentationNumber, 0) = 0 Then
        Call SetControlValue("txtForfas" & forfasNumber & "FermentationNumber", Null)
    Else
        Call SetControlValue("txtForfas" & forfasNumber & "FermentationNumber", fermentationNumber)
    End If

    Call SetControlValue("txtForfas" & forfasNumber & "BrewNumbers", NullIfEmpty(brewNumbers))

    If IsNull(firstFillDate) Then
        Call SetControlValue("txtForfas" & forfasNumber & "FirstFillDate", Null)
    Else
        Call SetControlValue("txtForfas" & forfasNumber & "FirstFillDate", Format(CDate(firstFillDate), "dd.mm.yyyy"))
    End If

    If IsNull(lastBrewDate) Then
        Call SetControlValue("txtForfas" & forfasNumber & "LastBrewDate", Null)
    Else
        Call SetControlValue("txtForfas" & forfasNumber & "LastBrewDate", Format(CDate(lastBrewDate), "dd.mm.yyyy"))
    End If

    If IsNull(daysInForfas) Then
        Call SetControlValue("txtForfas" & forfasNumber & "DaysInForfas", Null)
    Else
        Call SetControlValue("txtForfas" & forfasNumber & "DaysInForfas", CStr(daysInForfas) & " дн")
    End If

    Call SetForfasCardColor(forfasNumber, isBusy)

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось заполнить карточку Форфас" & forfasNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Панель форфасов"

End Sub


Private Sub ClearForfasCard(ByVal forfasNumber As Long)

    ' Очищает карточку форфаса.
    '
    ' Используется перед полной перезагрузкой панели.

    On Error Resume Next

    Call SetControlCaption("lblForfas" & forfasNumber & "Title", "Форфас" & forfasNumber)

    Call SetControlValue("txtForfas" & forfasNumber & "Status", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "Sort", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "VolumeL", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "FreeVolumeL", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "FermentationNumber", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "BrewNumbers", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "FirstFillDate", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "LastBrewDate", Null)
    Call SetControlValue("txtForfas" & forfasNumber & "DaysInForfas", Null)

    Call SetForfasCardColor(forfasNumber, False)

End Sub


' ============================================================
' Журнал форфаса
' ============================================================

Private Sub OpenForfasJournal(ByVal forfasNumber As Long)

    ' Открывает журнал движений по выбранному форфасу.
    '
    ' Пока форма fФорфас_Журнал еще не создана,
    ' показываем информационное сообщение.

    On Error GoTo ErrorHandler

    If FormExists(FORM_FORFAS_JOURNAL) = False Then

        MsgBox "Форма журнала форфаса еще не создана." & vbCrLf & vbCrLf & _
               "Следующий этап: создать форму " & FORM_FORFAS_JOURNAL & ".", _
               vbInformation, _
               "Журнал форфаса"

        Exit Sub

    End If

    DoCmd.OpenForm _
        FormName:=FORM_FORFAS_JOURNAL, _
        View:=acNormal, _
        WindowMode:=acWindowNormal, _
        OpenArgs:=CStr(forfasNumber)

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть журнал Форфас" & forfasNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Журнал форфаса"

End Sub


' ============================================================
' Операции форфаса
' ============================================================

Private Sub OpenForfasOperation(ByVal forfasNumber As Long)

    ' Открывает форму операций по выбранному форфасу.
    '
    ' По принятой логике для форфаса будут операции:
    '   - Форфас - Розлив;
    '   - Корректировка Форфаса.
    '
    ' Пока форма fОперацияФорфас еще не создана,
    ' показываем информационное сообщение.

    On Error GoTo ErrorHandler

    If FormExists(FORM_FORFAS_OPERATION) = False Then

        MsgBox "Форма операций форфаса еще не создана." & vbCrLf & vbCrLf & _
               "Следующий этап: создать форму " & FORM_FORFAS_OPERATION & ".", _
               vbInformation, _
               "Операции форфаса"

        Exit Sub

    End If

    DoCmd.OpenForm _
        FormName:=FORM_FORFAS_OPERATION, _
        View:=acNormal, _
        WindowMode:=acWindowNormal, _
        OpenArgs:=CStr(forfasNumber)

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть форму операций по Форфас" & forfasNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции форфаса"

End Sub


' ============================================================
' Цветовая маркировка карточек
' ============================================================

Private Sub SetForfasCardColor( _
    ByVal forfasNumber As Long, _
    ByVal isBusy As Boolean _
)

    ' Цветовая маркировка карточки:
    '
    '   Свободен:
    '       основа карточки — светло-серая.
    '
    '   Занят:
    '       основа карточки — светло-желтая.

    On Error Resume Next

    Dim cardColor As Long

    If isBusy = True Then

        ' Занятая емкость.
        cardColor = RGB(255, 242, 204)

    Else

        ' Свободная емкость.
        cardColor = RGB(242, 242, 242)

    End If

    ' ------------------------------------------------------------
    ' Фон карточки и заголовок
    ' ------------------------------------------------------------
    Call SetControlBackColor("boxForfas" & forfasNumber, cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "Title", cardColor)

    ' ------------------------------------------------------------
    ' Подписи строк
    ' ------------------------------------------------------------
    Call SetControlBackColor("lblForfas" & forfasNumber & "StatusCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "SortCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "VolumeCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "FreeVolumeCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "FermentationCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "BrewNumbersCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "FirstFillDateCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "LastBrewDateCaption", cardColor)
    Call SetControlBackColor("lblForfas" & forfasNumber & "DaysInForfasCaption", cardColor)

    ' ------------------------------------------------------------
    ' Поля значений
    ' ------------------------------------------------------------
    Call SetControlBackColor("txtForfas" & forfasNumber & "Status", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "Sort", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "VolumeL", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "FreeVolumeL", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "FermentationNumber", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "BrewNumbers", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "FirstFillDate", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "LastBrewDate", cardColor)
    Call SetControlBackColor("txtForfas" & forfasNumber & "DaysInForfas", cardColor)

End Sub


' ============================================================
' Безопасная работа с элементами управления
' ============================================================

Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    Set ctl = Me.Controls(controlName)

    ControlExists = True

    Exit Function

ErrorHandler:

    ControlExists = False

End Function


Private Sub SetControlValue( _
    ByVal controlName As String, _
    ByVal controlValue As Variant _
)

    ' Безопасно записывает значение в элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Value = controlValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlValue для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlCaption( _
    ByVal controlName As String, _
    ByVal captionText As String _
)

    ' Безопасно меняет Caption у надписи или кнопки.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Caption = captionText

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlCaption для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlBackColor( _
    ByVal controlName As String, _
    ByVal colorValue As Long _
)

    ' Безопасно меняет цвет фона элемента управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).BackStyle = 1
    Me.Controls(controlName).BackColor = colorValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlBackColor для " & controlName & ": " & Err.Description

End Sub


Private Function NullIfEmpty(ByVal sourceText As String) As Variant

    ' Возвращает Null, если строка пустая.
    ' Иначе возвращает саму строку.

    If Trim(Nz(sourceText, "")) = "" Then
        NullIfEmpty = Null
    Else
        NullIfEmpty = sourceText
    End If

End Function


Private Function FormatVolumeText(ByVal volumeValue As Double) As String

    ' Форматирует объем без лишней запятой в конце.
    '
    ' Примеры:
    '   100     -> "100"
    '   100,5   -> "100,5"
    '   100,125 -> "100,125"

    Dim resultText As String
    Dim decimalSeparator As String

    decimalSeparator = Mid(CStr(1.1), 2, 1)

    resultText = Format(volumeValue, "0.###")

    ' Убираем лишний десятичный разделитель в конце:
    '   "100," -> "100"
    '   "100." -> "100"
    If Len(resultText) > 0 Then

        If Right(resultText, 1) = decimalSeparator _
           Or Right(resultText, 1) = "." _
           Or Right(resultText, 1) = "," Then

            resultText = Left(resultText, Len(resultText) - 1)

        End If

    End If

    FormatVolumeText = resultText

End Function


Private Function FormExists(ByVal formName As String) As Boolean

    ' Проверяет, существует ли форма в базе Access.

    On Error GoTo ErrorHandler

    Dim obj As AccessObject

    For Each obj In CurrentProject.AllForms

        If StrComp(obj.Name, formName, vbTextCompare) = 0 Then
            FormExists = True
            Exit Function
        End If

    Next obj

    FormExists = False

    Exit Function

ErrorHandler:

    FormExists = False

End Function

```

### fCCT_Panel_Code_Full_NormalWindow.bas

**Группа:** `final_preferred`  
**Назначение:** fЦКТ_Панель — панель ЦКТ.  
**SHA256:** `ea44d6dacd07d7523733706765f6b81e7605880c745f3ac92703415261573ce2`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fЦКТ_Панель
'
' Назначение:
'   Панель текущего состояния ЦКТ.
'
' Логика:
'   - форма несвязанная;
'   - данные читаются из qЦКТ_ТекущееСостояние;
'   - каждая карточка ЦКТ заполняется через VBA;
'   - снятие дрожжей управляется checkbox-ами;
'   - подпись строки дрожжей меняется автоматически:
'       "Дрожжи" / "Дрожжи сняты" / "Дрожжи не сняты";
'   - кнопки "Журнал" и "Операции" открывают большие формы в обычном окне Access.
'
' Важно:
'   Карточка — это не отдельный объект Access,
'   а группа обычных элементов управления на форме.
' ============================================================


Private Const QUERY_CCT_STATE As String = "qЦКТ_ТекущееСостояние"
Private Const VESSEL_TYPE_CCT As String = "ЦКТ"

Private Const FORM_CCT_JOURNAL As String = "fЦКТ_Журнал"
Private Const FORM_CCT_OPERATION As String = "fОперацияЦКТ"

' Служебный флаг.
' Нужен, чтобы при программном заполнении checkbox-ов
' не срабатывал вопрос пользователю.
Private mInternalPanelUpdate As Boolean


Private Sub Form_Load()

    ' При первом открытии формы заполняем карточки ЦКТ.
    Call RefreshCctPanel

End Sub


Private Sub Form_Activate()

    ' При возврате на форму обновляем карточки.
    '
    ' Это пригодится после будущих форм операций, журналов,
    ' розлива и корректировок.

    Call RefreshCctPanel

End Sub


Private Sub cmdRefreshPanel_Click()

    ' Ручное обновление панели ЦКТ.
    Call RefreshCctPanel

End Sub


' ============================================================
' Checkbox "Дрожжи сняты" по карточкам ЦКТ
' ============================================================

Private Sub chkCCT1YeastRemoved_AfterUpdate()
    Call ChangeYeastRemovedByCheckBox(1)
End Sub

Private Sub chkCCT2YeastRemoved_AfterUpdate()
    Call ChangeYeastRemovedByCheckBox(2)
End Sub

Private Sub chkCCT3YeastRemoved_AfterUpdate()
    Call ChangeYeastRemovedByCheckBox(3)
End Sub

Private Sub chkCCT4YeastRemoved_AfterUpdate()
    Call ChangeYeastRemovedByCheckBox(4)
End Sub

Private Sub chkCCT5YeastRemoved_AfterUpdate()
    Call ChangeYeastRemovedByCheckBox(5)
End Sub

Private Sub chkCCT6YeastRemoved_AfterUpdate()
    Call ChangeYeastRemovedByCheckBox(6)
End Sub


' ============================================================
' Кнопки журнала по карточкам ЦКТ
' ============================================================

Private Sub cmdCCT1Journal_Click()
    Call OpenCctJournal(1)
End Sub

Private Sub cmdCCT2Journal_Click()
    Call OpenCctJournal(2)
End Sub

Private Sub cmdCCT3Journal_Click()
    Call OpenCctJournal(3)
End Sub

Private Sub cmdCCT4Journal_Click()
    Call OpenCctJournal(4)
End Sub

Private Sub cmdCCT5Journal_Click()
    Call OpenCctJournal(5)
End Sub

Private Sub cmdCCT6Journal_Click()
    Call OpenCctJournal(6)
End Sub


' ============================================================
' Кнопки операций по карточкам ЦКТ
' ============================================================

Private Sub cmdCCT1Operation_Click()
    Call OpenCctOperation(1)
End Sub

Private Sub cmdCCT2Operation_Click()
    Call OpenCctOperation(2)
End Sub

Private Sub cmdCCT3Operation_Click()
    Call OpenCctOperation(3)
End Sub

Private Sub cmdCCT4Operation_Click()
    Call OpenCctOperation(4)
End Sub

Private Sub cmdCCT5Operation_Click()
    Call OpenCctOperation(5)
End Sub

Private Sub cmdCCT6Operation_Click()
    Call OpenCctOperation(6)
End Sub


' ============================================================
' Основное обновление панели
' ============================================================

Private Sub RefreshCctPanel()

    ' Обновляет все 6 карточек ЦКТ по запросу qЦКТ_ТекущееСостояние.

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim cctNumber As Long

    ' Включаем служебный флаг на все время обновления формы.
    ' Это защищает от случайного запуска событий checkbox-ов
    ' при программной подстановке значений.
    mInternalPanelUpdate = True

    ' Сначала очищаем все карточки.
    For cctNumber = 1 To 6
        Call ClearCctCard(cctNumber)
    Next cctNumber

    Set db = CurrentDb
    Set rs = db.OpenRecordset(QUERY_CCT_STATE, dbOpenSnapshot)

    Do While Not rs.EOF

        cctNumber = Nz(rs.Fields("Номер емкости").Value, 0)

        If cctNumber >= 1 And cctNumber <= 6 Then
            Call LoadCctCard(cctNumber, rs)
        End If

        rs.MoveNext

    Loop

ExitPoint:

    On Error Resume Next

    If Not rs Is Nothing Then
        rs.Close
    End If

    Set rs = Nothing
    Set db = Nothing

    mInternalPanelUpdate = False

    Exit Sub

ErrorHandler:

    mInternalPanelUpdate = False

    MsgBox "Не удалось обновить панель ЦКТ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Панель ЦКТ"

    Resume ExitPoint

End Sub


Private Sub LoadCctCard( _
    ByVal cctNumber As Long, _
    ByVal rs As DAO.Recordset _
)

    ' Заполняет одну карточку ЦКТ данными из текущей строки Recordset.

    On Error GoTo ErrorHandler

    Dim vesselName As String
    Dim statusText As String
    Dim sortName As String
    Dim volumeL As Double
    Dim freeVolumeL As Double
    Dim fermentationNumber As Variant
    Dim brewNumbers As String
    Dim lastBrewDate As Variant
    Dim beerAgeDays As Variant
    Dim yeastRemoved As Boolean
    Dim yeastRemovedDate As Variant
    Dim isBusy As Boolean

    vesselName = Nz(rs.Fields("Название").Value, "ЦКТ" & cctNumber)
    statusText = Nz(rs.Fields("Статус").Value, "Свободен")
    sortName = Nz(rs.Fields("Сорт").Value, "")

    volumeL = Nz(rs.Fields("Объем(л)").Value, 0)
    freeVolumeL = Nz(rs.Fields("Свободно(л)").Value, 0)

    fermentationNumber = rs.Fields("Номер брожения").Value
    brewNumbers = Nz(rs.Fields("Номера варок").Value, "")

    lastBrewDate = rs.Fields("Дата последней варки").Value
    beerAgeDays = rs.Fields("Возраст пива(дн)").Value

    yeastRemoved = Nz(rs.Fields("Снятие дрожжей").Value, False)
    yeastRemovedDate = rs.Fields("Дата снятия дрожжей").Value

    isBusy = Nz(rs.Fields("Занят").Value, False)

    ' Если объем больше 0, считаем емкость занятой даже при ошибочном флаге.
    If volumeL > 0 Then
        isBusy = True
    End If

    If isBusy = False Then
        statusText = "Свободен"
        sortName = ""
        brewNumbers = ""
        yeastRemoved = False
    End If

    Call SetControlCaption("lblCCT" & cctNumber & "Title", vesselName)

    Call SetControlValue("txtCCT" & cctNumber & "Status", statusText)
    Call SetControlValue("txtCCT" & cctNumber & "Sort", NullIfEmpty(sortName))
    Call SetControlValue("txtCCT" & cctNumber & "VolumeL", Format(volumeL, "0") & " л")
    Call SetControlValue("txtCCT" & cctNumber & "FreeVolumeL", Format(freeVolumeL, "0") & " л")

    If IsNull(fermentationNumber) Or Nz(fermentationNumber, 0) = 0 Then
        Call SetControlValue("txtCCT" & cctNumber & "FermentationNumber", Null)
    Else
        Call SetControlValue("txtCCT" & cctNumber & "FermentationNumber", fermentationNumber)
    End If

    Call SetControlValue("txtCCT" & cctNumber & "BrewNumbers", NullIfEmpty(brewNumbers))

    If IsNull(lastBrewDate) Then
        Call SetControlValue("txtCCT" & cctNumber & "LastBrewDate", Null)
    Else
        Call SetControlValue("txtCCT" & cctNumber & "LastBrewDate", Format(CDate(lastBrewDate), "dd.mm.yyyy"))
    End If

    If IsNull(beerAgeDays) Then
        Call SetControlValue("txtCCT" & cctNumber & "BeerAgeDays", Null)
    Else
        Call SetControlValue("txtCCT" & cctNumber & "BeerAgeDays", CStr(beerAgeDays) & " дн")
    End If

    If IsNull(yeastRemovedDate) Then
        Call SetControlValue("txtCCT" & cctNumber & "YeastDate", Null)
    Else
        Call SetControlValue("txtCCT" & cctNumber & "YeastDate", Format(CDate(yeastRemovedDate), "dd.mm.yyyy"))
    End If

    Call SetControlValue("chkCCT" & cctNumber & "YeastRemoved", yeastRemoved)

    If isBusy = True Then
        Call SetControlEnabled("chkCCT" & cctNumber & "YeastRemoved", True)
    Else
        Call SetControlEnabled("chkCCT" & cctNumber & "YeastRemoved", False)
    End If

    Call SetCctCardColor(cctNumber, isBusy, yeastRemoved)

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось заполнить карточку ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Панель ЦКТ"

End Sub


Private Sub ClearCctCard(ByVal cctNumber As Long)

    ' Очищает карточку ЦКТ.
    '
    ' Используется перед полной перезагрузкой панели.

    On Error Resume Next

    Call SetControlCaption("lblCCT" & cctNumber & "Title", "ЦКТ" & cctNumber)

    Call SetControlValue("txtCCT" & cctNumber & "Status", Null)
    Call SetControlValue("txtCCT" & cctNumber & "Sort", Null)
    Call SetControlValue("txtCCT" & cctNumber & "VolumeL", Null)
    Call SetControlValue("txtCCT" & cctNumber & "FreeVolumeL", Null)
    Call SetControlValue("txtCCT" & cctNumber & "FermentationNumber", Null)
    Call SetControlValue("txtCCT" & cctNumber & "BrewNumbers", Null)
    Call SetControlValue("txtCCT" & cctNumber & "LastBrewDate", Null)
    Call SetControlValue("txtCCT" & cctNumber & "BeerAgeDays", Null)
    Call SetControlValue("txtCCT" & cctNumber & "YeastDate", Null)

    Call SetControlValue("chkCCT" & cctNumber & "YeastRemoved", False)
    Call SetControlEnabled("chkCCT" & cctNumber & "YeastRemoved", False)

    Call SetCctCardColor(cctNumber, False, False)

End Sub


' ============================================================
' Снятие дрожжей через checkbox
' ============================================================

Private Sub ChangeYeastRemovedByCheckBox(ByVal cctNumber As Long)

    ' Обрабатывает изменение checkbox "Дрожжи сняты".
    '
    ' Если пользователь ставит галочку:
    '   Снятие дрожжей = Да.
    '   Дата снятия дрожжей = сегодня.
    '
    ' Если пользователь снимает галочку:
    '   Снятие дрожжей = Нет.
    '   Дата снятия дрожжей = пусто.
    '
    ' При программном обновлении панели событие пропускается
    ' через флаг mInternalPanelUpdate.

    On Error GoTo ErrorHandler

    Dim vesselId As Long
    Dim vesselName As String
    Dim currentVolumeL As Double
    Dim newValue As Boolean
    Dim userAnswer As VbMsgBoxResult
    Dim checkBoxName As String

    If mInternalPanelUpdate = True Then
        Exit Sub
    End If

    checkBoxName = "chkCCT" & cctNumber & "YeastRemoved"

    vesselId = GetVesselIdByTypeAndNumber(VESSEL_TYPE_CCT, cctNumber)
    vesselName = GetVesselNameById(vesselId)

    If vesselId <= 0 Then

        MsgBox "Не найдена емкость ЦКТ" & cctNumber & " в справочнике tЕмкости.", _
               vbExclamation, _
               "Снятие дрожжей"

        Call RefreshCctPanel
        Exit Sub

    End If

    currentVolumeL = GetVesselCurrentVolume(vesselId)

    If currentVolumeL <= 0 Then

        MsgBox vesselName & " свободен. Снятие дрожжей отмечать не нужно.", _
               vbInformation, _
               "Снятие дрожжей"

        Call RefreshCctPanel
        Exit Sub

    End If

    newValue = Nz(Me.Controls(checkBoxName).Value, False)

    If newValue = True Then

        userAnswer = MsgBox( _
            "Отметить снятие дрожжей для " & vesselName & "?", _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            "Снятие дрожжей" _
        )

        If userAnswer <> vbYes Then
            Call RefreshCctPanel
            Exit Sub
        End If

        CurrentDb.Execute _
            "UPDATE [tСостояниеЕмкостей] " & _
            "SET [Снятие дрожжей] = True, " & _
            "    [Дата снятия дрожжей] = Date() " & _
            "WHERE [Код емкости] = " & vesselId & ";", _
            dbFailOnError

    Else

        userAnswer = MsgBox( _
            "Снять отметку снятия дрожжей для " & vesselName & "?", _
            vbQuestion + vbYesNo + vbDefaultButton2, _
            "Снятие дрожжей" _
        )

        If userAnswer <> vbYes Then
            Call RefreshCctPanel
            Exit Sub
        End If

        CurrentDb.Execute _
            "UPDATE [tСостояниеЕмкостей] " & _
            "SET [Снятие дрожжей] = False, " & _
            "    [Дата снятия дрожжей] = Null " & _
            "WHERE [Код емкости] = " & vesselId & ";", _
            dbFailOnError

    End If

    Call RefreshCctPanel

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось изменить признак снятия дрожжей для ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Снятие дрожжей"

    Call RefreshCctPanel

End Sub


' ============================================================
' Журнал ЦКТ
' ============================================================

Private Sub OpenCctJournal(ByVal cctNumber As Long)

    ' Открывает журнал движений по выбранному ЦКТ.
    '
    ' Пока форма fЦКТ_Журнал еще не создана,
    ' показываем информационное сообщение.

    On Error GoTo ErrorHandler

    If FormExists(FORM_CCT_JOURNAL) = False Then

        MsgBox "Форма журнала ЦКТ еще не создана." & vbCrLf & vbCrLf & _
               "Следующий этап: создать форму " & FORM_CCT_JOURNAL & ".", _
               vbInformation, _
               "Журнал ЦКТ"

        Exit Sub

    End If

    DoCmd.OpenForm _
        FormName:=FORM_CCT_JOURNAL, _
        View:=acNormal, _
        WindowMode:=acWindowNormal, _
        OpenArgs:=CStr(cctNumber)

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть журнал ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Журнал ЦКТ"

End Sub


' ============================================================
' Операции ЦКТ
' ============================================================

Private Sub OpenCctOperation(ByVal cctNumber As Long)

    ' Открывает форму операций по выбранному ЦКТ.
    '
    ' По принятой логике для ЦКТ будут операции:
    '   - ЦКТ -> Фильтрация -> Форфас;
    '   - ЦКТ -> Розлив;
    '   - Корректировка объема ЦКТ.
    '
    ' Пока форма fОперацияЦКТ еще не создана,
    ' показываем информационное сообщение.

    On Error GoTo ErrorHandler

    If FormExists(FORM_CCT_OPERATION) = False Then

        MsgBox "Форма операций ЦКТ еще не создана." & vbCrLf & vbCrLf & _
               "Следующий этап: создать форму " & FORM_CCT_OPERATION & ".", _
               vbInformation, _
               "Операции ЦКТ"

        Exit Sub

    End If

    DoCmd.OpenForm _
        FormName:=FORM_CCT_OPERATION, _
        View:=acNormal, _
        WindowMode:=acWindowNormal, _
        OpenArgs:=CStr(cctNumber)

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть форму операций по ЦКТ" & cctNumber & "." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Операции ЦКТ"

End Sub


' ============================================================
' Цветовая маркировка карточек
' ============================================================

Private Sub SetCctCardColor( _
    ByVal cctNumber As Long, _
    ByVal isBusy As Boolean, _
    ByVal yeastRemoved As Boolean _
)

    ' Цветовая маркировка карточки:
    '
    '   Свободен:
    '       основа карточки — светло-серая.
    '       подпись строки дрожжей — "Дрожжи".
    '
    '   Занят, дрожжи сняты:
    '       основа карточки — светло-желтая.
    '       строка дрожжей — светло-зеленая.
    '       подпись строки дрожжей — "Дрожжи сняты".
    '
    '   Занят, дрожжи не сняты:
    '       основа карточки — светло-желтая.
    '       строка дрожжей — светло-красная.
    '       подпись строки дрожжей — "Дрожжи не сняты".

    On Error Resume Next

    Dim cardColor As Long
    Dim yeastColor As Long
    Dim yeastCaption As String

    ' ------------------------------------------------------------
    ' Основной цвет карточки
    ' ------------------------------------------------------------
    If isBusy = True Then

        ' Занятая емкость.
        cardColor = RGB(255, 242, 204)

    Else

        ' Свободная емкость.
        cardColor = RGB(242, 242, 242)

    End If

    ' ------------------------------------------------------------
    ' Цвет и текст строки "Дрожжи"
    ' ------------------------------------------------------------
    If isBusy = False Then

        ' Для свободной емкости состояние дрожжей не актуально.
        yeastColor = cardColor
        yeastCaption = "Дрожжи"

    ElseIf yeastRemoved = True Then

        ' Дрожжи сняты.
        yeastColor = RGB(198, 239, 206)
        yeastCaption = "Дрожжи сняты"

    Else

        ' Дрожжи не сняты.
        yeastColor = RGB(255, 199, 206)
        yeastCaption = "Дрожжи не сняты"

    End If

    ' ------------------------------------------------------------
    ' Фон карточки и заголовок
    ' ------------------------------------------------------------
    Call SetControlBackColor("boxCCT" & cctNumber, cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "Title", cardColor)

    ' ------------------------------------------------------------
    ' Подписи строк
    ' ------------------------------------------------------------
    Call SetControlBackColor("lblCCT" & cctNumber & "StatusCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "SortCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "VolumeCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "FreeVolumeCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "FermentationCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "BrewNumbersCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "LastBrewDateCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "BeerAgeCaption", cardColor)
    Call SetControlBackColor("lblCCT" & cctNumber & "YeastDateCaption", cardColor)

    ' Строка "Дрожжи" получает отдельный текст и акцентный цвет.
    Call SetControlCaption("lblCCT" & cctNumber & "YeastRemovedCaption", yeastCaption)
    Call SetControlBackColor("lblCCT" & cctNumber & "YeastRemovedCaption", yeastColor)

    ' ------------------------------------------------------------
    ' Поля значений
    ' ------------------------------------------------------------
    Call SetControlBackColor("txtCCT" & cctNumber & "Status", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "Sort", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "VolumeL", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "FreeVolumeL", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "FermentationNumber", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "BrewNumbers", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "LastBrewDate", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "BeerAgeDays", cardColor)
    Call SetControlBackColor("txtCCT" & cctNumber & "YeastDate", cardColor)

    ' ------------------------------------------------------------
    ' Checkbox "Дрожжи сняты"
    ' ------------------------------------------------------------
    Call SetControlBackColor("chkCCT" & cctNumber & "YeastRemoved", yeastColor)

End Sub


' ============================================================
' Безопасная работа с элементами управления
' ============================================================

Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.
    '
    ' Это удобно при первичной настройке формы:
    ' если какой-то элемент еще не создан или назван иначе,
    ' код не падает, а просто пишет сообщение в Immediate Window.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    Set ctl = Me.Controls(controlName)

    ControlExists = True

    Exit Function

ErrorHandler:

    ControlExists = False

End Function


Private Sub SetControlValue( _
    ByVal controlName As String, _
    ByVal controlValue As Variant _
)

    ' Безопасно записывает значение в элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Value = controlValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlValue для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlCaption( _
    ByVal controlName As String, _
    ByVal captionText As String _
)

    ' Безопасно меняет Caption у надписи или кнопки.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Caption = captionText

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlCaption для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlEnabled( _
    ByVal controlName As String, _
    ByVal enabledValue As Boolean _
)

    ' Безопасно включает или отключает элемент управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).Enabled = enabledValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlEnabled для " & controlName & ": " & Err.Description

End Sub


Private Sub SetControlBackColor( _
    ByVal controlName As String, _
    ByVal colorValue As Long _
)

    ' Безопасно меняет цвет фона элемента управления.

    On Error GoTo ErrorHandler

    If ControlExists(controlName) = False Then
        Debug.Print "Не найден элемент: " & controlName
        Exit Sub
    End If

    Me.Controls(controlName).BackStyle = 1
    Me.Controls(controlName).BackColor = colorValue

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка SetControlBackColor для " & controlName & ": " & Err.Description

End Sub


Private Function NullIfEmpty(ByVal sourceText As String) As Variant

    ' Возвращает Null, если строка пустая.
    ' Иначе возвращает саму строку.

    If Trim(Nz(sourceText, "")) = "" Then
        NullIfEmpty = Null
    Else
        NullIfEmpty = sourceText
    End If

End Function


Private Function FormExists(ByVal formName As String) As Boolean

    ' Проверяет, существует ли форма в базе Access.

    On Error GoTo ErrorHandler

    Dim obj As AccessObject

    For Each obj In CurrentProject.AllForms

        If StrComp(obj.Name, formName, vbTextCompare) = 0 Then
            FormExists = True
            Exit Function
        End If

    Next obj

    FormExists = False

    Exit Function

ErrorHandler:

    FormExists = False

End Function

```

### fProductMovementJournal_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fОбщий журнал движения продукта.  
**SHA256:** `916954ae7ad2deff538e929675c20e12b8414c264d3f9c96cf83fc83bdebe4ca`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fЖурнал_ДвижениеПродукта
'
' Назначение:
'   Общий журнал движения продукта по партиям.
'
' Источник данных:
'   qПартии_Движение
'
' Показывает операции:
'   - Варка - ЦКТ;
'   - ЦКТ - Фильтрация - Форфас;
'   - ЦКТ - Розлив;
'   - Корректировка ЦКТ;
'   - Форфас - Розлив;
'   - Корректировка Форфаса.
'
' Фильтры:
'   - дата с;
'   - дата по;
'   - сорт;
'   - номер брожения;
'   - этап операции;
'   - емкость источник;
'   - емкость приемник.
' ============================================================


Private Const QUERY_PRODUCT_MOVEMENT As String = "qПартии_Движение"


Private Sub Form_Load()

    On Error GoTo ErrorHandler

    Me.RecordSource = QUERY_PRODUCT_MOVEMENT

    Call CheckRequiredControls
    Call InitializeFilterControls
    Call ApplyJournalFilter

    Exit Sub

ErrorHandler:

    MsgBox "Ошибка при загрузке формы fЖурнал_ДвижениеПродукта:" & vbCrLf & _
           Err.Description, _
           vbCritical, _
           "Журнал движения продукта"

End Sub


Private Sub Form_Activate()

    On Error Resume Next

    Me.Requery

End Sub


Private Sub cmdApplyFilter_Click()

    Call ApplyJournalFilter

End Sub


Private Sub cmdClearFilter_Click()

    Call ClearFilterControls
    Call ApplyJournalFilter

End Sub


Private Sub cmdCloseForm_Click()

    DoCmd.Close acForm, Me.Name

End Sub


Private Sub txtDateFrom_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub txtDateTo_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboSort_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboFermentationNumber_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboOperationStage_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboSourceVessel_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboTargetVessel_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub CheckRequiredControls()

    ' Проверяет наличие элементов, которые ожидает код.

    Dim missingControls As String

    missingControls = ""

    If ControlExists("txtDateFrom") = False Then
        missingControls = missingControls & "txtDateFrom" & vbCrLf
    End If

    If ControlExists("txtDateTo") = False Then
        missingControls = missingControls & "txtDateTo" & vbCrLf
    End If

    If ControlExists("cboSort") = False Then
        missingControls = missingControls & "cboSort" & vbCrLf
    End If

    If ControlExists("cboFermentationNumber") = False Then
        missingControls = missingControls & "cboFermentationNumber" & vbCrLf
    End If

    If ControlExists("cboOperationStage") = False Then
        missingControls = missingControls & "cboOperationStage" & vbCrLf
    End If

    If ControlExists("cboSourceVessel") = False Then
        missingControls = missingControls & "cboSourceVessel" & vbCrLf
    End If

    If ControlExists("cboTargetVessel") = False Then
        missingControls = missingControls & "cboTargetVessel" & vbCrLf
    End If

    If ControlExists("cmdApplyFilter") = False Then
        missingControls = missingControls & "cmdApplyFilter" & vbCrLf
    End If

    If ControlExists("cmdClearFilter") = False Then
        missingControls = missingControls & "cmdClearFilter" & vbCrLf
    End If

    If ControlExists("cmdCloseForm") = False Then
        missingControls = missingControls & "cmdCloseForm" & vbCrLf
    End If

    If Len(missingControls) > 0 Then

        MsgBox "На форме fЖурнал_ДвижениеПродукта не найдены элементы:" & vbCrLf & vbCrLf & _
               missingControls & vbCrLf & _
               "Проверь свойство 'Имя' у элементов управления.", _
               vbExclamation, _
               "Проверка элементов формы"

    End If

End Sub


Private Sub InitializeFilterControls()

    ' Настраивает списки фильтров.
    '
    ' Списки берутся из qПартии_Движение.

    On Error GoTo ErrorHandler

    If ControlExists("cboSort") Then

        Me.cboSort.RowSourceType = "Table/Query"
        Me.cboSort.RowSource = _
            "SELECT DISTINCT [Сорт] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Сорт] Is Not Null " & _
            "ORDER BY [Сорт];"

        Me.cboSort.ColumnCount = 1
        Me.cboSort.BoundColumn = 1
        Me.cboSort.LimitToList = False
        Me.cboSort.Requery

    End If

    If ControlExists("cboFermentationNumber") Then

        Me.cboFermentationNumber.RowSourceType = "Table/Query"
        Me.cboFermentationNumber.RowSource = _
            "SELECT DISTINCT [Номер брожения] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Номер брожения] Is Not Null " & _
            "ORDER BY [Номер брожения] DESC;"

        Me.cboFermentationNumber.ColumnCount = 1
        Me.cboFermentationNumber.BoundColumn = 1
        Me.cboFermentationNumber.LimitToList = False
        Me.cboFermentationNumber.Requery

    End If

    If ControlExists("cboOperationStage") Then

        Me.cboOperationStage.RowSourceType = "Table/Query"
        Me.cboOperationStage.RowSource = _
            "SELECT DISTINCT [Этап операции] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Этап операции] Is Not Null " & _
            "ORDER BY [Этап операции];"

        Me.cboOperationStage.ColumnCount = 1
        Me.cboOperationStage.BoundColumn = 1
        Me.cboOperationStage.LimitToList = False
        Me.cboOperationStage.Requery

    End If

    If ControlExists("cboSourceVessel") Then

        Me.cboSourceVessel.RowSourceType = "Table/Query"
        Me.cboSourceVessel.RowSource = _
            "SELECT DISTINCT [Емкость источника] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Емкость источника] Is Not Null " & _
            "ORDER BY [Емкость источника];"

        Me.cboSourceVessel.ColumnCount = 1
        Me.cboSourceVessel.BoundColumn = 1
        Me.cboSourceVessel.LimitToList = False
        Me.cboSourceVessel.Requery

    End If

    If ControlExists("cboTargetVessel") Then

        Me.cboTargetVessel.RowSourceType = "Table/Query"
        Me.cboTargetVessel.RowSource = _
            "SELECT DISTINCT [Емкость приемника] " & _
            "FROM [qПартии_Движение] " & _
            "WHERE [Емкость приемника] Is Not Null " & _
            "ORDER BY [Емкость приемника];"

        Me.cboTargetVessel.ColumnCount = 1
        Me.cboTargetVessel.BoundColumn = 1
        Me.cboTargetVessel.LimitToList = False
        Me.cboTargetVessel.Requery

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить списки фильтров." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Журнал движения продукта"

End Sub


Private Sub ApplyJournalFilter()

    On Error GoTo ErrorHandler

    Dim filterText As String

    filterText = ""

    If ControlExists("txtDateFrom") Then

        If Len(Nz(Me.txtDateFrom.Value, "")) > 0 Then

            If IsDate(Me.txtDateFrom.Value) = False Then
                MsgBox "Некорректная дата в поле 'Дата с'.", _
                       vbExclamation, _
                       "Фильтр журнала движения продукта"
                Exit Sub
            End If

            Call AddFilterPart( _
                filterText, _
                "[Дата операции] >= " & SqlDateLiteral(Me.txtDateFrom.Value) _
            )

        End If

    End If

    If ControlExists("txtDateTo") Then

        If Len(Nz(Me.txtDateTo.Value, "")) > 0 Then

            If IsDate(Me.txtDateTo.Value) = False Then
                MsgBox "Некорректная дата в поле 'Дата по'.", _
                       vbExclamation, _
                       "Фильтр журнала движения продукта"
                Exit Sub
            End If

            Call AddFilterPart( _
                filterText, _
                "[Дата операции] < " & SqlDateLiteral(DateAdd("d", 1, CDate(Me.txtDateTo.Value))) _
            )

        End If

    End If

    If ControlExists("cboSort") Then

        If Len(Nz(Me.cboSort.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Сорт] = " & SqlTextLiteral(Me.cboSort.Value) _
            )

        End If

    End If

    If ControlExists("cboFermentationNumber") Then

        If Len(Nz(Me.cboFermentationNumber.Value, "")) > 0 Then

            If IsNumeric(Me.cboFermentationNumber.Value) = False Then
                MsgBox "Некорректный номер брожения.", _
                       vbExclamation, _
                       "Фильтр журнала движения продукта"
                Exit Sub
            End If

            Call AddFilterPart( _
                filterText, _
                "[Номер брожения] = " & CLng(Me.cboFermentationNumber.Value) _
            )

        End If

    End If

    If ControlExists("cboOperationStage") Then

        If Len(Nz(Me.cboOperationStage.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Этап операции] = " & SqlTextLiteral(Me.cboOperationStage.Value) _
            )

        End If

    End If

    If ControlExists("cboSourceVessel") Then

        If Len(Nz(Me.cboSourceVessel.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Емкость источника] = " & SqlTextLiteral(Me.cboSourceVessel.Value) _
            )

        End If

    End If

    If ControlExists("cboTargetVessel") Then

        If Len(Nz(Me.cboTargetVessel.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Емкость приемника] = " & SqlTextLiteral(Me.cboTargetVessel.Value) _
            )

        End If

    End If

    If Len(filterText) = 0 Then

        Me.FilterOn = False
        Me.Filter = ""

    Else

        Me.Filter = filterText
        Me.FilterOn = True

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось применить фильтр журнала движения продукта." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Журнал движения продукта"

End Sub


Private Sub ClearFilterControls()

    On Error Resume Next

    If ControlExists("txtDateFrom") Then
        Me.txtDateFrom.Value = Null
    End If

    If ControlExists("txtDateTo") Then
        Me.txtDateTo.Value = Null
    End If

    If ControlExists("cboSort") Then
        Me.cboSort.Value = Null
    End If

    If ControlExists("cboFermentationNumber") Then
        Me.cboFermentationNumber.Value = Null
    End If

    If ControlExists("cboOperationStage") Then
        Me.cboOperationStage.Value = Null
    End If

    If ControlExists("cboSourceVessel") Then
        Me.cboSourceVessel.Value = Null
    End If

    If ControlExists("cboTargetVessel") Then
        Me.cboTargetVessel.Value = Null
    End If

End Sub


Private Sub AddFilterPart( _
    ByRef filterText As String, _
    ByVal filterPart As String _
)

    If Len(filterText) > 0 Then
        filterText = filterText & " AND "
    End If

    filterText = filterText & filterPart

End Sub


Private Function SqlTextLiteral(ByVal valueText As Variant) As String

    SqlTextLiteral = "'" & Replace(CStr(valueText), "'", "''") & "'"

End Function


Private Function SqlDateLiteral(ByVal dateValue As Variant) As String

    SqlDateLiteral = "#" & Format$(CDate(dateValue), "yyyy\/mm\/dd") & "#"

End Function


Private Function ControlExists(ByVal controlName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    For Each ctl In Me.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExists = True
            Exit Function
        End If

    Next ctl

    ControlExists = False

    Exit Function

ErrorHandler:

    ControlExists = False

End Function

```

### fBatchCheckJournal_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fЖурнал проверки партий.  
**SHA256:** `9b13364a43df01cd8d4d821fcd40041f196b95aabbc666a00413d933f6316169`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fЖурнал_СверкаПартий
'
' Назначение:
'   Общий журнал / форма контроля состояния партий.
'
' Источник данных:
'   qПартии_Состояние
'
' Показывает:
'   - поступление партии в ЦКТ;
'   - потери фильтрации;
'   - общий розлив;
'   - расчетный остаток;
'   - фактический остаток;
'   - расхождение;
'   - статус сверки;
'   - статус партии.
'
' Фильтры:
'   - сорт;
'   - номер брожения;
'   - статус сверки;
'   - статус партии.
' ============================================================


Private Const QUERY_BATCH_STATE As String = "qПартии_Состояние"


Private Sub Form_Load()

    On Error GoTo ErrorHandler

    Me.RecordSource = QUERY_BATCH_STATE

    Call CheckRequiredControls
    Call InitializeFilterControls
    Call ApplyJournalFilter

    Exit Sub

ErrorHandler:

    MsgBox "Ошибка при загрузке формы fЖурнал_СверкаПартий:" & vbCrLf & _
           Err.Description, _
           vbCritical, _
           "Сверка партий"

End Sub


Private Sub Form_Activate()

    On Error Resume Next

    Me.Requery

End Sub


Private Sub cmdApplyFilter_Click()

    Call ApplyJournalFilter

End Sub


Private Sub cmdClearFilter_Click()

    Call ClearFilterControls
    Call ApplyJournalFilter

End Sub


Private Sub cmdCloseForm_Click()

    DoCmd.Close acForm, Me.Name

End Sub


Private Sub cboSort_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboFermentationNumber_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboCheckStatus_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub cboBatchStatus_AfterUpdate()

    Call ApplyJournalFilter

End Sub


Private Sub CheckRequiredControls()

    ' Проверяет наличие элементов, которые ожидает код.

    Dim missingControls As String

    missingControls = ""

    If ControlExists("cboSort") = False Then
        missingControls = missingControls & "cboSort" & vbCrLf
    End If

    If ControlExists("cboFermentationNumber") = False Then
        missingControls = missingControls & "cboFermentationNumber" & vbCrLf
    End If

    If ControlExists("cboCheckStatus") = False Then
        missingControls = missingControls & "cboCheckStatus" & vbCrLf
    End If

    If ControlExists("cboBatchStatus") = False Then
        missingControls = missingControls & "cboBatchStatus" & vbCrLf
    End If

    If ControlExists("cmdApplyFilter") = False Then
        missingControls = missingControls & "cmdApplyFilter" & vbCrLf
    End If

    If ControlExists("cmdClearFilter") = False Then
        missingControls = missingControls & "cmdClearFilter" & vbCrLf
    End If

    If ControlExists("cmdCloseForm") = False Then
        missingControls = missingControls & "cmdCloseForm" & vbCrLf
    End If

    If Len(missingControls) > 0 Then

        MsgBox "На форме fЖурнал_СверкаПартий не найдены элементы:" & vbCrLf & vbCrLf & _
               missingControls & vbCrLf & _
               "Проверь свойство 'Имя' у элементов управления.", _
               vbExclamation, _
               "Проверка элементов формы"

    End If

End Sub


Private Sub InitializeFilterControls()

    ' Настраивает списки фильтров.
    '
    ' Списки берутся из qПартии_Состояние.

    On Error GoTo ErrorHandler

    If ControlExists("cboSort") Then

        Me.cboSort.RowSourceType = "Table/Query"
        Me.cboSort.RowSource = _
            "SELECT DISTINCT [Сорт] " & _
            "FROM [qПартии_Состояние] " & _
            "WHERE [Сорт] Is Not Null " & _
            "ORDER BY [Сорт];"

        Me.cboSort.ColumnCount = 1
        Me.cboSort.BoundColumn = 1
        Me.cboSort.LimitToList = False
        Me.cboSort.Requery

    End If

    If ControlExists("cboFermentationNumber") Then

        Me.cboFermentationNumber.RowSourceType = "Table/Query"
        Me.cboFermentationNumber.RowSource = _
            "SELECT DISTINCT [Номер брожения] " & _
            "FROM [qПартии_Состояние] " & _
            "WHERE [Номер брожения] Is Not Null " & _
            "ORDER BY [Номер брожения] DESC;"

        Me.cboFermentationNumber.ColumnCount = 1
        Me.cboFermentationNumber.BoundColumn = 1
        Me.cboFermentationNumber.LimitToList = False
        Me.cboFermentationNumber.Requery

    End If

    If ControlExists("cboCheckStatus") Then

        Me.cboCheckStatus.RowSourceType = "Value List"
        Me.cboCheckStatus.RowSource = "OK;Расхождение"
        Me.cboCheckStatus.ColumnCount = 1
        Me.cboCheckStatus.BoundColumn = 1
        Me.cboCheckStatus.LimitToList = False
        Me.cboCheckStatus.Requery

    End If

    If ControlExists("cboBatchStatus") Then

        Me.cboBatchStatus.RowSourceType = "Value List"
        Me.cboBatchStatus.RowSource = "В работе;Закрыта"
        Me.cboBatchStatus.ColumnCount = 1
        Me.cboBatchStatus.BoundColumn = 1
        Me.cboBatchStatus.LimitToList = False
        Me.cboBatchStatus.Requery

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось настроить списки фильтров." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Сверка партий"

End Sub


Private Sub ApplyJournalFilter()

    On Error GoTo ErrorHandler

    Dim filterText As String

    filterText = ""

    ' ------------------------------------------------------------
    ' Сорт.
    ' ------------------------------------------------------------
    If ControlExists("cboSort") Then

        If Len(Nz(Me.cboSort.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Сорт] = " & SqlTextLiteral(Me.cboSort.Value) _
            )

        End If

    End If

    ' ------------------------------------------------------------
    ' Номер брожения.
    ' ------------------------------------------------------------
    If ControlExists("cboFermentationNumber") Then

        If Len(Nz(Me.cboFermentationNumber.Value, "")) > 0 Then

            If IsNumeric(Me.cboFermentationNumber.Value) = False Then
                MsgBox "Некорректный номер брожения.", _
                       vbExclamation, _
                       "Фильтр сверки партий"
                Exit Sub
            End If

            Call AddFilterPart( _
                filterText, _
                "[Номер брожения] = " & CLng(Me.cboFermentationNumber.Value) _
            )

        End If

    End If

    ' ------------------------------------------------------------
    ' Статус сверки.
    ' ------------------------------------------------------------
    If ControlExists("cboCheckStatus") Then

        If Len(Nz(Me.cboCheckStatus.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Статус сверки] = " & SqlTextLiteral(Me.cboCheckStatus.Value) _
            )

        End If

    End If

    ' ------------------------------------------------------------
    ' Статус партии.
    ' ------------------------------------------------------------
    If ControlExists("cboBatchStatus") Then

        If Len(Nz(Me.cboBatchStatus.Value, "")) > 0 Then

            Call AddFilterPart( _
                filterText, _
                "[Статус партии] = " & SqlTextLiteral(Me.cboBatchStatus.Value) _
            )

        End If

    End If

    ' ------------------------------------------------------------
    ' Применение фильтра.
    ' ------------------------------------------------------------
    If Len(filterText) = 0 Then

        Me.FilterOn = False
        Me.Filter = ""

    Else

        Me.Filter = filterText
        Me.FilterOn = True

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось применить фильтр сверки партий." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Сверка партий"

End Sub


Private Sub ClearFilterControls()

    On Error Resume Next

    If ControlExists("cboSort") Then
        Me.cboSort.Value = Null
    End If

    If ControlExists("cboFermentationNumber") Then
        Me.cboFermentationNumber.Value = Null
    End If

    If ControlExists("cboCheckStatus") Then
        Me.cboCheckStatus.Value = Null
    End If

    If ControlExists("cboBatchStatus") Then
        Me.cboBatchStatus.Value = Null
    End If

End Sub


Private Sub AddFilterPart( _
    ByRef filterText As String, _
    ByVal filterPart As String _
)

    ' Добавляет условие к фильтру через AND.

    If Len(filterText) > 0 Then
        filterText = filterText & " AND "
    End If

    filterText = filterText & filterPart

End Sub


Private Function SqlTextLiteral(ByVal valueText As Variant) As String

    ' Текстовый литерал для фильтра Access.

    SqlTextLiteral = "'" & Replace(CStr(valueText), "'", "''") & "'"

End Function


Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.
    '
    ' Используем перебор с Trim, чтобы случайный пробел
    ' в имени элемента не ломал проверку.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    For Each ctl In Me.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExists = True
            Exit Function
        End If

    Next ctl

    ControlExists = False

    Exit Function

ErrorHandler:

    ControlExists = False

End Function

```

### fPackageDirectory_Code.bas

**Группа:** `final_preferred`  
**Назначение:** fСправочник тары.  
**SHA256:** `3180f2cbbc7c9510bf9fa59f9258611b4c84cd908c7f3a1d32c99d18cd267f7a`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fСправочник_Тара
'
' Назначение:
'   Справочник тары для операций розлива.
'
' Источник данных:
'   tТара
'
' Поля таблицы:
'   Код
'   Тип тары
'   Название тары
'   Объем единицы тары(л)
'   Активна
'   Комментарий
'
' Важный принцип:
'   Тару лучше не удалять физически, потому что старые движения
'   могут ссылаться на Код тары или хранить снимок этой тары.
'   Вместо удаления используем поле [Активна] = False.
' ============================================================


Private Const TABLE_PACKAGE As String = "tТара"


Private Sub Form_Load()

    On Error GoTo ErrorHandler

    Me.RecordSource = TABLE_PACKAGE
    Me.OrderBy = "[Тип тары], [Объем единицы тары(л)], [Название тары]"
    Me.OrderByOn = True

    Call CheckRequiredControls

    Exit Sub

ErrorHandler:

    MsgBox "Ошибка при загрузке формы fСправочник_Тара:" & vbCrLf & _
           Err.Description, _
           vbCritical, _
           "Справочник тары"

End Sub


Private Sub Form_BeforeUpdate(Cancel As Integer)

    ' Проверяем корректность записи перед сохранением.

    If ValidateCurrentRecord() = False Then
        Cancel = True
    End If

End Sub


Private Sub Form_Current()

    ' При переходе по записям можно обновлять состояние кнопок.

    Call RefreshButtonsState

End Sub


Private Sub cmdNewPackage_Click()

    ' Создает новую строку справочника тары.

    On Error GoTo ErrorHandler

    DoCmd.GoToRecord , , acNewRec

    If ControlExists("txtPackageType") Then
        Me.txtPackageType.SetFocus
    End If

    If ControlExists("chkIsActive") Then
        Me.chkIsActive.Value = True
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось создать новую тару." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Справочник тары"

End Sub


Private Sub cmdSavePackage_Click()

    ' Сохраняет текущую запись.

    On Error GoTo ErrorHandler

    If Me.Dirty Then

        If ValidateCurrentRecord() = False Then
            Exit Sub
        End If

        Me.Dirty = False

    End If

    Me.Requery

    MsgBox "Запись справочника тары сохранена.", _
           vbInformation, _
           "Справочник тары"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сохранить запись справочника тары." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Справочник тары"

End Sub


Private Sub cmdDeactivatePackage_Click()

    ' Делает тару неактивной.
    '
    ' Физически запись не удаляется.

    On Error GoTo ErrorHandler

    If Me.NewRecord Then
        MsgBox "Новая несохраненная запись не может быть отключена.", _
               vbInformation, _
               "Справочник тары"
        Exit Sub
    End If

    If MsgBox( _
        "Отключить выбранную тару?" & vbCrLf & vbCrLf & _
        "Она останется в истории, но не будет отображаться в списках выбора для новых операций.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        "Отключение тары" _
    ) <> vbYes Then
        Exit Sub
    End If

    Me.[Активна].Value = False

    If Me.Dirty Then
        Me.Dirty = False
    End If

    Me.Requery

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось отключить тару." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Справочник тары"

End Sub


Private Sub cmdActivatePackage_Click()

    ' Возвращает тару в активный список.

    On Error GoTo ErrorHandler

    If Me.NewRecord Then
        MsgBox "Сначала сохраните новую запись.", _
               vbInformation, _
               "Справочник тары"
        Exit Sub
    End If

    Me.[Активна].Value = True

    If Me.Dirty Then
        Me.Dirty = False
    End If

    Me.Requery

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось включить тару." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Справочник тары"

End Sub


Private Sub cmdRefreshForm_Click()

    ' Обновляет форму справочника.

    On Error Resume Next

    Me.Requery

End Sub


Private Sub cmdCloseForm_Click()

    ' Закрывает форму справочника.

    On Error GoTo ErrorHandler

    If Me.Dirty Then

        If MsgBox( _
            "Есть несохраненные изменения. Сохранить перед закрытием?", _
            vbQuestion + vbYesNoCancel, _
            "Справочник тары" _
        ) = vbCancel Then
            Exit Sub
        End If

        If MsgBox( _
            "Сохранить изменения?", _
            vbQuestion + vbYesNo, _
            "Справочник тары" _
        ) = vbYes Then

            If ValidateCurrentRecord() = False Then
                Exit Sub
            End If

            Me.Dirty = False

        Else

            Me.Undo

        End If

    End If

    DoCmd.Close acForm, Me.Name

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось закрыть форму справочника тары." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Справочник тары"

End Sub


Private Function ValidateCurrentRecord() As Boolean

    ' Проверяет текущую запись справочника тары.

    On Error GoTo ErrorHandler

    ValidateCurrentRecord = False

    If Len(Trim$(Nz(Me.[Тип тары].Value, ""))) = 0 Then

        MsgBox "Заполните поле 'Тип тары'.", _
               vbExclamation, _
               "Проверка справочника тары"

        If ControlExists("txtPackageType") Then
            Me.txtPackageType.SetFocus
        End If

        Exit Function

    End If

    If Len(Trim$(Nz(Me.[Название тары].Value, ""))) = 0 Then

        MsgBox "Заполните поле 'Название тары'.", _
               vbExclamation, _
               "Проверка справочника тары"

        If ControlExists("txtPackageName") Then
            Me.txtPackageName.SetFocus
        End If

        Exit Function

    End If

    If Nz(Me.[Объем единицы тары(л)].Value, 0) <= 0 Then

        MsgBox "Поле 'Объем единицы тары(л)' должно быть больше 0.", _
               vbExclamation, _
               "Проверка справочника тары"

        If ControlExists("txtPackageVolumeL") Then
            Me.txtPackageVolumeL.SetFocus
        End If

        Exit Function

    End If

    If IsNull(Me.[Активна].Value) Then
        Me.[Активна].Value = True
    End If

    ValidateCurrentRecord = True

    Exit Function

ErrorHandler:

    MsgBox "Ошибка проверки записи справочника тары." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Проверка справочника тары"

    ValidateCurrentRecord = False

End Function


Private Sub RefreshButtonsState()

    ' Обновляет доступность кнопок.
    '
    ' Кнопки могут отсутствовать на форме — это допустимо.

    On Error Resume Next

    If ControlExists("cmdDeactivatePackage") Then
        Me.cmdDeactivatePackage.Enabled = Not Me.NewRecord
    End If

    If ControlExists("cmdActivatePackage") Then
        Me.cmdActivatePackage.Enabled = Not Me.NewRecord
    End If

End Sub


Private Sub CheckRequiredControls()

    ' Диагностическая проверка ожидаемых элементов.
    '
    ' Форма может быть построена и без этих имен, если используются
    ' стандартные связанные поля. Но для SetFocus и кнопок эти имена удобны.

    Dim missingControls As String

    missingControls = ""

    If ControlExists("txtPackageType") = False Then
        missingControls = missingControls & "txtPackageType" & vbCrLf
    End If

    If ControlExists("txtPackageName") = False Then
        missingControls = missingControls & "txtPackageName" & vbCrLf
    End If

    If ControlExists("txtPackageVolumeL") = False Then
        missingControls = missingControls & "txtPackageVolumeL" & vbCrLf
    End If

    If ControlExists("chkIsActive") = False Then
        missingControls = missingControls & "chkIsActive" & vbCrLf
    End If

    If ControlExists("cmdNewPackage") = False Then
        missingControls = missingControls & "cmdNewPackage" & vbCrLf
    End If

    If ControlExists("cmdSavePackage") = False Then
        missingControls = missingControls & "cmdSavePackage" & vbCrLf
    End If

    If ControlExists("cmdDeactivatePackage") = False Then
        missingControls = missingControls & "cmdDeactivatePackage" & vbCrLf
    End If

    If ControlExists("cmdActivatePackage") = False Then
        missingControls = missingControls & "cmdActivatePackage" & vbCrLf
    End If

    If ControlExists("cmdRefreshForm") = False Then
        missingControls = missingControls & "cmdRefreshForm" & vbCrLf
    End If

    If ControlExists("cmdCloseForm") = False Then
        missingControls = missingControls & "cmdCloseForm" & vbCrLf
    End If

    If Len(missingControls) > 0 Then

        MsgBox "На форме fСправочник_Тара не найдены элементы:" & vbCrLf & vbCrLf & _
               missingControls & vbCrLf & _
               "Если эти элементы называются иначе — переименуй их или скорректируй код.", _
               vbInformation, _
               "Проверка элементов формы"

    End If

End Sub


Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.
    '
    ' Используем перебор с Trim, чтобы случайный пробел
    ' в имени элемента не ломал проверку.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    For Each ctl In Me.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExists = True
            Exit Function
        End If

    Next ctl

    ControlExists = False

    Exit Function

ErrorHandler:

    ControlExists = False

End Function

```

### fLicenseGenerator_Code_RobustSearch.bas

**Группа:** `final_preferred`  
**Назначение:** fLicenseGenerator — форма генератора ключей для dev/служебной базы, не включать в Prod.  
**SHA256:** `8a449a2bf21600b17c8c115751e8f166b79222b8de844b64e34a5aa3933b07f1`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fLicenseGenerator
'
' Назначение:
'   Удобная форма генерации лицензионного ключа разработчиком.
'
' Рекомендуемые имена элементов:
'   txtMachineCode
'   txtExpireDate
'   txtGeneratedLicenseKey
'
'   cmdGenerateLicenseKey
'   cmdCopyLicenseKey
'   cmdClear
'   cmdClose
'
' Особенность этой версии:
'   Код умеет работать даже если Access фактически не видит элементы
'   по именам txtMachineCode / txtExpireDate / txtGeneratedLicenseKey.
'
'   Поиск выполняется так:
'     1. по имени элемента;
'     2. по подписи привязанной метки;
'     3. по порядку текстовых полей на форме.
'
' Это нужно, потому что в Access иногда визуально кажется, что имя задано,
' но код формы все равно не находит элемент по ожидаемому имени.
' ============================================================


Private Sub Form_Load()

    ' Значения по умолчанию.

    On Error Resume Next

    SetTextBoxValue GetExpireDateControl(), DateAdd("d", 60, Date)
    SetTextBoxValue GetGeneratedKeyControl(), Null

End Sub


Private Sub cmdGenerateLicenseKey_Click()

    ' Генерирует ключ и выводит его в текстовое поле,
    ' чтобы его можно было выделить и скопировать.

    On Error GoTo ErrorHandler

    Dim ctlMachineCode As Control
    Dim ctlExpireDate As Control
    Dim ctlGeneratedKey As Control

    Dim machineCode As String
    Dim expireDate As Date
    Dim licenseKey As String

    Set ctlMachineCode = GetMachineCodeControl()
    Set ctlExpireDate = GetExpireDateControl()
    Set ctlGeneratedKey = GetGeneratedKeyControl()

    If ctlMachineCode Is Nothing Then
        Call ShowControlsDebugMessage("Не найдено поле кода компьютера клиента.")
        Exit Sub
    End If

    If ctlExpireDate Is Nothing Then
        Call ShowControlsDebugMessage("Не найдено поле даты окончания лицензии.")
        Exit Sub
    End If

    If ctlGeneratedKey Is Nothing Then
        Call ShowControlsDebugMessage("Не найдено поле лицензионного ключа.")
        Exit Sub
    End If

    machineCode = Trim$(Nz(ctlMachineCode.Value, ""))

    If machineCode = "" Then
        MsgBox "Введите код компьютера клиента.", _
               vbExclamation, _
               "Генератор лицензии"
        ctlMachineCode.SetFocus
        Exit Sub
    End If

    If IsDate(ctlExpireDate.Value) = False Then
        MsgBox "Введите корректную дату окончания лицензии.", _
               vbExclamation, _
               "Генератор лицензии"
        ctlExpireDate.SetFocus
        Exit Sub
    End If

    expireDate = CDate(ctlExpireDate.Value)

    licenseKey = GeneratePivovarLicenseKey(machineCode, expireDate, "Alpha")

    If Trim$(licenseKey) = "" Then
        MsgBox "Не удалось сформировать лицензионный ключ.", _
               vbExclamation, _
               "Генератор лицензии"
        Exit Sub
    End If

    ctlGeneratedKey.Value = licenseKey

    ' Сразу копируем в буфер обмена для удобства.
    Call CopyTextToClipboard(licenseKey)

    ctlGeneratedKey.SetFocus
    ctlGeneratedKey.SelStart = 0
    ctlGeneratedKey.SelLength = Len(licenseKey)

    MsgBox "Лицензионный ключ сформирован." & vbCrLf & _
           "Ключ выведен в поле и скопирован в буфер обмена.", _
           vbInformation, _
           "Генератор лицензии"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сформировать лицензионный ключ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Генератор лицензии"

End Sub


Private Sub cmdCopyLicenseKey_Click()

    ' Копирует уже сформированный ключ из текстового поля.

    On Error GoTo ErrorHandler

    Dim ctlGeneratedKey As Control
    Dim licenseKey As String

    Set ctlGeneratedKey = GetGeneratedKeyControl()

    If ctlGeneratedKey Is Nothing Then
        Call ShowControlsDebugMessage("Не найдено поле лицензионного ключа.")
        Exit Sub
    End If

    licenseKey = Trim$(Nz(ctlGeneratedKey.Value, ""))

    If licenseKey = "" Then
        MsgBox "Сначала сформируйте лицензионный ключ.", _
               vbInformation, _
               "Генератор лицензии"
        Exit Sub
    End If

    Call CopyTextToClipboard(licenseKey)

    ctlGeneratedKey.SetFocus
    ctlGeneratedKey.SelStart = 0
    ctlGeneratedKey.SelLength = Len(licenseKey)

    MsgBox "Лицензионный ключ скопирован в буфер обмена.", _
           vbInformation, _
           "Генератор лицензии"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось скопировать лицензионный ключ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Генератор лицензии"

End Sub


Private Sub cmdClear_Click()

    ' Очищает поля формы.

    On Error Resume Next

    SetTextBoxValue GetMachineCodeControl(), Null
    SetTextBoxValue GetExpireDateControl(), DateAdd("d", 60, Date)
    SetTextBoxValue GetGeneratedKeyControl(), Null

    If Not GetMachineCodeControl() Is Nothing Then
        GetMachineCodeControl().SetFocus
    End If

End Sub


Private Sub cmdClose_Click()

    ' Закрывает форму генератора.

    DoCmd.Close acForm, Me.Name, acSaveNo

End Sub


' ============================================================
' Поиск рабочих полей формы
' ============================================================

Private Function GetMachineCodeControl() As Control

    Set GetMachineCodeControl = FindTextBoxControl( _
        "txtMachineCode", _
        "Код компьютера клиента", _
        1 _
    )

End Function


Private Function GetExpireDateControl() As Control

    Set GetExpireDateControl = FindTextBoxControl( _
        "txtExpireDate", _
        "Действует до", _
        2 _
    )

End Function


Private Function GetGeneratedKeyControl() As Control

    Set GetGeneratedKeyControl = FindTextBoxControl( _
        "txtGeneratedLicenseKey", _
        "Лицензионный ключ", _
        3 _
    )

End Function


Private Function FindTextBoxControl( _
    ByVal expectedControlName As String, _
    ByVal labelCaptionPart As String, _
    ByVal fallbackTextBoxNumber As Long _
) As Control

    ' Ищет текстовое поле:
    '   1. по точному имени;
    '   2. по подписи связанной метки;
    '   3. по порядковому номеру текстового поля на форме.

    On Error Resume Next

    Dim ctl As Control
    Dim childCtl As Control
    Dim textBoxCounter As Long

    ' ------------------------------------------------------------
    ' 1. По имени.
    ' ------------------------------------------------------------
    For Each ctl In Me.Controls

        If ctl.ControlType = acTextBox Then

            If StrComp(Trim$(ctl.Name), Trim$(expectedControlName), vbTextCompare) = 0 Then
                Set FindTextBoxControl = ctl
                Exit Function
            End If

        End If

    Next ctl

    ' ------------------------------------------------------------
    ' 2. По подписи привязанной метки.
    ' ------------------------------------------------------------
    For Each ctl In Me.Controls

        If ctl.ControlType = acTextBox Then

            For Each childCtl In ctl.Controls

                If childCtl.ControlType = acLabel Then

                    If InStr(1, Nz(childCtl.Caption, ""), labelCaptionPart, vbTextCompare) > 0 Then
                        Set FindTextBoxControl = ctl
                        Exit Function
                    End If

                End If

            Next childCtl

        End If

    Next ctl

    ' ------------------------------------------------------------
    ' 3. По порядковому номеру текстового поля.
    ' ------------------------------------------------------------
    textBoxCounter = 0

    For Each ctl In Me.Controls

        If ctl.ControlType = acTextBox Then

            textBoxCounter = textBoxCounter + 1

            If textBoxCounter = fallbackTextBoxNumber Then
                Set FindTextBoxControl = ctl
                Exit Function
            End If

        End If

    Next ctl

    Set FindTextBoxControl = Nothing

End Function


Private Sub SetTextBoxValue( _
    ByVal targetControl As Control, _
    ByVal controlValue As Variant _
)

    On Error Resume Next

    If targetControl Is Nothing Then
        Exit Sub
    End If

    targetControl.Value = controlValue

End Sub


Private Sub ShowControlsDebugMessage(ByVal headerText As String)

    ' Показывает понятное сообщение и печатает список контролов
    ' в Immediate Window для диагностики.

    On Error Resume Next

    Call DebugPrintControls

    MsgBox headerText & vbCrLf & vbCrLf & _
           "Проверьте имена элементов формы." & vbCrLf & _
           "Список элементов выведен в Immediate Window: Ctrl+G.", _
           vbExclamation, _
           "Генератор лицензии"

End Sub


Public Sub DebugPrintControls()

    ' Выводит список элементов формы в Immediate Window.
    '
    ' Можно вызвать вручную из Immediate Window:
    '   Forms("fLicenseGenerator").DebugPrintControls

    On Error Resume Next

    Dim ctl As Control

    Debug.Print "=========================================="
    Debug.Print "Controls on form: " & Me.Name
    Debug.Print "Time: " & Now()

    For Each ctl In Me.Controls

        Debug.Print _
            "Name=[" & ctl.Name & "]", _
            "Type=[" & ctl.ControlType & "]", _
            "Caption=[" & Nz(ctl.Caption, "") & "]", _
            "ControlSource=[" & Nz(ctl.ControlSource, "") & "]", _
            "Value=[" & Nz(ctl.Value, "") & "]"

    Next ctl

    Debug.Print "=========================================="

End Sub

```

### mPivovarLicenseGenerator_FinalClipboard_Code.bas

**Группа:** `final_preferred`  
**Назначение:** mPivovarLicenseGenerator — генератор ключей с копированием в буфер, не включать в Prod.  
**SHA256:** `4c455dfc732bb748764c1d4059d89520ddff65fe5e20c6374ede4d3e79345a5b`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Windows Clipboard API
'
' Нужен как надежная замена MSForms.DataObject.
' В некоторых установках Access CreateObject("MSForms.DataObject")
' не работает или не копирует текст в буфер.
' ============================================================

#If VBA7 Then

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr

Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr

#Else

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

#End If

Private Const GMEM_MOVEABLE As Long = &H2
Private Const CF_UNICODETEXT As Long = 13


' ============================================================
' Модуль: mPivovarLicenseGenerator
'
' Назначение:
'   Генератор лицензионных ключей для разработчика.
'
' Использование:
'   Вариант 1:
'     - создать форму fLicenseGenerator;
'     - добавить на форму элементы:
'         txtMachineCode
'         txtExpireDate
'         txtGeneratedLicenseKey
'         cmdGenerateLicenseKey
'         cmdCopyLicenseKey
'         cmdClear
'         cmdClose
'     - вставить код формы из fLicenseGenerator_Code.bas.
'
'   Вариант 2:
'     - вызвать из Immediate Window:
'         Call ShowPivovarLicenseKeyGenerator
'
' Формат ключа:
'   PV1-ALPHA-YYYYMMDD-XXXX-YYYY-SIGNATURE
'
' Где код компьютера клиента имеет вид:
'   PV-XXXX-YYYY
'
' Важно:
'   Секретная строка должна совпадать с GetLicenseSecret()
'   в клиентском модуле mLicense.
' ============================================================


Private Const DEFAULT_ALPHA_DAYS As Long = 60
Private Const LICENSE_TYPE_ALPHA As String = "Alpha"


Public Sub ShowPivovarLicenseKeyGenerator()

    ' Быстрый режим генерации через InputBox.
    '
    ' Дополнительно копирует ключ в буфер обмена.
    ' Основной удобный вариант — форма fLicenseGenerator.

    On Error GoTo ErrorHandler

    Dim machineCode As String
    Dim expireText As String
    Dim expireDate As Date
    Dim licenseKey As String

    machineCode = InputBox( _
        "Введите код компьютера клиента." & vbCrLf & _
        "Пример: PV-1234-ABCD", _
        "Пивовар — генератор лицензии" _
    )

    If Trim$(machineCode) = "" Then
        Exit Sub
    End If

    expireText = InputBox( _
        "Введите дату окончания лицензии в формате ДД.ММ.ГГГГ.", _
        "Пивовар — генератор лицензии", _
        Format$(DateAdd("d", DEFAULT_ALPHA_DAYS, Date), "dd.mm.yyyy") _
    )

    If Trim$(expireText) = "" Then
        Exit Sub
    End If

    If IsDate(expireText) = False Then
        MsgBox "Некорректная дата.", vbExclamation, "Генератор лицензии"
        Exit Sub
    End If

    expireDate = CDate(expireText)

    licenseKey = GeneratePivovarLicenseKey(machineCode, expireDate, LICENSE_TYPE_ALPHA)

    Call CopyTextToClipboard(licenseKey)

    MsgBox "Лицензионный ключ сформирован и скопирован в буфер обмена:" & vbCrLf & vbCrLf & _
           licenseKey, _
           vbInformation, _
           "Пивовар — генератор лицензии"

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось сформировать ключ." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Генератор лицензии"

End Sub


Public Function GeneratePivovarLicenseKey( _
    ByVal machineCode As String, _
    ByVal expireDate As Date, _
    Optional ByVal licenseType As String = LICENSE_TYPE_ALPHA _
) As String

    On Error GoTo ErrorHandler

    Dim normalizedMachineCode As String
    Dim normalizedLicenseType As String
    Dim dateText As String
    Dim signatureText As String
    Dim machinePart As String

    normalizedMachineCode = NormalizeMachineCode(machineCode)
    normalizedLicenseType = NormalizeLicenseType(licenseType)
    dateText = Format$(expireDate, "yyyymmdd")

    signatureText = BuildLicenseSignature(normalizedLicenseType, dateText, normalizedMachineCode)

    machinePart = Replace(normalizedMachineCode, "PV-", "")

    GeneratePivovarLicenseKey = _
        "PV1-" & normalizedLicenseType & "-" & dateText & "-" & machinePart & "-" & signatureText

    Exit Function

ErrorHandler:

    GeneratePivovarLicenseKey = ""

End Function


Public Sub CopyTextToClipboard(ByVal sourceText As String)

    ' Копирует текст в буфер обмена Windows.
    '
    ' Использует Windows Clipboard API, без зависимости от MSForms.DataObject.

    On Error GoTo ErrorHandler

    If CopyTextToClipboardSafe(sourceText) = False Then
        MsgBox "Не удалось автоматически скопировать текст в буфер обмена." & vbCrLf & _
               "Выделите ключ в поле и скопируйте его вручную.", _
               vbInformation, _
               "Буфер обмена"
    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось автоматически скопировать текст в буфер обмена." & vbCrLf & _
           "Выделите ключ в поле и скопируйте его вручную.", _
           vbInformation, _
           "Буфер обмена"

End Sub


Private Function CopyTextToClipboardSafe(ByVal sourceText As String) As Boolean

    ' Надежно копирует Unicode-текст в буфер обмена Windows.
    '
    ' Работает без ссылки на Microsoft Forms.
    ' Поддерживает 32-bit и 64-bit Access.

    On Error GoTo ErrorHandler

#If VBA7 Then

    Dim hGlobalMemory As LongPtr
    Dim lockedMemoryPointer As LongPtr
    Dim setDataResult As LongPtr
    Dim bytesCount As LongPtr

#Else

    Dim hGlobalMemory As Long
    Dim lockedMemoryPointer As Long
    Dim setDataResult As Long
    Dim bytesCount As Long

#End If

    CopyTextToClipboardSafe = False

    bytesCount = (Len(sourceText) + 1) * 2

    hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE, bytesCount)

    If hGlobalMemory = 0 Then
        Exit Function
    End If

    lockedMemoryPointer = GlobalLock(hGlobalMemory)

    If lockedMemoryPointer = 0 Then
        Exit Function
    End If

    Call lstrcpyW(lockedMemoryPointer, StrPtr(sourceText))
    Call GlobalUnlock(hGlobalMemory)

    If OpenClipboard(0) = 0 Then
        Exit Function
    End If

    Call EmptyClipboard

    setDataResult = SetClipboardData(CF_UNICODETEXT, hGlobalMemory)

    Call CloseClipboard

    CopyTextToClipboardSafe = (setDataResult <> 0)

    Exit Function

ErrorHandler:

    On Error Resume Next
    Call CloseClipboard
    CopyTextToClipboardSafe = False

End Function

Private Function NormalizeLicenseType(ByVal licenseType As String) As String

    NormalizeLicenseType = UCase$(Trim$(licenseType))

    If NormalizeLicenseType = "" Then
        NormalizeLicenseType = UCase$(LICENSE_TYPE_ALPHA)
    End If

End Function


Private Function NormalizeMachineCode(ByVal machineCode As String) As String

    Dim normalizedText As String
    Dim parts As Variant

    normalizedText = UCase$(Trim$(machineCode))
    normalizedText = Replace(normalizedText, " ", "")

    If Left$(normalizedText, 3) <> "PV-" Then
        normalizedText = "PV-" & normalizedText
    End If

    parts = Split(normalizedText, "-")

    If UBound(parts) = 2 Then
        NormalizeMachineCode = "PV-" & parts(1) & "-" & parts(2)
    Else
        NormalizeMachineCode = normalizedText
    End If

End Function


Private Function BuildLicenseSignature( _
    ByVal licenseType As String, _
    ByVal dateText As String, _
    ByVal machineCode As String _
) As String

    Dim payloadText As String
    Dim secretText As String
    Dim part1 As String
    Dim part2 As String

    payloadText = _
        "PV1|" & _
        NormalizeLicenseType(licenseType) & "|" & _
        dateText & "|" & _
        NormalizeMachineCode(machineCode)

    secretText = GetLicenseSecret()

    part1 = HashTextLicense(payloadText & "|" & secretText)
    part2 = HashTextLicense(secretText & "|" & payloadText)

    BuildLicenseSignature = part1 & part2

End Function


Private Function GetLicenseSecret() As String

    GetLicenseSecret = "PV-" & "Alpha-" & "2026-" & "Sulimov-" & "Brew"

End Function


Private Function HashTextLicense(ByVal sourceText As String) As String

    On Error GoTo ErrorHandler

    Dim i As Long
    Dim hashValue As Double
    Dim charCode As Long

    hashValue = 5381#

    For i = 1 To Len(sourceText)

        charCode = AscW(Mid$(sourceText, i, 1))

        If charCode < 0 Then
            charCode = charCode + 65536
        End If

        hashValue = hashValue * 33# + charCode

        Do While hashValue > 2147483647#
            hashValue = hashValue - 2147483647#
        Loop

    Next i

    HashTextLicense = Right$("00000000" & Hex$(CLng(hashValue)), 8)

    Exit Function

ErrorHandler:

    HashTextLicense = "00000000"

End Function

```

### mAlphaRelease_PersistentMode_Code.bas

**Группа:** `experimental_or_not_adopted`  
**Назначение:** mAlphaRelease PersistentMode — эксперимент с сохранением клиентского режима; пользователь решил пока не применять.  
**SHA256:** `b5c9de65f1aedc52ac4499f32ebc9c3f628773b3fe8aa74c8eb956661b512100`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Модуль: mAlphaRelease
'
' Назначение:
'   Финальная подготовка интерфейса "Пивовар Alpha" перед передачей заказчику.
'
' Версия v2:
'   - режим интерфейса сохраняется в таблицу tAlphaSettings;
'   - при следующем открытии fГлавная режим применяется снова;
'   - служебные кнопки разработчика не появляются обратно после перезапуска.
'
' Важно:
'   Этот модуль не удаляет рабочие данные.
'   Он управляет только режимом интерфейса и проверками поставки.
' ============================================================


Private Const APP_NAME As String = "Пивовар Alpha"

Private Const TABLE_ALPHA_SETTINGS As String = "tAlphaSettings"

Private Const SETTING_UI_MODE As String = "UiMode"

Private Const UI_MODE_DEVELOPER As String = "Developer"
Private Const UI_MODE_CLIENT As String = "Client"


' ============================================================
' Автоприменение сохраненного режима
' ============================================================

Public Sub ApplySavedAlphaUiMode(ByVal targetForm As Form)

    ' Применяет сохраненный режим интерфейса.
    '
    ' Вызывать из Form_Load формы fГлавная.
    '
    ' Если режим еще не задан, считаем базу dev-копией
    ' и показываем служебные кнопки разработчика.

    On Error Resume Next

    Dim uiMode As String

    Call EnsureAlphaSettingsTable

    uiMode = GetAlphaSetting(SETTING_UI_MODE, UI_MODE_DEVELOPER)

    If StrComp(uiMode, UI_MODE_CLIENT, vbTextCompare) = 0 Then

        Call ApplyAlphaClientUiMode(targetForm, False)

    Else

        Call ApplyDeveloperUiMode(targetForm, False)

    End If

End Sub


Public Function GetAlphaUiModeText() As String

    ' Возвращает понятный текст текущего режима интерфейса.

    On Error GoTo ErrorHandler

    Dim uiMode As String

    Call EnsureAlphaSettingsTable

    uiMode = GetAlphaSetting(SETTING_UI_MODE, UI_MODE_DEVELOPER)

    If StrComp(uiMode, UI_MODE_CLIENT, vbTextCompare) = 0 Then
        GetAlphaUiModeText = "Клиентская Alpha"
    Else
        GetAlphaUiModeText = "Режим разработки"
    End If

    Exit Function

ErrorHandler:

    GetAlphaUiModeText = "Не определен"

End Function


' ============================================================
' Клиентский режим / режим разработки
' ============================================================

Public Sub ApplyAlphaClientUiMode( _
    ByVal targetForm As Form, _
    Optional ByVal saveMode As Boolean = True _
)

    ' Скрывает служебные кнопки разработчика на fГлавная.
    '
    ' Оставляет пользователю:
    '   - Проверить лицензию;
    '   - Скопировать код компьютера;
    '   - Ввести лицензионный ключ.
    '
    ' Если saveMode=True, режим сохраняется в tAlphaSettings
    ' и будет применяться после следующего открытия базы.

    On Error Resume Next

    If saveMode Then
        Call SetAlphaSetting(SETTING_UI_MODE, UI_MODE_CLIENT, "Режим интерфейса Alpha")
    End If

    ' Тестовые кнопки лицензии.
    SetControlVisible targetForm, "cmdCreateAlphaTrialLicense", False
    SetControlVisible targetForm, "cmdResetLicense", False

    ' Кнопки управления оболочкой Access.
    SetControlVisible targetForm, "cmdEnableAlphaShell", False
    SetControlVisible targetForm, "cmdEnableAlphaShell_", False

    SetControlVisible targetForm, "cmdEnableAlphaShellStrict", False
    SetControlVisible targetForm, "cmdEnableAlphaShellStrict_", False

    SetControlVisible targetForm, "cmdRestoreDeveloperShell", False
    SetControlVisible targetForm, "cmdRestoreDeveloperShell_", False

    SetControlVisible targetForm, "cmdHideAccessInterface", False
    SetControlVisible targetForm, "cmdHideAccessInterface_", False

    SetControlVisible targetForm, "cmdShowAccessInterface", False
    SetControlVisible targetForm, "cmdShowAccessInterface_", False

    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist", False
    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist_", False

    ' Кнопки подготовки релиза.
    SetControlVisible targetForm, "cmdPrepareAlphaClientCopy", False
    SetControlVisible targetForm, "cmdRestoreDeveloperUi", False
    SetControlVisible targetForm, "cmdShowAlphaReleaseChecklist", False
    SetControlVisible targetForm, "cmdCheckAlphaFolders", False

    ' Клиентские кнопки лицензии оставляем.
    SetControlVisible targetForm, "cmdCheckLicense", True
    SetControlVisible targetForm, "cmdCopyMachineCode", True
    SetControlVisible targetForm, "cmdEnterLicenseKey", True

End Sub


Public Sub ApplyDeveloperUiMode( _
    ByVal targetForm As Form, _
    Optional ByVal saveMode As Boolean = True _
)

    ' Возвращает служебные кнопки разработчика на fГлавная.
    '
    ' Использовать только в dev-копии.

    On Error Resume Next

    If saveMode Then
        Call SetAlphaSetting(SETTING_UI_MODE, UI_MODE_DEVELOPER, "Режим интерфейса Alpha")
    End If

    SetControlVisible targetForm, "cmdCreateAlphaTrialLicense", True
    SetControlVisible targetForm, "cmdResetLicense", True

    SetControlVisible targetForm, "cmdEnableAlphaShell", True
    SetControlVisible targetForm, "cmdEnableAlphaShell_", True

    SetControlVisible targetForm, "cmdEnableAlphaShellStrict", True
    SetControlVisible targetForm, "cmdEnableAlphaShellStrict_", True

    SetControlVisible targetForm, "cmdRestoreDeveloperShell", True
    SetControlVisible targetForm, "cmdRestoreDeveloperShell_", True

    SetControlVisible targetForm, "cmdHideAccessInterface", True
    SetControlVisible targetForm, "cmdHideAccessInterface_", True

    SetControlVisible targetForm, "cmdShowAccessInterface", True
    SetControlVisible targetForm, "cmdShowAccessInterface_", True

    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist", True
    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist_", True

    SetControlVisible targetForm, "cmdPrepareAlphaClientCopy", True
    SetControlVisible targetForm, "cmdRestoreDeveloperUi", True
    SetControlVisible targetForm, "cmdShowAlphaReleaseChecklist", True
    SetControlVisible targetForm, "cmdCheckAlphaFolders", True

    SetControlVisible targetForm, "cmdCheckLicense", True
    SetControlVisible targetForm, "cmdCopyMachineCode", True
    SetControlVisible targetForm, "cmdEnterLicenseKey", True

End Sub


Public Sub PrepareAlphaClientCopy(ByVal targetForm As Form)

    ' Готовит текущую копию интерфейса к передаче заказчику.
    '
    ' Важно:
    '   Делать только на копии, а не на основной dev-базе.

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Подготовить эту копию интерфейса к передаче заказчику?" & vbCrLf & vbCrLf & _
        "Будут скрыты служебные кнопки разработчика на вкладке Настройки." & vbCrLf & _
        "Режим будет сохранен и применится после следующего открытия базы." & vbCrLf & vbCrLf & _
        "Рекомендуется выполнять только на копии базы.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        APP_NAME _
    ) <> vbYes Then
        Exit Sub
    End If

    Call ApplyAlphaClientUiMode(targetForm, True)

    MsgBox "Интерфейс подготовлен к клиентской Alpha-версии." & vbCrLf & vbCrLf & _
           "Режим сохранен: Клиентская Alpha." & vbCrLf & vbCrLf & _
           "Дальше:" & vbCrLf & _
           "1. Отладка -> Компилировать." & vbCrLf & _
           "2. Включить Alpha-режим." & vbCrLf & _
           "3. Закрыть и открыть базу." & vbCrLf & _
           "4. Проверить лицензию." & vbCrLf & _
           "5. Собрать ACCDE.", _
           vbInformation, _
           APP_NAME

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось подготовить клиентскую Alpha-копию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           APP_NAME

End Sub


Public Sub RestoreDeveloperUiOnForm(ByVal targetForm As Form)

    ' Возвращает dev-кнопки на форме.
    '
    ' Использовать только в рабочей dev-копии.

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Вернуть служебные кнопки разработчика на вкладке Настройки?" & vbCrLf & vbCrLf & _
        "Режим будет сохранен как режим разработки.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        APP_NAME _
    ) <> vbYes Then
        Exit Sub
    End If

    Call ApplyDeveloperUiMode(targetForm, True)

    MsgBox "Служебные кнопки разработчика снова отображаются." & vbCrLf & vbCrLf & _
           "Режим сохранен: Режим разработки.", _
           vbInformation, _
           APP_NAME

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось вернуть служебные кнопки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           APP_NAME

End Sub


Public Sub RestoreDeveloperUiGlobal()

    ' Аварийное восстановление dev-режима.
    '
    ' Можно вызвать из Immediate Window:
    '   Call RestoreDeveloperUiGlobal
    '
    ' Использовать, если кнопка восстановления скрыта.

    On Error Resume Next

    Call SetAlphaSetting(SETTING_UI_MODE, UI_MODE_DEVELOPER, "Режим интерфейса Alpha")

    If CurrentProject.AllForms("fГлавная").IsLoaded Then
        Call ApplyDeveloperUiMode(Forms("fГлавная"), False)
    End If

    MsgBox "Режим интерфейса переключен в режим разработки.", _
           vbInformation, _
           APP_NAME

End Sub


' ============================================================
' Проверки перед сборкой
' ============================================================

Public Sub ShowAlphaReleaseChecklist()

    ' Показывает краткий чек-лист перед сборкой ACCDE.

    MsgBox _
        "Чек-лист Alpha-поставки:" & vbCrLf & vbCrLf & _
        "1. Рабочая копия сохранена отдельно от dev-копии." & vbCrLf & _
        "2. Текущий режим интерфейса: " & GetAlphaUiModeText() & "." & vbCrLf & _
        "3. Временные кнопки скрыты в клиентской копии:" & vbCrLf & _
        "   - создать тестовую лицензию;" & vbCrLf & _
        "   - сбросить лицензию;" & vbCrLf & _
        "   - управление оболочкой Access." & vbCrLf & _
        "4. На управляющих кнопках стоит:" & vbCrLf & _
        "   Дополнительные сведения = RequiresLicense." & vbCrLf & _
        "5. Лицензия проверена:" & vbCrLf & _
        "   - без лицензии кнопки блокируются;" & vbCrLf & _
        "   - с ключом кнопки включаются." & vbCrLf & _
        "6. Отчеты проверены." & vbCrLf & _
        "7. Мягкая очистка проверена." & vbCrLf & _
        "8. Alpha-режим включен." & vbCrLf & _
        "9. База открывается сразу с fГлавная." & vbCrLf & _
        "10. Ribbon/область навигации скрыты." & vbCrLf & _
        "11. Выполнено: Отладка -> Компилировать." & vbCrLf & _
        "12. Собран ACCDE." & vbCrLf & _
        "13. Подготовлены папки Templates и Reports.", _
        vbInformation, _
        APP_NAME

End Sub


Public Sub CheckAlphaFolders()

    ' Проверяет наличие папок Templates и Reports рядом с базой.

    On Error GoTo ErrorHandler

    Dim templatesPath As String
    Dim reportsPath As String
    Dim messageText As String

    templatesPath = CurrentProject.Path & "\Templates"
    reportsPath = CurrentProject.Path & "\Reports"

    messageText = ""

    If Dir(templatesPath, vbDirectory) = "" Then
        messageText = messageText & "- Нет папки Templates" & vbCrLf
    End If

    If Dir(reportsPath, vbDirectory) = "" Then
        messageText = messageText & "- Нет папки Reports" & vbCrLf
    End If

    If messageText = "" Then

        MsgBox "Папки Templates и Reports найдены.", _
               vbInformation, _
               APP_NAME

    Else

        MsgBox "Найдены проблемы с папками:" & vbCrLf & vbCrLf & _
               messageText, _
               vbExclamation, _
               APP_NAME

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось проверить папки Alpha-поставки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           APP_NAME

End Sub


' ============================================================
' Таблица настроек Alpha
' ============================================================

Private Sub EnsureAlphaSettingsTable()

    ' Создает таблицу tAlphaSettings, если ее нет.

    On Error GoTo ErrorHandler

    If TableExists(TABLE_ALPHA_SETTINGS) = False Then

        CurrentDb.Execute _
            "CREATE TABLE [" & TABLE_ALPHA_SETTINGS & "] (" & _
            "[Код] AUTOINCREMENT CONSTRAINT [PrimaryKey] PRIMARY KEY, " & _
            "[SettingName] TEXT(100), " & _
            "[SettingValue] LONGTEXT, " & _
            "[UpdatedDate] DATETIME, " & _
            "[Comment] LONGTEXT" & _
            ");", _
            dbFailOnError

        CurrentDb.Execute _
            "CREATE UNIQUE INDEX [ux_tAlphaSettings_SettingName] " & _
            "ON [" & TABLE_ALPHA_SETTINGS & "] ([SettingName]);", _
            dbFailOnError

    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function GetAlphaSetting( _
    ByVal settingName As String, _
    Optional ByVal defaultValue As String = "" _
) As String

    On Error GoTo ErrorHandler

    Call EnsureAlphaSettingsTable

    Dim resultValue As Variant

    resultValue = DLookup("[SettingValue]", TABLE_ALPHA_SETTINGS, "[SettingName] = " & SqlText(settingName))

    If IsNull(resultValue) Then
        GetAlphaSetting = defaultValue
    Else
        GetAlphaSetting = CStr(resultValue)
    End If

    Exit Function

ErrorHandler:

    GetAlphaSetting = defaultValue

End Function


Private Sub SetAlphaSetting( _
    ByVal settingName As String, _
    ByVal settingValue As String, _
    Optional ByVal commentText As String = "" _
)

    On Error GoTo ErrorHandler

    Call EnsureAlphaSettingsTable

    If DCount("*", TABLE_ALPHA_SETTINGS, "[SettingName] = " & SqlText(settingName)) = 0 Then

        CurrentDb.Execute _
            "INSERT INTO [" & TABLE_ALPHA_SETTINGS & "] " & _
            "([SettingName], [SettingValue], [UpdatedDate], [Comment]) " & _
            "VALUES (" & _
            SqlText(settingName) & ", " & _
            SqlText(settingValue) & ", " & _
            SqlDateTime(Now()) & ", " & _
            SqlText(commentText) & _
            ");", _
            dbFailOnError

    Else

        CurrentDb.Execute _
            "UPDATE [" & TABLE_ALPHA_SETTINGS & "] SET " & _
            "[SettingValue] = " & SqlText(settingValue) & ", " & _
            "[UpdatedDate] = " & SqlDateTime(Now()) & ", " & _
            "[Comment] = " & SqlText(commentText) & " " & _
            "WHERE [SettingName] = " & SqlText(settingName) & ";", _
            dbFailOnError

    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


' ============================================================
' Вспомогательные процедуры
' ============================================================

Private Sub SetControlVisible( _
    ByVal targetForm As Form, _
    ByVal controlName As String, _
    ByVal isVisible As Boolean _
)

    ' Безопасно меняет видимость элемента управления.

    On Error Resume Next

    If ControlExistsOnForm(targetForm, controlName) Then
        targetForm.Controls(controlName).Visible = isVisible
    End If

End Sub


Private Function ControlExistsOnForm( _
    ByVal targetForm As Form, _
    ByVal controlName As String _
) As Boolean

    On Error GoTo ErrorHandler

    Dim ctl As Control

    For Each ctl In targetForm.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExistsOnForm = True
            Exit Function
        End If

    Next ctl

    ControlExistsOnForm = False

    Exit Function

ErrorHandler:

    ControlExistsOnForm = False

End Function


Private Function TableExists(ByVal tableName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim tdf As DAO.TableDef

    For Each tdf In CurrentDb.TableDefs

        If StrComp(tdf.Name, tableName, vbTextCompare) = 0 Then
            TableExists = True
            Exit Function
        End If

    Next tdf

    TableExists = False

    Exit Function

ErrorHandler:

    TableExists = False

End Function


Private Function SqlText(ByVal sourceValue As Variant) As String

    If IsNull(sourceValue) Then
        SqlText = "Null"
    Else
        SqlText = "'" & Replace(CStr(sourceValue), "'", "''") & "'"
    End If

End Function


Private Function SqlDateTime(ByVal sourceDate As Date) As String

    SqlDateTime = "#" & Format$(sourceDate, "yyyy\/mm\/dd hh\:nn\:ss") & "#"

End Function

```

### fMain_Final_AlphaRelease_PersistentMode_Code.bas

**Группа:** `experimental_or_not_adopted`  
**Назначение:** fГлавная PersistentMode — экспериментальная версия; не обязательна для первого показа.  
**SHA256:** `85381cc53bb45a44ee9298b6643f04f920ac60322ef2da70a596f4dcf9cf0bbd`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Форма: fГлавная
'
' Назначение:
'   Главная форма приложения "Пивовар".
'
' В этом коде:
'   - открытие общих журналов;
'   - мягкая очистка рабочих данных;
'   - автоматическое обновление встроенных рабочих форм:
'       fВарка;
'       fЦКТ_Панель;
'       fФорфас_Панель.
'
' Текущие имена элементов подчиненных форм на fГлавная:
'   subBrew
'   subCctPanel
'   subForfasPanel
'
' Текущее имя набора вкладок:
'   НаборВкладок0
'
' Рабочие вкладки:
'   Варка
'   ЦКТ
'   Форфасы
'
' Важно:
'   Имена SUBFORM_* должны совпадать именно с именами элементов
'   подчиненных форм на fГлавная, а не только с объектами-источниками.
' ============================================================


Private Const SUBFORM_BREW As String = "subBrew"
Private Const SUBFORM_CCT_PANEL As String = "subCctPanel"
Private Const SUBFORM_FORFAS_PANEL As String = "subForfasPanel"

Private Const MAIN_TAB_CONTROL As String = "НаборВкладок0"

Private Const TAB_BREW As String = "Варка"
Private Const TAB_CCT As String = "ЦКТ"
Private Const TAB_FORFAS As String = "Форфасы"
Private Const TAB_SETTINGS As String = "Настройки"

Private mLastMainAutoRefresh As Date
Private mShellHideRetryCount As Long


' ============================================================
' Alpha-оболочка Access / вкладка "Настройки"
'
' Поддерживаются имена кнопок как без хвостового "_",
' так и с хвостовым "_", потому что Access в этом случае
' создает обработчик с двойным "__Click".
' ============================================================

Private Sub cmdEnableAlphaShell_Click()
    Call DoEnableAlphaShell
End Sub

Private Sub cmdEnableAlphaShell__Click()
    Call DoEnableAlphaShell
End Sub

Private Sub cmdEnableAlphaShellStrict_Click()
    Call DoEnableAlphaShellStrict
End Sub

Private Sub cmdEnableAlphaShellStrict__Click()
    Call DoEnableAlphaShellStrict
End Sub

Private Sub cmdRestoreDeveloperShell_Click()
    Call DoRestoreDeveloperShell
End Sub

Private Sub cmdRestoreDeveloperShell__Click()
    Call DoRestoreDeveloperShell
End Sub

Private Sub cmdHideAccessInterface_Click()
    Call DoHideAccessInterface
End Sub

Private Sub cmdHideAccessInterface__Click()
    Call DoHideAccessInterface
End Sub

Private Sub cmdShowAccessInterface_Click()
    Call DoShowAccessInterface
End Sub

Private Sub cmdShowAccessInterface__Click()
    Call DoShowAccessInterface
End Sub

Private Sub cmdShowAlphaPackagingChecklist_Click()
    Call DoShowAlphaPackagingChecklist
End Sub

Private Sub cmdShowAlphaPackagingChecklist__Click()
    Call DoShowAlphaPackagingChecklist
End Sub


Private Sub DoEnableAlphaShell()

    Call ConfigurePivovarAlphaShell

End Sub


Private Sub DoEnableAlphaShellStrict()

    Call ConfigurePivovarAlphaShellStrict

End Sub


Private Sub DoRestoreDeveloperShell()

    Call RestorePivovarDeveloperShell

End Sub


Private Sub DoHideAccessInterface()

    Call HideAccessInterface

End Sub


Private Sub DoShowAccessInterface()

    Call ShowAccessInterface

End Sub


Private Sub DoShowAlphaPackagingChecklist()

    Call PreparePivovarAlphaAccdeChecklist

End Sub



' ============================================================
' Загрузка, активация и переключение вкладок
' ============================================================

Private Sub Form_Load()

    ' При открытии главной формы:
    '   1. инициализируем лицензионный блок;
    '   2. скрываем стандартный интерфейс Access;
    '   3. включаем отложенное повторное скрытие интерфейса;
    '   4. обновляем поля лицензии;
    '   5. применяем сохраненный режим Alpha-интерфейса;
    '   6. привязываем событие вкладок;
    '   7. обновляем активную вкладку.

    Call InitializeLicenseSystem
    Call HideAccessInterface
    Call StartDelayedAccessInterfaceHide

    Call RefreshLicenseControls
    Call ApplySavedAlphaUiMode(Me)

    Call WireMainFormEvents
    Call RefreshSelectedMainTab("Form_Load")

End Sub

Private Sub Form_Activate()

    ' При возврате на главную форму после операций / журналов
    ' обновляем только текущую активную вкладку.
    '
    ' Дополнительно повторно скрываем интерфейс Access.
    ' Это защищает от ситуаций, когда Ribbon снова появляется
    ' после открытия/закрытия других окон Access.

    Call HideAccessInterface

    If DateDiff("s", mLastMainAutoRefresh, Now) < 1 Then
        Exit Sub
    End If

    mLastMainAutoRefresh = Now

    Call RefreshSelectedMainTab("Form_Activate")

End Sub

Private Sub НаборВкладок0_Change()

    ' Событие набора вкладок.
    '
    ' В свойствах элемента НаборВкладок0 должно быть:
    '   При изменении = [Процедура обработки событий]
    '
    ' При смене вкладки сбрасываем защиту от частого обновления,
    ' потому что это явное действие пользователя.

    mLastMainAutoRefresh = 0

    DoEvents

    Call RefreshSelectedMainTab("Tab_Change")

End Sub


Private Sub WireMainFormEvents()

    ' Принудительно привязывает событие смены вкладки.
    '
    ' В русской версии Access в свойствах будет отображаться:
    '   При изменении = [Процедура обработки событий]
    '
    ' В VBA нужно использовать английское значение:
    '   [Event Procedure]

    On Error Resume Next

    If ControlExists(MAIN_TAB_CONTROL) Then
        Me.Controls(MAIN_TAB_CONTROL).OnChange = "[Event Procedure]"
    End If

End Sub



Private Sub Form_Timer()

    ' Отложенное повторное скрытие стандартного интерфейса Access.
    '
    ' Нужен именно при автозапуске базы:
    ' Access может показать Ribbon уже после Form_Load формы fГлавная.
    '
    ' Делаем несколько повторов, затем выключаем таймер.

    On Error Resume Next

    mShellHideRetryCount = mShellHideRetryCount + 1

    Call HideAccessInterface

    If mShellHideRetryCount >= 6 Then
        Me.TimerInterval = 0
    End If

End Sub


Private Sub StartDelayedAccessInterfaceHide()

    ' Запускает короткий одноразово-многоразовый таймер скрытия интерфейса.
    '
    ' 6 повторов по 300 мс обычно достаточно, чтобы Access успел
    ' полностью загрузить интерфейс и после этого Ribbon был скрыт.

    On Error Resume Next

    mShellHideRetryCount = 0
    Me.TimerInterval = 300

End Sub


' ============================================================
' Открытие общих журналов
' ============================================================

Private Sub cmdOpenBatchCheckJournal_Click()

    Call OpenFormSafe("fЖурнал_СверкаПартий")

End Sub


Private Sub cmdOpenFillingJournal_Click()

    Call OpenFormSafe("fЖурнал_Розлив")

End Sub


Private Sub cmdOpenFiltrationLossesJournal_Click()

    Call OpenFormSafe("fЖурнал_ФильтрацияПотери")

End Sub


Private Sub cmdOpenProductMovementJournal_Click()

    Call OpenFormSafe("fЖурнал_ДвижениеПродукта")

End Sub


Private Sub OpenFormSafe(ByVal formName As String)

    ' Безопасно открывает форму.
    '
    ' Если форма уже открыта — переводит на нее фокус.

    On Error GoTo ErrorHandler

    If CurrentProject.AllForms(formName).IsLoaded Then

        DoCmd.SelectObject acForm, formName, False
        Forms(formName).SetFocus

    Else

        DoCmd.OpenForm formName, acNormal

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось открыть форму:" & vbCrLf & _
           formName & vbCrLf & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           "Открытие формы"

End Sub


' ============================================================
' Мягкая очистка рабочих данных
' ============================================================

Private Sub cmdSoftClearDatabase_Click()

    ' Мягкая очистка рабочих данных:
    '   - варки;
    '   - отправки Варка - ЦКТ;
    '   - движения по емкостям;
    '   - текущее состояние емкостей.
    '
    ' Справочники не удаляются.
    '
    ' После очистки обновляем все встроенные рабочие формы.

    On Error GoTo ErrorHandler

    Call SoftClearWorkingData
    Call RefreshEmbeddedWorkingForms

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось выполнить мягкую очистку рабочих данных." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbCritical, _
           "Мягкая очистка"

End Sub


Private Sub cmdRefreshAll_Click()

    ' Ручное обновление всех встроенных рабочих форм.
    '
    ' Кнопка необязательная.
    ' Ее можно оставить на вкладке "Настройки" как служебную.

    Call RefreshEmbeddedWorkingForms

End Sub


' ============================================================
' Автообновление встроенных рабочих форм
' ============================================================

Public Sub RefreshEmbeddedWorkingForms()

    ' Полное обновление встроенных рабочих форм:
    '   - fВарка;
    '   - fЦКТ_Панель;
    '   - fФорфас_Панель.
    '
    ' После обновления заново применяем лицензионный режим,
    ' чтобы кнопки внутри подформ не включались случайно после Requery.

    Debug.Print "RefreshEmbeddedWorkingForms:", Now()

    Call RefreshBrewPanel
    Call RefreshCctPanelEmbedded
    Call RefreshForfasPanelEmbedded

    Call ApplyLicenseToForm(Me)

End Sub

Private Sub RefreshSelectedMainTab(Optional ByVal reason As String = "")

    ' Обновляет только активную рабочую вкладку.
    '
    ' Проверяем и Caption, и Name страницы вкладок,
    ' чтобы не зависеть от того, где именно задано:
    '   Варка
    '   ЦКТ
    '   Форфасы
    '   Настройки
    '
    ' После обновления активной вкладки повторно применяем лицензионный режим.
    ' Это важно для кнопок внутри подформ.

    On Error GoTo ErrorHandler

    Dim tabControl As Object
    Dim currentCaption As String
    Dim currentName As String

    If ControlExists(MAIN_TAB_CONTROL) = False Then
        Debug.Print "Не найден набор вкладок: " & MAIN_TAB_CONTROL
        Exit Sub
    End If

    Set tabControl = Me.Controls(MAIN_TAB_CONTROL)

    If GetCurrentTabPageInfo(tabControl, currentName, currentCaption) = False Then
        Debug.Print "Не удалось определить активную вкладку."
        Exit Sub
    End If

    Debug.Print "Активная вкладка:", _
                "Name=[" & currentName & "]", _
                "Caption=[" & currentCaption & "]", _
                "Reason=[" & reason & "]", _
                Now()

    If IsTabPage(currentName, currentCaption, TAB_BREW) Then

        Call RefreshBrewPanel

    ElseIf IsTabPage(currentName, currentCaption, TAB_CCT) Then

        Call RefreshCctPanelEmbedded

    ElseIf IsTabPage(currentName, currentCaption, TAB_FORFAS) Then

        Call RefreshForfasPanelEmbedded

    ElseIf IsTabPage(currentName, currentCaption, TAB_SETTINGS) Then

        Call RefreshLicenseControls

    Else

        ' Для вкладок "Общие журналы", "Отчеты", "Справочники",
        ' "О программе" автоматическое обновление рабочих форм не требуется.

    End If

    Call ApplyLicenseToForm(Me)

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка автообновления активной вкладки fГлавная: " & Err.Description

End Sub

Private Function GetCurrentTabPageInfo( _
    ByVal tabControl As Object, _
    ByRef pageName As String, _
    ByRef pageCaption As String _
) As Boolean

    ' Возвращает имя и подпись активной страницы набора вкладок.
    '
    ' Не полагаемся только на Pages(tabControl.Value), потому что
    ' в Access значение вкладки может быть связано с PageIndex.
    ' Поэтому дополнительно перебираем Pages.

    On Error GoTo ErrorHandler

    Dim pageItem As Object

    pageName = ""
    pageCaption = ""

    For Each pageItem In tabControl.Pages

        If CLng(pageItem.PageIndex) = CLng(tabControl.value) Then

            pageName = Nz(pageItem.Name, "")
            pageCaption = Nz(pageItem.Caption, "")

            GetCurrentTabPageInfo = True
            Exit Function

        End If

    Next pageItem

    ' Запасной вариант.
    pageName = Nz(tabControl.Pages(tabControl.value).Name, "")
    pageCaption = Nz(tabControl.Pages(tabControl.value).Caption, "")

    GetCurrentTabPageInfo = True

    Exit Function

ErrorHandler:

    GetCurrentTabPageInfo = False

End Function


Private Function IsTabPage( _
    ByVal pageName As String, _
    ByVal pageCaption As String, _
    ByVal expectedText As String _
) As Boolean

    ' Проверяет страницу вкладок по имени и подписи.
    '
    ' Сравнение сделано не только точным, но и через InStr,
    ' чтобы не ломаться от случайных пробелов или значков в подписи.

    Dim normalizedName As String
    Dim normalizedCaption As String
    Dim normalizedExpected As String

    normalizedName = NormalizeTabText(pageName)
    normalizedCaption = NormalizeTabText(pageCaption)
    normalizedExpected = NormalizeTabText(expectedText)

    If StrComp(normalizedName, normalizedExpected, vbTextCompare) = 0 Then
        IsTabPage = True
        Exit Function
    End If

    If StrComp(normalizedCaption, normalizedExpected, vbTextCompare) = 0 Then
        IsTabPage = True
        Exit Function
    End If

    If InStr(1, normalizedName, normalizedExpected, vbTextCompare) > 0 Then
        IsTabPage = True
        Exit Function
    End If

    If InStr(1, normalizedCaption, normalizedExpected, vbTextCompare) > 0 Then
        IsTabPage = True
        Exit Function
    End If

    IsTabPage = False

End Function


Private Function NormalizeTabText(ByVal sourceText As String) As String

    ' Нормализует текст вкладки для сравнения.

    Dim resultText As String

    resultText = Nz(sourceText, "")
    resultText = Replace(resultText, Chr$(160), " ")
    resultText = Trim$(resultText)

    NormalizeTabText = resultText

End Function


Private Sub RefreshBrewPanel()

    ' Обновляет встроенную форму Варка.
    '
    ' Для fВарка нельзя ограничиваться обычным Requery:
    ' в режиме подформы это может вернуть форму на первую запись.
    '
    ' Поэтому вызываем Public Sub RefreshPanel внутри fВарка,
    ' а там уже выполняется переход на последнюю варку.

    Call RefreshEmbeddedForm(SUBFORM_BREW, "RefreshPanel")

End Sub

Private Sub RefreshCctPanelEmbedded()

    ' Обновляет встроенную панель ЦКТ.
    '
    ' На форме fЦКТ_Панель должна быть процедура:
    '   Public Sub RefreshCctPanel()

    Call RefreshEmbeddedForm(SUBFORM_CCT_PANEL, "RefreshCctPanel")

End Sub


Private Sub RefreshForfasPanelEmbedded()

    ' Обновляет встроенную панель форфасов.
    '
    ' На форме fФорфас_Панель должна быть процедура:
    '   Public Sub RefreshForfasPanel()

    Call RefreshEmbeddedForm(SUBFORM_FORFAS_PANEL, "RefreshForfasPanel")

End Sub


Private Sub RefreshEmbeddedForm( _
    ByVal subformControlName As String, _
    ByVal refreshMethodName As String _
)

    ' Безопасно обновляет подчиненную форму.
    '
    ' Если refreshMethodName указан:
    '   1. пытаемся вызвать эту публичную процедуру внутри подформы;
    '   2. если не получилось — пытаемся вызвать универсальный RefreshPanel;
    '   3. если не получилось — выполняем стандартный Requery/Refresh.
    '
    ' Важно:
    '   После успешного вызова специального метода НЕ делаем дополнительный
    '   Requery из fГлавная.
    '
    ' Причина:
    '   Для fВарка метод RefreshPanel сам делает Requery и переходит
    '   на последнюю запись. Если после этого fГлавная снова выполнит
    '   Requery, подформа может вернуться на первую запись.

    On Error GoTo ErrorHandler

    If ControlExists(subformControlName) = False Then
        Debug.Print "Не найден элемент подчиненной формы: " & subformControlName
        Exit Sub
    End If

    If Nz(Me.Controls(subformControlName).SourceObject, "") = "" Then
        Debug.Print "У элемента подчиненной формы не задан SourceObject: " & subformControlName
        Exit Sub
    End If

    Debug.Print "Обновление подчиненной формы:", subformControlName, _
                "Method=[" & refreshMethodName & "]", _
                Now()

    If Len(refreshMethodName) > 0 Then

        If TryCallSubformMethod(subformControlName, refreshMethodName) Then
            Exit Sub
        Else
            Debug.Print "Не удалось вызвать метод " & refreshMethodName & _
                        " у подчиненной формы " & subformControlName
        End If

    End If

    If TryCallSubformMethod(subformControlName, "RefreshPanel") Then
        Exit Sub
    End If

    Call RequerySubform(subformControlName)

    Exit Sub

ErrorHandler:

    Debug.Print "Ошибка обновления подчиненной формы " & subformControlName & ": " & Err.Description

End Sub

Private Function TryCallSubformMethod( _
    ByVal subformControlName As String, _
    ByVal methodName As String _
) As Boolean

    ' Пытается вызвать публичный метод внутри подчиненной формы.

    On Error GoTo ErrorHandler

    Err.Clear

    CallByName Me.Controls(subformControlName).Form, methodName, VbMethod

    TryCallSubformMethod = True

    Exit Function

ErrorHandler:

    Debug.Print "CallByName не выполнил " & methodName & _
                " для " & subformControlName & _
                ". Ошибка: " & Err.Description

    TryCallSubformMethod = False

End Function


Private Sub RequerySubform(ByVal subformControlName As String)

    ' Выполняет стандартное обновление подчиненной формы.

    On Error Resume Next

    Me.Controls(subformControlName).Form.Requery
    Me.Controls(subformControlName).Form.Refresh
    Me.Controls(subformControlName).Form.Recalc
    Me.Controls(subformControlName).Form.Repaint

End Sub



' ============================================================
' Лицензия / вкладка "Настройки"

' ============================================================
' Alpha-оболочка Access / вкладка "Настройки"
' ============================================================

' ============================================================

Private Sub RefreshLicenseControls()

    ' Обновляет поля лицензионного блока на вкладке "Настройки"
    ' и применяет режим доступа к кнопкам с Tag = RequiresLicense.

    On Error Resume Next

    Call RefreshLicenseInfoOnForm(Me)
    Call ApplyLicenseToForm(Me)

End Sub

Private Sub cmdCheckLicense_Click()

    ' Проверяет лицензию, обновляет поля на форме
    ' и применяет режим доступа к открытым формам.

    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

    MsgBox "Проверка лицензии выполнена." & vbCrLf & vbCrLf & _
           "Статус: " & GetLicenseStatusText(), _
           vbInformation, _
           "Лицензия"

End Sub

Private Sub cmdCopyMachineCode_Click()

    ' Копирует код компьютера в буфер обмена.

    Call CopyMachineCodeToClipboard
    Call RefreshLicenseControls

End Sub


Private Sub cmdEnterLicenseKey_Click()

    ' Заготовка для будущего ввода лицензионного ключа.
    '
    ' На следующем этапе сюда подключим реальную проверку ключа,
    ' сохранение лицензии и повторное применение режима доступа.

    Call EnterLicenseKeyPlaceholder
    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

End Sub

Private Sub cmdCreateAlphaTrialLicense_Click()

    ' Временная тестовая кнопка.
    '
    ' Создает локальную Alpha-лицензию на 60 дней
    ' для проверки интерфейса и логики статуса.
    '
    ' Перед передачей заказчику эту кнопку нужно скрыть или удалить.

    Call CreateAlphaTrialLicense
    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

End Sub


Private Sub cmdResetLicense_Click()

    ' Временная служебная кнопка для тестов.
    '
    ' Сбрасывает активную лицензию и повторно применяет блокировку
    ' кнопок с Tag = RequiresLicense.
    '
    ' Перед передачей заказчику эту кнопку нужно скрыть или удалить.

    If MsgBox("Сбросить активную лицензию для теста?", _
              vbQuestion + vbYesNo + vbDefaultButton2, _
              "Сброс лицензии") <> vbYes Then
        Exit Sub
    End If

    Call ResetActiveLicenseForDebug(False)

    Call RefreshLicenseControls
    Call ApplyLicenseToOpenForms

    MsgBox "Лицензия сброшена." & vbCrLf & _
           "Управляющие кнопки должны перейти в заблокированное состояние.", _
           vbInformation, _
           "Сброс лицензии"

End Sub


' ============================================================
' Подготовка клиентской Alpha-копии / вкладка "Настройки"
' ============================================================

Private Sub cmdPrepareAlphaClientCopy_Click()

    ' Скрывает служебные кнопки разработчика и оставляет
    ' только клиентские элементы лицензии.
    '
    ' Требуется стандартный модуль:
    '   mAlphaRelease

    Call PrepareAlphaClientCopy(Me)

End Sub


Private Sub cmdRestoreDeveloperUi_Click()

    ' Возвращает служебные кнопки разработчика на вкладку "Настройки".
    '
    ' Использовать только в dev-копии.

    Call RestoreDeveloperUiOnForm(Me)

End Sub


Private Sub cmdShowAlphaReleaseChecklist_Click()

    ' Показывает чек-лист перед сборкой клиентской Alpha-версии.

    Call ShowAlphaReleaseChecklist

End Sub


Private Sub cmdCheckAlphaFolders_Click()

    ' Проверяет наличие папок Templates и Reports рядом с базой.

    Call CheckAlphaFolders

End Sub

' ============================================================
' Вспомогательные процедуры
' ============================================================

Private Function ControlExists(ByVal controlName As String) As Boolean

    ' Проверяет наличие элемента управления на форме.
    '
    ' Используем перебор с Trim, чтобы случайный пробел
    ' в имени элемента не ломал проверку.

    On Error GoTo ErrorHandler

    Dim ctl As Access.Control

    For Each ctl In Me.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExists = True
            Exit Function
        End If

    Next ctl

    ControlExists = False

    Exit Function

ErrorHandler:

    ControlExists = False

End Function


Private Sub cmdCloseApplication_Click()

    ' Закрывает приложение.
    '
    ' Кнопка необязательная.
    ' Если на форме нет cmdCloseApplication, процедура не используется.

    DoCmd.Quit acQuitSaveAll

End Sub






```

### mAlphaRelease_Code.bas

**Группа:** `experimental_or_not_adopted`  
**Назначение:** mAlphaRelease базовый — утилиты подготовки Alpha-копии; можно не использовать, если опасные кнопки удаляются вручную.  
**SHA256:** `ce9309e5cb7e4bc8b290cf81b64e001bf09f5cd0f958919cfc176f7d9dd5e57f`

```vb
Option Compare Database
Option Explicit

' ============================================================
' Модуль: mAlphaRelease
'
' Назначение:
'   Финальная подготовка интерфейса "Пивовар Alpha" перед передачей заказчику.
'
' Что делает:
'   - скрывает временные/служебные кнопки разработчика;
'   - оставляет пользователю только нужные кнопки лицензии;
'   - позволяет вернуть служебные кнопки в dev-копии;
'   - проверяет наличие критичных таблиц/модулей/папок;
'   - показывает чек-лист перед сборкой ACCDE.
'
' Важно:
'   Этот модуль безопасен: он не удаляет данные.
'   Он работает только с видимостью элементов интерфейса и проверками.
' ============================================================


Private Const APP_NAME As String = "Пивовар Alpha"


' ============================================================
' Клиентский режим / режим разработки
' ============================================================

Public Sub ApplyAlphaClientUiMode(ByVal targetForm As Form)

    ' Скрывает служебные кнопки разработчика на fГлавная.
    '
    ' Оставляет пользователю:
    '   - Проверить лицензию;
    '   - Скопировать код компьютера;
    '   - Ввести лицензионный ключ.
    '
    ' Скрывает:
    '   - создание тестовой Alpha-лицензии;
    '   - сброс лицензии;
    '   - управление Access-оболочкой;
    '   - возврат режима разработки;
    '   - показ интерфейса Access.

    On Error Resume Next

    ' Тестовые кнопки лицензии.
    SetControlVisible targetForm, "cmdCreateAlphaTrialLicense", False
    SetControlVisible targetForm, "cmdResetLicense", False

    ' Кнопки управления оболочкой Access.
    SetControlVisible targetForm, "cmdEnableAlphaShell", False
    SetControlVisible targetForm, "cmdEnableAlphaShell_", False

    SetControlVisible targetForm, "cmdEnableAlphaShellStrict", False
    SetControlVisible targetForm, "cmdEnableAlphaShellStrict_", False

    SetControlVisible targetForm, "cmdRestoreDeveloperShell", False
    SetControlVisible targetForm, "cmdRestoreDeveloperShell_", False

    SetControlVisible targetForm, "cmdHideAccessInterface", False
    SetControlVisible targetForm, "cmdHideAccessInterface_", False

    SetControlVisible targetForm, "cmdShowAccessInterface", False
    SetControlVisible targetForm, "cmdShowAccessInterface_", False

    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist", False
    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist_", False

    ' Клиентские кнопки лицензии оставляем.
    SetControlVisible targetForm, "cmdCheckLicense", True
    SetControlVisible targetForm, "cmdCopyMachineCode", True
    SetControlVisible targetForm, "cmdEnterLicenseKey", True

End Sub


Public Sub ApplyDeveloperUiMode(ByVal targetForm As Form)

    ' Возвращает служебные кнопки разработчика на fГлавная.
    '
    ' Использовать только в dev-копии.

    On Error Resume Next

    SetControlVisible targetForm, "cmdCreateAlphaTrialLicense", True
    SetControlVisible targetForm, "cmdResetLicense", True

    SetControlVisible targetForm, "cmdEnableAlphaShell", True
    SetControlVisible targetForm, "cmdEnableAlphaShell_", True

    SetControlVisible targetForm, "cmdEnableAlphaShellStrict", True
    SetControlVisible targetForm, "cmdEnableAlphaShellStrict_", True

    SetControlVisible targetForm, "cmdRestoreDeveloperShell", True
    SetControlVisible targetForm, "cmdRestoreDeveloperShell_", True

    SetControlVisible targetForm, "cmdHideAccessInterface", True
    SetControlVisible targetForm, "cmdHideAccessInterface_", True

    SetControlVisible targetForm, "cmdShowAccessInterface", True
    SetControlVisible targetForm, "cmdShowAccessInterface_", True

    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist", True
    SetControlVisible targetForm, "cmdShowAlphaPackagingChecklist_", True

    SetControlVisible targetForm, "cmdCheckLicense", True
    SetControlVisible targetForm, "cmdCopyMachineCode", True
    SetControlVisible targetForm, "cmdEnterLicenseKey", True

End Sub


Public Sub PrepareAlphaClientCopy(ByVal targetForm As Form)

    ' Готовит текущую копию интерфейса к передаче заказчику.
    '
    ' Важно:
    '   Делать только на копии, а не на основной dev-базе.

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Подготовить эту копию интерфейса к передаче заказчику?" & vbCrLf & vbCrLf & _
        "Будут скрыты служебные кнопки разработчика на вкладке Настройки." & vbCrLf & _
        "Данные и таблицы не изменяются." & vbCrLf & vbCrLf & _
        "Рекомендуется выполнять только на копии базы.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        APP_NAME _
    ) <> vbYes Then
        Exit Sub
    End If

    Call ApplyAlphaClientUiMode(targetForm)

    MsgBox "Интерфейс подготовлен к клиентской Alpha-версии." & vbCrLf & vbCrLf & _
           "Дальше:" & vbCrLf & _
           "1. Отладка -> Компилировать." & vbCrLf & _
           "2. Включить Alpha-режим." & vbCrLf & _
           "3. Закрыть и открыть базу." & vbCrLf & _
           "4. Проверить лицензию." & vbCrLf & _
           "5. Собрать ACCDE.", _
           vbInformation, _
           APP_NAME

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось подготовить клиентскую Alpha-копию." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           APP_NAME

End Sub


Public Sub RestoreDeveloperUiOnForm(ByVal targetForm As Form)

    ' Возвращает dev-кнопки на форме.
    '
    ' Использовать только в рабочей dev-копии.

    On Error GoTo ErrorHandler

    If MsgBox( _
        "Вернуть служебные кнопки разработчика на вкладке Настройки?", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        APP_NAME _
    ) <> vbYes Then
        Exit Sub
    End If

    Call ApplyDeveloperUiMode(targetForm)

    MsgBox "Служебные кнопки разработчика снова отображаются.", _
           vbInformation, _
           APP_NAME

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось вернуть служебные кнопки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           APP_NAME

End Sub


' ============================================================
' Проверки перед сборкой
' ============================================================

Public Sub ShowAlphaReleaseChecklist()

    ' Показывает краткий чек-лист перед сборкой ACCDE.

    MsgBox _
        "Чек-лист Alpha-поставки:" & vbCrLf & vbCrLf & _
        "1. Рабочая копия сохранена отдельно от dev-копии." & vbCrLf & _
        "2. Временные кнопки скрыты:" & vbCrLf & _
        "   - создать тестовую лицензию;" & vbCrLf & _
        "   - сбросить лицензию;" & vbCrLf & _
        "   - управление оболочкой Access." & vbCrLf & _
        "3. На управляющих кнопках стоит:" & vbCrLf & _
        "   Дополнительные сведения = RequiresLicense." & vbCrLf & _
        "4. Лицензия проверена:" & vbCrLf & _
        "   - без лицензии кнопки блокируются;" & vbCrLf & _
        "   - с ключом кнопки включаются." & vbCrLf & _
        "5. Отчеты проверены." & vbCrLf & _
        "6. Мягкая очистка проверена." & vbCrLf & _
        "7. Alpha-режим включен." & vbCrLf & _
        "8. База открывается сразу с fГлавная." & vbCrLf & _
        "9. Ribbon/область навигации скрыты." & vbCrLf & _
        "10. Выполнено: Отладка -> Компилировать." & vbCrLf & _
        "11. Собран ACCDE." & vbCrLf & _
        "12. Подготовлены папки Templates и Reports.", _
        vbInformation, _
        APP_NAME

End Sub


Public Sub CheckAlphaFolders()

    ' Проверяет наличие папок Templates и Reports рядом с базой.

    On Error GoTo ErrorHandler

    Dim templatesPath As String
    Dim reportsPath As String
    Dim messageText As String

    templatesPath = CurrentProject.Path & "\Templates"
    reportsPath = CurrentProject.Path & "\Reports"

    messageText = ""

    If Dir(templatesPath, vbDirectory) = "" Then
        messageText = messageText & "- Нет папки Templates" & vbCrLf
    End If

    If Dir(reportsPath, vbDirectory) = "" Then
        messageText = messageText & "- Нет папки Reports" & vbCrLf
    End If

    If messageText = "" Then

        MsgBox "Папки Templates и Reports найдены.", _
               vbInformation, _
               APP_NAME

    Else

        MsgBox "Найдены проблемы с папками:" & vbCrLf & vbCrLf & _
               messageText, _
               vbExclamation, _
               APP_NAME

    End If

    Exit Sub

ErrorHandler:

    MsgBox "Не удалось проверить папки Alpha-поставки." & vbCrLf & _
           "Ошибка: " & Err.Description, _
           vbExclamation, _
           APP_NAME

End Sub


' ============================================================
' Вспомогательные процедуры
' ============================================================

Private Sub SetControlVisible( _
    ByVal targetForm As Form, _
    ByVal controlName As String, _
    ByVal isVisible As Boolean _
)

    ' Безопасно меняет видимость элемента управления.

    On Error Resume Next

    If ControlExistsOnForm(targetForm, controlName) Then
        targetForm.Controls(controlName).Visible = isVisible
    End If

End Sub


Private Function ControlExistsOnForm( _
    ByVal targetForm As Form, _
    ByVal controlName As String _
) As Boolean

    On Error GoTo ErrorHandler

    Dim ctl As Control

    For Each ctl In targetForm.Controls

        If StrComp(Trim$(ctl.Name), Trim$(controlName), vbTextCompare) = 0 Then
            ControlExistsOnForm = True
            Exit Function
        End If

    Next ctl

    ControlExistsOnForm = False

    Exit Function

ErrorHandler:

    ControlExistsOnForm = False

End Function

```
