---

'== Модуль: UserForm1 (форма пустая, элементы строит код) — вставьте как ВЕСЬ код модуля (Ctrl+A, затем вставка). ==
Option Explicit

' --- Win32 API: держать форму поверх всех окон при скрытом Excel (Excel 2007, 32-бит) ---
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST As Long = -1
Private Const HWND_NOTOPMOST As Long = -2
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1

Private mH As Collection
Private mHooked As Object          ' п.4 — имена элементов, уже подписанных на события
Private mBusy As Boolean
Private mOrder() As String
Private mNArea As Long
Private mNCommon As Long
Private mRowsC As Long
Private mFlacons() As String
Private mPays() As String

Private Const RARE_LIST As String = "легкие/средостение|сердце|молочная железа|голова-шея|прочее"
Private Const YLOW_HIDDEN As Single = 270
Private Const YLOW_SHOWN As Single = 354      ' контраст стал чуть выше (заголовок флаконов)
Private Const MAX_FORM_H As Single = 620       ' выше окно не растёт (редкие области — с прокруткой)

Private txtNumber As MSForms.TextBox
Private txtStudyDate As MSForms.TextBox
Private PatientName As MSForms.TextBox
Private DoB As MSForms.TextBox
Private cboDept As MSForms.ComboBox
Private History_number As MSForms.TextBox
Private txtArea As MSForms.TextBox
Private optAnestYes As MSForms.OptionButton
Private optAnestNo As MSForms.OptionButton
Private optContrastYes As MSForms.OptionButton
Private optContrastNo As MSForms.OptionButton
Private cboContrast As MSForms.ComboBox
Private txtDose As MSForms.TextBox
Private cboPerf As MSForms.ComboBox
Private chkRare As MSForms.CheckBox
Private frContrast As MSForms.Frame
Private frStudies As MSForms.Frame
Private frPay As MSForms.Frame
Private lblWarn As MSForms.Label
Private btnMain As MSForms.CommandButton
Private btnDelete As MSForms.CommandButton
Private btnCancelPat As MSForms.CommandButton
Private btnSettings As MSForms.CommandButton
Private btnExport As MSForms.CommandButton
Private btnDiscBurn As MSForms.CommandButton   ' крупная кнопка «Записать диск» (в обоих режимах окна)
Private btnImport As MSForms.CommandButton     ' «Выгрузить пациента» из другого журнала (включается в Настройках)
Private lblPerfHead As MSForms.Label           ' надпись «Исполнитель» (сдвигается, когда есть btnImport)
Private mEdit As Boolean                       ' окно в режиме редактирования записи

Private Const fmDDL As Integer = 2
Private Const FS As Single = 9                ' базовый размер шрифта (п.6 — крупнее)

Private Sub UserForm_Initialize()
    Set mH = New Collection
    Set mHooked = CreateObject("Scripting.Dictionary")
    ReadArrays
    BuildForm
    If CurrentRow > 0 And Not gEditSheet Is Nothing Then FillData Else ResetNew
End Sub

Private Sub ReadArrays()
    Dim a As Variant, i As Long, common() As String, rare() As String, nc As Long, nr As Long
    a = GetList("области")
    mFlacons = ToStrArray(GetList("флаконы"))
    mPays = ToStrArray(GetList("оплата"))
    ReDim common(0 To 200): ReDim rare(0 To 200): nc = 0: nr = 0
    If IsArray(a) Then
        If UBound(a) >= 0 Then
            For i = 0 To UBound(a)
                If IsRareArea(CStr(a(i))) Then
                    rare(nr) = CStr(a(i)): nr = nr + 1
                Else
                    common(nc) = CStr(a(i)): nc = nc + 1
                End If
            Next i
        End If
    End If
    mNCommon = nc: mNArea = nc + nr
    ReDim mOrder(0 To IIf(mNArea = 0, 0, mNArea - 1))
    For i = 0 To nc - 1: mOrder(i) = common(i): Next i
    For i = 0 To nr - 1: mOrder(nc + i) = rare(i): Next i
    mRowsC = (mNCommon + 1) \ 2: If mRowsC < 1 Then mRowsC = 1
End Sub
Private Function IsRareArea(ByVal nm As String) As Boolean
    IsRareArea = (InStr("|" & RARE_LIST & "|", "|" & nm & "|") > 0)
End Function
Private Function ToStrArray(ByVal v As Variant) As String()
    Dim r() As String, i As Long
    If IsArray(v) Then
        If UBound(v) >= 0 Then
            ReDim r(0 To UBound(v))
            For i = 0 To UBound(v): r(i) = CStr(v(i)): Next i
            ToStrArray = r: Exit Function
        End If
    End If
    ReDim r(0 To -1): ToStrArray = r
End Function

'--------------------- ПОСТРОЕНИЕ ОКНА ---------------------
Private Sub BuildForm()
    Dim clrHead As Long, clrPrimary As Long, clrDel As Long, clrCancel As Long, clrExp As Long
    clrHead = RGB(28, 62, 110): clrPrimary = RGB(46, 120, 90)
    clrDel = RGB(150, 55, 55): clrCancel = RGB(196, 138, 46): clrExp = RGB(60, 90, 150)

    Me.Caption = "Журнал МРТ — регистрация"
    Me.BackColor = RGB(244, 247, 250)
    Me.Width = 340: Me.Height = 400

    Set btnSettings = AddButton("btnSettings", 318, 4, 16, 14, ChrW(9881), "SETTINGS")
    btnSettings.Font.Size = 8: btnSettings.BackColor = RGB(238, 241, 244)
    btnSettings.ForeColor = RGB(150, 160, 170): btnSettings.ControlTipText = "Настройки (пароль)"

    Dim be As MSForms.CommandButton
    Set be = AddButton("btnEye", 318, 20, 16, 14, "N", "EYE")   ' Webdings "N" = глаз, под шестерёнкой
    be.Font.Name = "Webdings": be.Font.Size = 9
    be.BackColor = RGB(238, 241, 244): be.ForeColor = RGB(150, 160, 170)
    be.ControlTipText = "Скрыть/показать окно Excel"

    AddHead "Дата", 10, 8, 34, clrHead
    Set txtStudyDate = AddText("txtStudyDate", 44, 6, 72): HookText txtStudyDate, "DATE"
    AddHead "№", 10, 30, 18, clrHead
    Set txtNumber = AddText("txtNumber", 44, 28, 58)
    Set lblPerfHead = AddLabel("Исполнитель", 172, 8, 90, 13)
    lblPerfHead.ForeColor = clrHead
    Set cboPerf = AddCombo("cboPerf", 172, 22, 120, "исполнители")
    ' «Выгрузить пациента» — вверху справа; видна, если включено в Настройках (ShowImportBtn)
    Set btnImport = AddButton("btnImport", 172, 2, 142, 18, "Выгрузить пациента", "IMPORT")
    btnImport.Font.Size = 8: btnImport.BackColor = RGB(60, 90, 150): btnImport.ForeColor = vbWhite
    btnImport.ControlTipText = "Взять данные пациента из другого журнала (путь — в Настройках)"
    btnImport.Visible = False

    AddHead "ФИО", 10, 48, 40, clrHead
    Set PatientName = AddText("PatientName", 10, 62, 238)

    AddHead "Дата рождения", 10, 82, 90, clrHead
    Set DoB = AddText("DoB", 10, 96, 80): HookText DoB, "DOB"
    AddHead "№ ист. болезни", 152, 82, 90, clrHead
    Set History_number = AddText("History_number", 152, 96, 78)

    AddHead "Отделение", 10, 116, 66, clrHead
    Set cboDept = AddCombo("cboDept", 10, 130, 76, "отделения")
    AddHead "Область исследования", 152, 116, 140, clrHead
    Set txtArea = AddText("txtArea", 152, 130, 178)

    ' Анестезия и Оплата — в отдельных рамках, варианты в столбец
    Dim frAnest As MSForms.Frame
    Set frAnest = AddFrame("frAnest", 10, 150, 96, 72, "Анестезия")
    frAnest.ForeColor = clrHead: frAnest.BackColor = RGB(244, 247, 250)
    AddOptionIn frAnest, "optAnestYes", 8, 20, 78, "да", "ANEST"
    AddOptionIn frAnest, "optAnestNo", 8, 44, 78, "нет", "ANEST"
    Set optAnestYes = frAnest.Controls("optAnestYes")
    Set optAnestNo = frAnest.Controls("optAnestNo")

    Set frPay = AddFrame("frPay", 176, 150, 152, 72, "Оплата")
    frPay.ForeColor = clrHead: frPay.BackColor = RGB(244, 247, 250)
    Dim i As Long, py As Single: py = 15
    For i = 0 To UBoundS(mPays)
        AddOptionIn frPay, "optPay_" & i, 8, py, 132, mPays(i), "PAY"
        py = py + 16
    Next i

    ' п.2 — выбор «да/нет» вместо галочки; «да» раскрывает поля контраста
    Dim frCT As MSForms.Frame
    Set frCT = AddFrame("frContrToggle", 10, 222, 320, 42, "Введение контрастного препарата")
    frCT.ForeColor = clrHead
    AddOptionIn frCT, "optContrastYes", 8, 16, 60, "да", "grpContrast"
    AddOptionIn frCT, "optContrastNo", 74, 16, 60, "нет", "grpContrast"
    Set optContrastYes = frCT.Controls("optContrastYes")
    Set optContrastNo = frCT.Controls("optContrastNo")
    HookOpt optContrastYes, "CONTRYES"
    HookOpt optContrastNo, "CONTRNO"
    Set frContrast = AddFrame("frContrast", 10, YLOW_HIDDEN, 320, 80, "")
    frContrast.BackColor = RGB(238, 244, 249)
    AddLabelIn frContrast, "Препарат", 6, 6, 54
    Set cboContrast = AddComboIn(frContrast, "cboContrast", 62, 4, 90, "контрасты")
    AddLabelIn frContrast, "Доза, мл", 162, 6, 50
    Set txtDose = AddTextIn(frContrast, "txtDose", 214, 4, 50)
    AddLabelIn frContrast, "Списываемые флаконы контраста:", 6, 26, 300   ' п.4 — подпись
    Dim fy As Single: fy = 44
    For i = 0 To UBoundS(mFlacons)
        AddCheckIn frContrast, "chkFlac_" & i, 8, fy, 58, mFlacons(i)      ' п.4 — счётчик ближе
        Dim sp As MSForms.SpinButton
        Set sp = AddSpinIn(frContrast, "spnFlac_" & i, 66, fy, 14, 16)
        AddLabelIn frContrast, "1", 84, fy + 1, 22, "lblFlac_" & i
        HookSpin sp, "lblFlac_" & i
        fy = fy + 18
    Next i
    frContrast.Visible = False

    Set frStudies = AddFrame("frStudies", 10, YLOW_HIDDEN, 320, 84, "Для формы №30")
    frStudies.ForeColor = clrHead: frStudies.BackColor = RGB(242, 246, 248)
    frStudies.ScrollBars = fmScrollBarsNone         ' высота рамки — по числу строк (PlaceLower)
    Dim colW As Single: colW = 152
    Dim gx As Single, gy As Single, col As Long, row As Long
    For i = 0 To mNArea - 1
        If i < mNCommon Then
            col = i \ mRowsC: row = i Mod mRowsC
        Else
            Dim j As Long: j = i - mNCommon
            col = j \ 3: row = mRowsC + (j Mod 3)
        End If
        gx = 6 + col * colW: gy = 6 + row * 19
        AddCheckIn frStudies, "chkStudy_" & i, gx, gy, 100, mOrder(i)
        Dim sp2 As MSForms.SpinButton
        Set sp2 = AddSpinIn(frStudies, "spnStudy_" & i, gx + 102, gy, 14, 16)
        AddLabelIn frStudies, "1", gx + 118, gy + 1, 16, "lblStudy_" & i
        HookSpin sp2, "lblStudy_" & i
        If i >= mNCommon Then
            frStudies.Controls("chkStudy_" & i).Visible = False
            frStudies.Controls("spnStudy_" & i).Visible = False
            frStudies.Controls("lblStudy_" & i).Visible = False
        End If
    Next i

    Set chkRare = AddCheck("chkRare", 10, 0, 220, "Показать редкие области")
    HookChk chkRare, "RARE"

    Set lblWarn = AddLabel("", 10, 0, 320, 18)
    lblWarn.ForeColor = RGB(170, 0, 0): lblWarn.Font.Bold = True: lblWarn.Font.Size = 10
    lblWarn.BackStyle = 1: lblWarn.BackColor = RGB(255, 225, 225)      ' заметнее: розовый фон
    lblWarn.WordWrap = True: lblWarn.Visible = False

    Set btnMain = AddButton("btnMain", 10, 0, 120, 24, "Зарегистрировать", "REGISTER")
    btnMain.BackColor = clrPrimary: btnMain.ForeColor = vbWhite: btnMain.Font.Bold = True
    Set btnDelete = AddButton("btnDelete", 136, 0, 92, 24, "Удалить запись", "DELETE")
    btnDelete.BackColor = clrDel: btnDelete.ForeColor = vbWhite
    Set btnCancelPat = AddButton("btnCancelPat", 232, 0, 98, 24, "Отменить пациента", "CANCELPAT")
    btnCancelPat.BackColor = clrCancel: btnCancelPat.ForeColor = vbWhite
    Set btnExport = AddButton("btnExport", 150, 0, 180, 22, "Выгрузить данные в журналы", "EXPORT")
    btnExport.BackColor = clrExp: btnExport.ForeColor = vbWhite
    ' крупная кнопка записи диска — и в окне регистрации, и в окне редактирования
    Set btnDiscBurn = AddButton("btnDiscBurn", 175, 0, 155, 28, "Записать диск", "DISC")
    btnDiscBurn.BackColor = RGB(96, 72, 140): btnDiscBurn.ForeColor = vbWhite
    btnDiscBurn.Font.Bold = True: btnDiscBurn.Font.Size = 10

    PlaceLower YLOW_HIDDEN
    HookAllForF9 Me.Controls          ' п.4 — F9 закрывает окно из любого поля
End Sub

' Нижняя часть окна: рамка «Для формы №30» (высота — по числу строк областей, без
' полосы прокрутки), «редкие области», предупреждение, кнопки
Private Sub PlaceLower(ByVal topY As Single)
    Dim fh As Single, need As Single, y As Single, by As Single
    need = StudiesFrameHeight()
    fh = need
    If topY + fh + 38 + 56 + 36 > MAX_FORM_H Then fh = MAX_FORM_H - (topY + 38 + 56 + 36)   ' очень высокое окно
    If fh < 60 Then fh = 60
    frStudies.Top = topY: frStudies.Height = fh
    If fh < need Then
        frStudies.ScrollBars = fmScrollBarsVertical
        frStudies.ScrollHeight = need - 18
    Else
        frStudies.ScrollBars = fmScrollBarsNone
        frStudies.ScrollTop = 0
    End If
    y = topY + fh + 4
    chkRare.Top = y
    lblWarn.Top = y + 16
    by = y + 38
    btnMain.Top = by: btnDelete.Top = by: btnCancelPat.Top = by
    If mEdit Then
        btnDiscBurn.Top = by + 28: btnExport.Top = by + 28      ' ряд 2: диск + выгрузка
    Else
        btnDiscBurn.Top = by: btnExport.Top = by + 32           ' ряд 1: регистрация + диск
    End If
    Me.Height = by + 56 + 36
End Sub

' Высота рамки, чтобы все видимые строки областей помещались без прокрутки
Private Function StudiesFrameHeight() As Single
    Dim nRows As Long, nRare As Long
    nRows = mRowsC
    If chkRare.Value Then
        nRare = mNArea - mNCommon
        If nRare > 3 Then nRare = 3
        nRows = nRows + nRare
    End If
    StudiesFrameHeight = nRows * 19 + 26
End Function

'--------------------- Хелперы (шрифт FS=9) ---------------------
Private Sub AddHead(cap As String, x As Single, y As Single, w As Single, clr As Long)
    Dim c As MSForms.Label
    Set c = Me.Controls.Add("Forms.Label.1", "lb" & Me.Controls.Count, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = 13: c.Font.Size = FS: c.ForeColor = clr
End Sub
Private Function AddLabel(cap As String, x As Single, y As Single, w As Single, h As Single) As MSForms.Label
    Dim c As MSForms.Label
    Set c = Me.Controls.Add("Forms.Label.1", "lb" & Me.Controls.Count, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = h: c.Font.Size = FS
    Set AddLabel = c
End Function
Private Function AddText(nm As String, x As Single, y As Single, w As Single) As MSForms.TextBox
    Dim c As MSForms.TextBox
    Set c = Me.Controls.Add("Forms.TextBox.1", nm, True)
    c.Left = x: c.Top = y: c.Width = w: c.Height = 18: c.Font.Size = FS
    Set AddText = c
End Function
Private Function AddCombo(nm As String, x As Single, y As Single, w As Single, listHdr As String) As MSForms.ComboBox
    Dim c As MSForms.ComboBox
    Set c = Me.Controls.Add("Forms.ComboBox.1", nm, True)
    c.Left = x: c.Top = y: c.Width = w: c.Height = 18: c.Font.Size = FS
    c.Style = fmDDL: c.MatchRequired = True
    FillCtl c, listHdr
    Set AddCombo = c
End Function
Private Function AddCheck(nm As String, x As Single, y As Single, w As Single, cap As String) As MSForms.CheckBox
    Dim c As MSForms.CheckBox
    Set c = Me.Controls.Add("Forms.CheckBox.1", nm, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = 16: c.Font.Size = FS
    Set AddCheck = c
End Function
Private Function AddOption(nm As String, x As Single, y As Single, w As Single, cap As String, grp As String) As MSForms.OptionButton
    Dim c As MSForms.OptionButton
    Set c = Me.Controls.Add("Forms.OptionButton.1", nm, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = 16: c.Font.Size = FS: c.GroupName = grp
    Set AddOption = c
End Function
Private Function AddFrame(nm As String, x As Single, y As Single, w As Single, h As Single, cap As String) As MSForms.Frame
    Dim c As MSForms.Frame
    Set c = Me.Controls.Add("Forms.Frame.1", nm, True)
    c.Left = x: c.Top = y: c.Width = w: c.Height = h: c.Caption = cap: c.Font.Size = FS
    Set AddFrame = c
End Function
Private Function AddButton(nm As String, x As Single, y As Single, w As Single, h As Single, cap As String, key As String) As MSForms.CommandButton
    Dim c As MSForms.CommandButton
    Set c = Me.Controls.Add("Forms.CommandButton.1", nm, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = h: c.Font.Size = FS
    HookBtn c, key
    Set AddButton = c
End Function
Private Sub AddLabelIn(fr As MSForms.Frame, cap As String, x As Single, y As Single, w As Single, Optional nm As String = "")
    Dim c As MSForms.Label
    If nm = "" Then nm = "l_" & fr.Name & "_" & fr.Controls.Count
    Set c = fr.Controls.Add("Forms.Label.1", nm, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = 14: c.Font.Size = FS
End Sub
Private Function AddTextIn(fr As MSForms.Frame, nm As String, x As Single, y As Single, w As Single) As MSForms.TextBox
    Dim c As MSForms.TextBox
    Set c = fr.Controls.Add("Forms.TextBox.1", nm, True)
    c.Left = x: c.Top = y: c.Width = w: c.Height = 18: c.Font.Size = FS
    Set AddTextIn = c
End Function
Private Function AddComboIn(fr As MSForms.Frame, nm As String, x As Single, y As Single, w As Single, listHdr As String) As MSForms.ComboBox
    Dim c As MSForms.ComboBox
    Set c = fr.Controls.Add("Forms.ComboBox.1", nm, True)
    c.Left = x: c.Top = y: c.Width = w: c.Height = 18: c.Font.Size = FS
    c.Style = fmDDL: c.MatchRequired = True
    FillCtl c, listHdr
    Set AddComboIn = c
End Function
Private Sub AddCheckIn(fr As MSForms.Frame, nm As String, x As Single, y As Single, w As Single, cap As String)
    Dim c As MSForms.CheckBox
    Set c = fr.Controls.Add("Forms.CheckBox.1", nm, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = 16: c.Font.Size = FS
End Sub
Private Function AddSpinIn(fr As MSForms.Frame, nm As String, x As Single, y As Single, w As Single, h As Single) As MSForms.SpinButton
    Dim c As MSForms.SpinButton
    Set c = fr.Controls.Add("Forms.SpinButton.1", nm, True)
    c.Left = x: c.Top = y: c.Width = w: c.Height = h: c.Min = 1: c.Max = 50: c.Value = 1
    Set AddSpinIn = c
End Function
Private Sub AddOptionIn(fr As MSForms.Frame, nm As String, x As Single, y As Single, w As Single, cap As String, grp As String)
    Dim c As MSForms.OptionButton
    Set c = fr.Controls.Add("Forms.OptionButton.1", nm, True)
    c.Caption = cap: c.Left = x: c.Top = y: c.Width = w: c.Height = 16: c.Font.Size = FS: c.GroupName = grp
End Sub
Private Sub FillCtl(ByVal cbo As MSForms.ComboBox, ByVal header As String)
    Dim arr As Variant, i As Long
    cbo.Clear: arr = GetList(header)
    If IsArray(arr) Then
        If UBound(arr) >= 0 Then
            For i = 0 To UBound(arr): cbo.AddItem arr(i): Next i
        End If
    End If
End Sub
Private Function UBoundS(a() As String) As Long
    On Error Resume Next
    UBoundS = UBound(a): If Err.Number <> 0 Then UBoundS = -1
    On Error GoTo 0
End Function

Private Sub HookBtn(b As MSForms.CommandButton, k As String)
    Dim h As ctlEvents: Set h = New ctlEvents: Set h.Frm = Me: h.Key = k: Set h.Btn = b: mH.Add h: mHooked(b.Name) = True
End Sub
Private Sub HookSpin(s As MSForms.SpinButton, k As String)
    Dim h As ctlEvents: Set h = New ctlEvents: Set h.Frm = Me: h.Key = k: Set h.Spn = s: mH.Add h: mHooked(s.Name) = True
End Sub
Private Sub HookText(t As MSForms.TextBox, k As String)
    Dim h As ctlEvents: Set h = New ctlEvents: Set h.Frm = Me: h.Key = k: Set h.Txt = t: mH.Add h: mHooked(t.Name) = True
End Sub
Private Sub HookChk(ch As MSForms.CheckBox, k As String)
    Dim h As ctlEvents: Set h = New ctlEvents: Set h.Frm = Me: h.Key = k: Set h.Chk = ch: mH.Add h: mHooked(ch.Name) = True
End Sub
Private Sub HookOpt(o As MSForms.OptionButton, k As String)
    Dim h As ctlEvents: Set h = New ctlEvents: Set h.Frm = Me: h.Key = k: Set h.Opt = o: mH.Add h: mHooked(o.Name) = True
End Sub

' п.4 — подписать на F9 все элементы, у которых ещё нет обработчика
' (ФИО, № истории, отделение, оплата, анестезия, флаконы, области и т.д.)
Private Sub HookAllForF9(ByVal ctls As Object)
    Dim c As Object, h As ctlEvents, tn As String
    For Each c In ctls
        tn = TypeName(c)
        If tn = "Frame" Then
            HookAllForF9 c.Controls
        ElseIf Not mHooked.Exists(c.Name) Then
            Set h = Nothing
            Select Case tn
                Case "TextBox": Set h = New ctlEvents: Set h.Txt = c
                Case "ComboBox": Set h = New ctlEvents: Set h.cbo = c
                Case "CheckBox": Set h = New ctlEvents: Set h.Chk = c
                Case "OptionButton": Set h = New ctlEvents: Set h.Opt = c
                Case "CommandButton": Set h = New ctlEvents: Set h.Btn = c
                Case "SpinButton": Set h = New ctlEvents: Set h.Spn = c
            End Select
            If Not h Is Nothing Then
                Set h.Frm = Me: h.F9Only = True
                mH.Add h: mHooked(c.Name) = True
            End If
        End If
    Next c
End Sub

'--------------------- Диспетчеры ---------------------
Public Sub OnButton(ByVal k As String)
    Select Case k
        Case "REGISTER": DoRegister
        Case "DELETE": DoDelete
        Case "CANCELPAT": DoCancelPatient
        Case "SETTINGS": OpenSettings
        Case "IMPORT": ImportPatient
        Case "EYE": ToggleExcel
        Case "EXPORT"
            ' показать Excel, чтобы окна подтверждения и итога выгрузки были доступны
            On Error Resume Next
            Application.Visible = True
            SetTopMost False
            On Error GoTo 0
            ExportEndOfShift
        Case "DISC"
            ' окно записи диска (UserForm4, модуль modDisc); без записи журнала —
            ' пациента выбирают в самом окне (угадывается по последнему исследованию)
            On Error Resume Next
            Application.Visible = True
            SetTopMost False
            On Error GoTo 0
            If CurrentRow > 0 And Not gEditSheet Is Nothing Then
                OpenDiscWindow gEditSheet, CurrentRow, "burn"
            Else
                OpenDiscWindow Nothing, 0, "burn"
            End If
    End Select
End Sub
Public Sub OnSpin(ByVal k As String, ByVal v As Long)
    On Error Resume Next
    FindCtl(k).Caption = CStr(v)
    On Error GoTo 0
End Sub
Public Sub OnText(ByVal k As String)
    If mBusy Then Exit Sub
    If k = "DOB" Then ReformatDate DoB Else ReformatDate txtStudyDate   ' п.7
End Sub
Public Sub OnCheck(ByVal k As String, ByVal v As Boolean)
    If k = "CONTR" Then
        frContrast.Visible = v
        If v Then PlaceLower YLOW_SHOWN Else PlaceLower YLOW_HIDDEN
    ElseIf k = "RARE" Then
        ShowRare v
    End If
End Sub
Public Sub OnCombo(ByVal k As String)
End Sub
Public Sub OnOption(ByVal k As String)
    Select Case k
        Case "CONTRYES": If optContrastYes.Value Then ShowContrast True
        Case "CONTRNO": If optContrastNo.Value Then ShowContrast False
    End Select
End Sub
Private Sub ShowContrast(ByVal v As Boolean)
    frContrast.Visible = v
    If v Then PlaceLower YLOW_SHOWN Else PlaceLower YLOW_HIDDEN
End Sub

' п.7 — устойчивое проставление точек: работает из цифр, backspace корректен,
' двойные точки невозможны (все нецифры отбрасываются)
Private Sub ReformatDate(tb As MSForms.TextBox)
    Dim raw As String, d As String, i As Long, ch As String, s As String
    raw = tb.Text: d = ""
    For i = 1 To Len(raw)
        ch = Mid$(raw, i, 1)
        If ch >= "0" And ch <= "9" Then d = d & ch
    Next i
    If Len(d) > 8 Then d = Left$(d, 8)
    If Len(d) <= 2 Then
        s = d
    ElseIf Len(d) <= 4 Then
        s = Left$(d, 2) & "." & Mid$(d, 3)
    Else
        s = Left$(d, 2) & "." & Mid$(d, 3, 2) & "." & Mid$(d, 5)
    End If
    If s = raw Then Exit Sub
    mBusy = True
    tb.Text = s: tb.SelStart = Len(s)
    mBusy = False
End Sub

Private Sub ShowRare(ByVal show As Boolean)
    Dim i As Long
    For i = mNCommon To mNArea - 1
        frStudies.Controls("chkStudy_" & i).Visible = show
        frStudies.Controls("spnStudy_" & i).Visible = show
        frStudies.Controls("lblStudy_" & i).Visible = show
    Next i
    PlaceLower frStudies.Top                     ' рамка растёт/сжимается под строки
End Sub
Private Function FindCtl(ByVal nm As String) As Object
    On Error Resume Next
    Set FindCtl = frStudies.Controls(nm)
    If FindCtl Is Nothing Then Set FindCtl = frContrast.Controls(nm)
    If FindCtl Is Nothing Then Set FindCtl = Me.Controls(nm)
    On Error GoTo 0
End Function

'--------------------- Новая регистрация ---------------------
Private Sub ResetNew()
    mEdit = False
    mBusy = True: txtStudyDate.Value = Format$(Date, "dd.mm.yyyy"): mBusy = False
    txtNumber.Value = NextPatientNumber()
    PatientName.Value = "": DoB.Value = "": cboDept.Value = ""
    History_number.Value = "": txtArea.Value = ""
    optAnestYes.Value = False: optAnestNo.Value = False
    optContrastYes.Value = False: optContrastNo.Value = False: frContrast.Visible = False: PlaceLower YLOW_HIDDEN   ' п.2 — ответ не выбран заранее
    If cboContrast.ListCount > 0 Then cboContrast.Value = cboContrast.List(0)   ' п.1 — Гадобутрол по умолч.
    txtDose.Value = ""
    ClearFlacons: ClearStudies: ClearPay
    If gShiftPerformer <> "" Then cboPerf.Value = gShiftPerformer Else cboPerf.Value = ""
    lblWarn.Visible = False
    btnMain.Caption = "Зарегистрировать"
    btnDelete.Visible = False: btnCancelPat.Visible = False
    btnExport.Visible = True: btnDiscBurn.Visible = True
    ' ряд 1: «Зарегистрировать» и «Записать диск»; ряд 2: «Выгрузить данные в журналы»
    btnMain.Left = 10: btnMain.Width = 155: btnMain.Height = 28
    btnDiscBurn.Left = 175: btnDiscBurn.Width = 155
    btnDiscBurn.ControlTipText = "Записать диск пациенту (пациента можно выбрать в окне записи)"
    btnExport.Left = 10: btnExport.Width = 320: btnExport.Height = 22
    PlaceLower frStudies.Top
    ShowImportBtn
End Sub
Private Sub ClearFlacons()
    Dim i As Long
    For i = 0 To UBoundS(mFlacons)
        frContrast.Controls("chkFlac_" & i).Value = False
        frContrast.Controls("spnFlac_" & i).Value = 1
        frContrast.Controls("lblFlac_" & i).Caption = "1"
    Next i
End Sub
Private Sub ClearStudies()
    Dim i As Long
    For i = 0 To mNArea - 1
        frStudies.Controls("chkStudy_" & i).Value = False
        frStudies.Controls("spnStudy_" & i).Value = 1
        frStudies.Controls("lblStudy_" & i).Caption = "1"
    Next i
End Sub
Private Sub ClearPay()
    Dim i As Long
    For i = 0 To UBoundS(mPays): frPay.Controls("optPay_" & i).Value = False: Next i
End Sub

'--------------------- Редактирование ---------------------
Public Sub FillData()
    Dim ws As Worksheet, r As Long
    mEdit = True
    Set ws = gEditSheet: r = CurrentRow
    mBusy = True
    txtNumber.Value = ws.Cells(r, COL_NUM).Value
    PatientName.Value = ws.Cells(r, COL_FIO).Value
    If IsDate(ws.Cells(r, COL_DOB).Value) Then _
        DoB.Value = Format$(ws.Cells(r, COL_DOB).Value, "dd.mm.yyyy") _
    Else DoB.Value = CStr(ws.Cells(r, COL_DOB).Value)
    cboDept.Value = ws.Cells(r, COL_DEPT).Value
    History_number.Value = ws.Cells(r, COL_CARD).Value
    txtArea.Value = ws.Cells(r, COL_AREA).Value
    Dim an As String: an = LCase$(Trim$(CStr(ws.Cells(r, COL_ANEST).Value)))
    optAnestYes.Value = (an = "да"): optAnestNo.Value = (an = "нет")
    SetPay CStr(ws.Cells(r, COL_PAY).Value)
    Dim hc As Boolean: hc = (Trim$(CStr(ws.Cells(r, COL_CONTR_NAME).Value)) <> "")
    optContrastYes.Value = hc: optContrastNo.Value = Not hc: frContrast.Visible = hc
    If hc Then PlaceLower YLOW_SHOWN Else PlaceLower YLOW_HIDDEN
    cboContrast.Value = ws.Cells(r, COL_CONTR_NAME).Value
    If IsNumeric(ws.Cells(r, COL_CONTR_DOSE).Value) Then _
        txtDose.Value = Format$(ws.Cells(r, COL_CONTR_DOSE).Value, "0.0")
    LoadFlacons CStr(ws.Cells(r, COL_CONTR_FLAC).Value)
    cboPerf.Value = ws.Cells(r, COL_PERF).Value
    LoadStudies CStr(ws.Cells(r, COL_STUDY).Value)
    Dim dRow As Long: dRow = r
    Do While Trim$(CStr(ws.Cells(dRow, COL_DATE).Value)) = "" And dRow > 1
        dRow = dRow - 1
    Loop
    If IsDate(ws.Cells(dRow, COL_DATE).Value) Then _
        txtStudyDate.Value = Format$(ws.Cells(dRow, COL_DATE).Value, "dd.mm.yyyy")
    mBusy = False
    lblWarn.Visible = False
    btnMain.Caption = "Редактировать"          ' п.9
    btnDelete.Visible = True: btnCancelPat.Visible = True
    btnExport.Visible = True                    ' п.8 — выгрузка доступна и в окне редактирования
    btnDiscBurn.Visible = True
    ' раскладка режима редактирования: три кнопки в ряд; ниже — «Записать диск» и «Выгрузить …»
    btnMain.Width = 106: btnMain.Left = 10: btnMain.Height = 24
    btnDelete.Width = 96: btnDelete.Left = 122
    btnCancelPat.Width = 106: btnCancelPat.Left = 224
    btnDiscBurn.Left = 10: btnDiscBurn.Width = 155
    btnDiscBurn.ControlTipText = "Записать диск этому пациенту"
    btnExport.Left = 175: btnExport.Width = 155: btnExport.Height = 28
    PlaceLower frStudies.Top
    ShowImportBtn
End Sub
Private Sub SetPay(ByVal v As String)
    Dim i As Long: v = Trim$(v)
    For i = 0 To UBoundS(mPays): frPay.Controls("optPay_" & i).Value = (mPays(i) = v): Next i
End Sub
Private Sub LoadFlacons(ByVal s As String)
    Dim parts() As String, i As Long, j As Long, nm As String, cnt As Long
    ClearFlacons: s = Trim$(s): If s = "" Then Exit Sub
    parts = Split(s, ";")
    For j = LBound(parts) To UBound(parts)
        If Trim$(parts(j)) <> "" Then
            ParseToken parts(j), "flac", nm, cnt
            For i = 0 To UBoundS(mFlacons)
                If mFlacons(i) = nm Then
                    frContrast.Controls("chkFlac_" & i).Value = True
                    frContrast.Controls("spnFlac_" & i).Value = cnt
                    frContrast.Controls("lblFlac_" & i).Caption = CStr(cnt)
                End If
            Next i
        End If
    Next j
End Sub
Private Sub LoadStudies(ByVal s As String)
    Dim parts() As String, i As Long, j As Long, nm As String, cnt As Long, anyRare As Boolean
    ClearStudies: s = Trim$(s): If s = "" Then Exit Sub
    parts = Split(s, ",")
    For j = LBound(parts) To UBound(parts)
        If Trim$(parts(j)) <> "" Then
            ParseToken parts(j), "study", nm, cnt
            For i = 0 To mNArea - 1
                If mOrder(i) = nm Then
                    frStudies.Controls("chkStudy_" & i).Value = True
                    frStudies.Controls("spnStudy_" & i).Value = cnt
                    frStudies.Controls("lblStudy_" & i).Caption = CStr(cnt)
                    If i >= mNCommon Then anyRare = True
                End If
            Next i
        End If
    Next j
    If anyRare Then chkRare.Value = True
End Sub

'--------------------- Сбор данных ---------------------
Private Function SelectedPay() As String
    Dim i As Long
    For i = 0 To UBoundS(mPays)
        If frPay.Controls("optPay_" & i).Value Then SelectedPay = mPays(i): Exit Function
    Next i
End Function
Private Function AnestValue() As String
    If optAnestYes.Value Then
        AnestValue = "да"
    ElseIf optAnestNo.Value Then
        AnestValue = "нет"
    End If
End Function
Private Function CollectFlacons() As String
    Dim i As Long, s As String, cnt As Long
    For i = 0 To UBoundS(mFlacons)
        If frContrast.Controls("chkFlac_" & i).Value Then
            cnt = frContrast.Controls("spnFlac_" & i).Value: If cnt < 1 Then cnt = 1
            s = s & IIf(s = "", "", "; ") & FormatToken(mFlacons(i), cnt, "flac")
        End If
    Next i
    CollectFlacons = s
End Function
Private Function AnyFlacon() As Boolean
    Dim i As Long
    For i = 0 To UBoundS(mFlacons)
        If frContrast.Controls("chkFlac_" & i).Value Then AnyFlacon = True: Exit Function
    Next i
End Function
Private Function CollectStudies(ByRef outCount As Long, ByVal hasContrast As Boolean) As String
    Dim i As Long, s As String, cnt As Long
    outCount = 0
    For i = 0 To mNArea - 1
        If frStudies.Controls("chkStudy_" & i).Value Then
            cnt = frStudies.Controls("spnStudy_" & i).Value: If cnt < 1 Then cnt = 1
            s = s & IIf(s = "", "", ", ") & FormatToken(mOrder(i), cnt, "study")
            If hasContrast And mOrder(i) <> "сосуды" Then outCount = outCount + cnt * 2 _
            Else outCount = outCount + cnt
        End If
    Next i
    CollectStudies = s
End Function

' п.3 — корректный разбор дозы с одним знаком после запятой, независимо от локали
Private Function IsDecimal(ByVal s As String) As Boolean
    Dim i As Long, ch As String, sep As Long
    s = Trim$(s): If s = "" Then Exit Function
    sep = 0
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If ch = "," Or ch = "." Then
            sep = sep + 1: If sep > 1 Then Exit Function
        ElseIf ch < "0" Or ch > "9" Then
            Exit Function
        End If
    Next i
    IsDecimal = True
End Function
Private Function ToDouble(ByVal s As String) As Double
    ToDouble = Val(Replace(Trim$(s), ",", "."))     ' Val всегда трактует точку как разделитель
End Function

'--------------------- РЕГИСТРАЦИЯ ---------------------
Private Sub DoRegister()
    ' при регистрации возвращаем окно Excel — иначе окна подтверждения не видны/некликабельны
    On Error Resume Next
    Application.Visible = True
    SetTopMost False
    On Error GoTo 0

    Dim bDate As Date, dReg As Date, num As Long
    Dim cName As String, cDose As String, flacText As String
    Dim hasContrast As Boolean, writeContrast As Boolean
    Dim studiesText As String, studiesN As Long
    Dim soft As String, hard As String

    hasContrast = optContrastYes.Value
    cName = Trim$(cboContrast.Value): cDose = Trim$(txtDose.Value)

    If Trim$(PatientName.Value) = "" Then soft = AddProblem(soft, "ФИО")
    If Trim$(cboDept.Value) = "" Then soft = AddProblem(soft, "отделение")
    If Trim$(History_number.Value) = "" Then soft = AddProblem(soft, "№ истории болезни")
    If Trim$(txtArea.Value) = "" Then soft = AddProblem(soft, "область")
    If AnestValue() = "" Then soft = AddProblem(soft, "анестезия")
    If SelectedPay() = "" Then soft = AddProblem(soft, "оплата")
    If Trim$(cboPerf.Value) = "" Then soft = AddProblem(soft, "исполнитель")

    studiesText = CollectStudies(studiesN, hasContrast)
    If studiesText = "" Then soft = AddProblem(soft, "исследования")

    If hasContrast Then
        If cName = "" Then soft = AddProblem(soft, "контраст: препарат")
        If cDose = "" Then soft = AddProblem(soft, "контраст: доза")
        If Not AnyFlacon() Then soft = AddProblem(soft, "контраст: флакон")
        If cDose <> "" Then If Not IsDecimal(cDose) Then soft = AddProblem(soft, "доза (например 3,5)")
    End If

    If Trim$(History_number.Value) <> "" Then If Not ValidCardNumber(CStr(History_number.Value)) Then _
        soft = AddProblem(soft, "укажите номер истории болезни в формате «номер-год»")

    If Not TryDoB(bDate) Then soft = AddProblem(soft, "дата рождения")

    If Not ParseDate(txtStudyDate.Text, dReg) Then hard = AddProblem(hard, "дата исследования (дд.мм.гггг)")
    If Not IsNumeric(txtNumber.Value) Then hard = AddProblem(hard, "№ (число)")
    If Not optContrastYes.Value And Not optContrastNo.Value Then _
        hard = AddProblem(hard, "введение контраста — выберите «да» или «нет»")      ' п.2

    If hard <> "" Then
        lblWarn.Caption = "Исправьте: " & hard: lblWarn.Visible = True: Exit Sub
    End If
    If soft <> "" Then
        Dim resp As VbMsgBoxResult
        resp = WarnAsk("Заполнены не все данные:" & vbCrLf & soft & vbCrLf & vbCrLf & _
                      "Всё равно зарегистрировать пациента?" & vbCrLf & _
                      "(Да — продолжить, Нет — назад)", vbYesNo + vbExclamation, "Предупреждение")
        If resp = vbNo Then
            lblWarn.Caption = "Заполнены не все данные: " & soft: lblWarn.Visible = True: Exit Sub
        End If
    End If
    lblWarn.Visible = False
    If Not EnsureDiscColumn(False) Then Exit Sub        ' столбец O «Запись диска» (разово, при первом запуске)

    num = CLng(txtNumber.Value)
    writeContrast = hasContrast And cName <> "" And AnyFlacon() And cDose <> "" And IsDecimal(cDose)
    studiesText = CollectStudies(studiesN, writeContrast)
    flacText = CollectFlacons()

    If CurrentRow > 0 And Not gEditSheet Is Nothing Then
        WritePatient gEditSheet, CurrentRow, num, bDate, writeContrast, flacText, studiesText, studiesN, cDose
        gShiftPerformer = CStr(cboPerf.Value)
        MsgBox "Изменения сохранены.", vbInformation
        CurrentRow = 0: Set gEditSheet = Nothing: ResetNew: Exit Sub   ' п.8 — снова окно регистрации
    End If

    Dim ws As Worksheet: Set ws = MonthSheet(dReg)
    If ws Is Nothing Then WarnAsk "Лист «" & MonthName_Nom(dReg) & "» не найден.", vbCritical: Exit Sub

    ' п.3б — убрать «висячую» неправильную дату (дата без пациента) на других листах-месяцах
    CleanDanglingDates ws

    Dim lastA As Long, lastC As Long, lastRow As Long, patRow As Long, sameDate As Boolean
    Dim dateRow As Long
    lastA = ws.Cells(ws.Rows.Count, COL_DATE).End(xlUp).Row
    lastC = ws.Cells(ws.Rows.Count, COL_FIO).End(xlUp).Row
    If lastA >= FIRST_DATA_ROW And lastA > lastC Then
        ' п.3а — последняя строка = дата без пациента: перезаписываем её правильной датой
        dateRow = lastA: patRow = dateRow + 1
        UnprotectSheet ws
        ws.Cells(dateRow, COL_DATE).Value = dReg
        ws.Cells(dateRow, COL_DATE).NumberFormat = "dd.mm.yyyy"
        ProtectSheet ws
    Else
        lastRow = Application.WorksheetFunction.Max(lastA, lastC, FIRST_DATA_ROW - 1)
        If lastA >= FIRST_DATA_ROW Then If IsDate(ws.Cells(lastA, COL_DATE).Value) Then _
            sameDate = (Int(ws.Cells(lastA, COL_DATE).Value) = Int(dReg))
        If sameDate Then
            patRow = lastRow + 1
        Else
            dateRow = lastRow + 1: patRow = dateRow + 1
            UnprotectSheet ws
            ws.Cells(dateRow, COL_DATE).Value = dReg
            ws.Cells(dateRow, COL_DATE).NumberFormat = "dd.mm.yyyy"
            ProtectSheet ws
        End If
    End If
    WritePatient ws, patRow, num, bDate, writeContrast, flacText, studiesText, studiesN, cDose
    If gShiftPerformer = "" Then gShiftPerformer = CStr(cboPerf.Value)
    Dim pName As String: pName = Trim$(CStr(PatientName.Value))
    If pName = "" Then pName = "№" & num
    MsgBox "Пациент «" & pName & "» добавлен на лист «" & ws.Name & "».", vbInformation

    txtNumber.Value = NextPatientNumber()
    PatientName.Value = "": DoB.Value = "": cboDept.Value = "": History_number.Value = "": txtArea.Value = ""
    optAnestYes.Value = False: optAnestNo.Value = False
    optContrastYes.Value = False: optContrastNo.Value = False: frContrast.Visible = False: PlaceLower YLOW_HIDDEN   ' п.2 — ответ не выбран заранее
    If cboContrast.ListCount > 0 Then cboContrast.Value = cboContrast.List(0)
    txtDose.Value = "": ClearFlacons: ClearStudies
    PatientName.SetFocus
End Sub

Private Function AddProblem(ByVal cur As String, ByVal item As String) As String
    AddProblem = cur & IIf(cur = "", "", ", ") & item
End Function
Private Function TryDoB(ByRef bDate As Date) As Boolean
    Dim d As Integer, m As Integer, y As Integer
    bDate = 0
    If Len(DoB.Text) <> 10 Then Exit Function
    d = Val(Left$(DoB.Text, 2)): m = Val(Mid$(DoB.Text, 4, 2)): y = Val(Right$(DoB.Text, 4))
    If d < 1 Or d > 31 Or m < 1 Or m > 12 Or y < 1900 Then Exit Function
    On Error Resume Next
    bDate = DateSerial(y, m, d)
    On Error GoTo 0
    If Month(bDate) = m And bDate <= Date Then TryDoB = True Else bDate = 0
End Function

Private Sub WritePatient(ByVal ws As Worksheet, ByVal rowN As Long, ByVal num As Long, _
        ByVal bDate As Date, ByVal writeContrast As Boolean, ByVal flacText As String, _
        ByVal studiesText As String, ByVal studiesN As Long, ByVal cDose As String)
    UnprotectSheet ws
    ws.Cells(rowN, COL_NUM).Value = num
    ws.Cells(rowN, COL_FIO).Value = PatientName.Value
    If bDate > 0 Then
        ws.Cells(rowN, COL_DOB).Value = bDate
        ws.Cells(rowN, COL_DOB).NumberFormat = "dd.mm.yyyy"
    Else
        ws.Cells(rowN, COL_DOB).ClearContents
    End If
    ws.Cells(rowN, COL_DEPT).Value = cboDept.Value
    ws.Cells(rowN, COL_CARD).Value = History_number.Value
    ws.Cells(rowN, COL_AREA).Value = txtArea.Value
    ws.Cells(rowN, COL_ANEST).Value = AnestValue()
    If writeContrast Then
        ws.Cells(rowN, COL_CONTR_NAME).Value = cboContrast.Value
        ws.Cells(rowN, COL_CONTR_DOSE).Value = ToDouble(cDose)      ' п.3
        ws.Cells(rowN, COL_CONTR_DOSE).NumberFormat = "0.0"
        ws.Cells(rowN, COL_CONTR_FLAC).Value = flacText
    Else
        ws.Cells(rowN, COL_CONTR_NAME).ClearContents
        ws.Cells(rowN, COL_CONTR_DOSE).ClearContents
        ws.Cells(rowN, COL_CONTR_FLAC).ClearContents
    End If
    ws.Cells(rowN, COL_PAY).Value = SelectedPay()
    ws.Cells(rowN, COL_PERF).Value = cboPerf.Value
    ws.Cells(rowN, COL_STUDY).Value = studiesText
    ws.Cells(rowN, COL_COUNT).Value = studiesN
    ProtectSheet ws
End Sub

'--------------------- Удаление / отмена / настройки ---------------------
' п.3б — удалить одинокую дату (без пациента) в конце других листов-месяцев
Private Sub CleanDanglingDates(ByVal keepWs As Worksheet)
    Dim i As Long, s As Worksheet, la As Long, lc As Long
    For i = 1 To 12
        Set s = MonthSheet(DateSerial(2000, i, 1))
        If Not s Is Nothing Then
            If Not (s Is keepWs) Then
                la = s.Cells(s.Rows.Count, COL_DATE).End(xlUp).Row
                lc = s.Cells(s.Rows.Count, COL_FIO).End(xlUp).Row
                If la >= FIRST_DATA_ROW And la > lc Then
                    UnprotectSheet s
                    s.Rows(la).Delete Shift:=xlUp
                    ProtectSheet s
                End If
            End If
        End If
    Next i
End Sub

Private Sub DoDelete()
    If gEditSheet Is Nothing Or CurrentRow = 0 Then Exit Sub
    If MsgBox("Вы действительно хотите удалить данные о пациенте?", vbYesNo + vbQuestion, "Удаление") = vbYes Then
        Dim ws As Worksheet: Set ws = gEditSheet
        UnprotectSheet ws
        ws.Rows(CurrentRow).Delete Shift:=xlUp
        ProtectSheet ws
        RenumberSheet ws
        CurrentRow = 0: Set gEditSheet = Nothing
        ResetNew                       ' п.8 — снова окно регистрации
    End If
End Sub
Private Sub DoCancelPatient()
    If gEditSheet Is Nothing Or CurrentRow = 0 Then Exit Sub
    Dim reason As String
    reason = InputBox("Причина отмены исследования:" & vbCrLf & "(ОК — отменить, Отмена — назад)", "Отмена пациента")
    If Trim$(reason) = "" Then Exit Sub
    Dim ws As Worksheet, r As Long: Set ws = gEditSheet: r = CurrentRow
    UnprotectSheet ws
    ws.Cells(r, COL_CONTR_NAME).ClearContents
    ws.Cells(r, COL_CONTR_DOSE).ClearContents
    ws.Cells(r, COL_CONTR_FLAC).ClearContents
    ws.Cells(r, COL_STUDY).ClearContents
    ws.Cells(r, COL_COUNT).ClearContents
    ws.Cells(r, COL_AREA).Value = "отмена – " & reason
    ProtectSheet ws
    MsgBox "Исследование отменено.", vbInformation
    CurrentRow = 0: Set gEditSheet = Nothing: ResetNew   ' п.8 — снова окно регистрации
End Sub
Private Sub OpenSettings()
    Dim p As String
    p = InputBox("Введите пароль настроек:", "Настройки")
    If p = "" Then Exit Sub
    If Not SettingsPWOk(p) Then WarnAsk "Неверный пароль.", vbExclamation: Exit Sub
    UserForm2.Show vbModal
    UnloadForm "UserForm2"                      ' если окно закрыли клавишей F9 (Hide)
    FillCtl cboDept, "отделения": FillCtl cboPerf, "исполнители": FillCtl cboContrast, "контрасты"
    ShowImportBtn                               ' опцию «Выгрузка пациентов…» могли включить/выключить
End Sub

'--------------------- Пациент из другого журнала ---------------------
' Кнопка «Выгрузить пациента» (Настройки -> «Обмен пациентами со старым журналом»):
' видна в окне новой регистрации, если опция включена; тогда «Исполнитель» чуть ниже.
' Вызывается из Настроек сразу после «Сохранить»
Public Sub RefreshImportBtn()
    ShowImportBtn
End Sub

Private Sub ShowImportBtn()
    Dim isOn As Boolean
    On Error Resume Next
    isOn = ImportEnabled()
    On Error GoTo 0
    btnImport.Visible = (isOn And Not mEdit)
    If isOn Then
        lblPerfHead.Top = 22: cboPerf.Top = 35
    Else
        lblPerfHead.Top = 8: cboPerf.Top = 22
    End If
End Sub

' Окно выбора пациента другого журнала (UserForm6) -> данные в поля окна регистрации
Private Sub ImportPatient()
    Dim f As UserForm6, rec As Variant, fl As String, got As Boolean
    If mEdit Then Exit Sub
    Set f = New UserForm6
    If f.Prepare() Then
        f.Show vbModal
        got = f.Chosen
        If got Then rec = f.Record: fl = f.Fields
    End If
    Unload f
    Set f = Nothing
    If got Then ApplyImported rec, fl
End Sub

' rec — запись пациента другого журнала (см. IMP_NF в Module2): 1 ФИО, 2 дата рождения,
' 3 отделение, 4 № мед. карты, 5 область, 6 оплата, 7 исполнитель, 8 анестезия, 9 дата
' исследования, 11 препарат, 12 доза, 13 «Для формы 30», 14 какие столбцы есть в том журнале.
' fl — что вносить (10 знаков «1»/«0»): ФИО, ДР, отделение, № карты, область, оплата,
' исполнитель, анестезия, контраст, «Для формы №30». Дата исследования берётся всегда.
Private Sub ApplyImported(ByVal rec As Variant, ByVal fl As String)
    Dim miss As String, s As String, sd As String, an As String, dayNote As String, av As String
    av = CStr(rec(14))
    mBusy = True
    s = Trim$(CStr(rec(9)))
    If s <> "" And s <> Trim$(CStr(txtStudyDate.Value)) Then
        txtStudyDate.Value = s
        dayNote = vbCrLf & vbCrLf & "Дата исследования в окне — " & s & ", как в другом журнале."
    End If
    If Want(fl, av, 1, 1) Then PatientName.Value = CStr(rec(1))
    If Want(fl, av, 2, 2) Then DoB.Value = CStr(rec(2))
    If Want(fl, av, 3, 3) Then
        s = Trim$(CStr(rec(3)))
        If Not PickCombo(cboDept, s) Then miss = miss & vbCrLf & "  • отделение «" & s & "» — нет в списке"
    End If
    If Want(fl, av, 4, 4) Then History_number.Value = CStr(rec(4))
    If Want(fl, av, 5, 5) Then txtArea.Value = CStr(rec(5))
    s = Trim$(CStr(rec(6)))
    If Want(fl, av, 6, 6) And s <> "" Then
        If Not PickPay(s) Then miss = miss & vbCrLf & "  • оплата «" & s & "» — нет такого варианта"
    End If
    s = Trim$(CStr(rec(7)))
    If Want(fl, av, 7, 7) And s <> "" Then
        If Not PickCombo(cboPerf, s) Then miss = miss & vbCrLf & "  • исполнитель «" & s & "» — нет в списке"
    End If
    an = NormTxt(CStr(rec(8)))
    If Want(fl, av, 8, 8) And an <> "" Then
        If Left$(an, 2) = "да" Or an = "+" Then
            optAnestYes.Value = True
        ElseIf Left$(an, 3) = "нет" Or an = "-" Then
            optAnestNo.Value = True
        Else
            miss = miss & vbCrLf & "  • анестезия «" & Trim$(CStr(rec(8))) & "» — выберите «да» или «нет»"
        End If
    End If
    ' контраст: в том журнале есть препарат/доза — «да» + препарат + доза (флаконы — вручную); пусто — «нет»
    If Want(fl, av, 9, 9) Then
        s = Trim$(CStr(rec(11))): sd = Trim$(CStr(rec(12)))
        If s <> "" Or sd <> "" Then
            optContrastYes.Value = True: ShowContrast True
            If s <> "" Then
                If Not PickCombo(cboContrast, s) Then miss = miss & vbCrLf & "  • контраст «" & s & "» — нет в списке препаратов"
            End If
            txtDose.Value = sd
            miss = miss & vbCrLf & "  • списанные флаконы контраста"
        Else
            optContrastNo.Value = True: ShowContrast False
        End If
    End If
    ' «Для формы №30» — галочки и количества
    If Want(fl, av, 10, 11) Then miss = miss & ApplyStudies(CStr(rec(13)))
    mBusy = False
    lblWarn.Visible = False
    If miss <> "" Then
        MsgBox "Данные пациента внесены. Выберите вручную:" & miss & dayNote, vbInformation, "Выгрузить пациента"
    ElseIf dayNote <> "" Then
        MsgBox "Данные пациента внесены." & dayNote, vbInformation, "Выгрузить пациента"
    End If
End Sub

' Вносить ли поле: отмечено галочкой (позиция fPos в fl) и столбец есть в том журнале
' (поле col записи, позиция col+1 в av; пустое av — считать, что есть)
Private Function Want(ByVal fl As String, ByVal av As String, ByVal fPos As Long, ByVal col As Long) As Boolean
    If Mid$(fl, fPos, 1) <> "1" Then Exit Function
    If Len(av) >= col + 1 Then
        If Mid$(av, col + 1, 1) = "0" Then Exit Function
    End If
    Want = True
End Function

' «Для формы 30» другого журнала («гм, шоп, суставы/мягкиеткани, суставы/мягкиеткани»,
' повтор = ещё одно исследование; «гм-2» — тоже понимается) -> галочки и количества рамки
' «Для формы №30». Возвращает строки «нет в списке» для сообщения.
Private Function ApplyStudies(ByVal s As String) As String
    Dim parts() As String, j As Long, i As Long, nm As String, cnt As Long, cnts() As Long
    Dim anyRare As Boolean, hit As Boolean, bad As String
    ClearStudies
    s = Trim$(s)
    If s = "" Or mNArea < 1 Then Exit Function
    ReDim cnts(0 To mNArea - 1)
    parts = Split(Replace(s, ";", ","), ",")
    For j = LBound(parts) To UBound(parts)
        If Trim$(parts(j)) <> "" Then
            ParseToken parts(j), "study", nm, cnt
            If cnt < 1 Then cnt = 1
            hit = False
            For i = 0 To mNArea - 1
                If NormTxt(mOrder(i)) = NormTxt(nm) Then
                    cnts(i) = cnts(i) + cnt: hit = True
                    Exit For
                End If
            Next i
            If Not hit Then bad = bad & vbCrLf & "  • для формы №30: «" & Trim$(parts(j)) & "» — нет в списке"
        End If
    Next j
    For i = 0 To mNArea - 1
        If cnts(i) > 0 Then
            If cnts(i) > 50 Then cnts(i) = 50
            frStudies.Controls("chkStudy_" & i).Value = True
            frStudies.Controls("spnStudy_" & i).Value = cnts(i)
            frStudies.Controls("lblStudy_" & i).Caption = CStr(cnts(i))
            If i >= mNCommon Then anyRare = True
        End If
    Next i
    If anyRare Then chkRare.Value = True
    ApplyStudies = bad
End Function

' Выбрать в списке значение, равное тексту (без учёта регистра, пробелов, точек, «ё»);
' нет равного — единственное, начинающееся так же. "" — очистить. False — не нашлось.
Private Function PickCombo(ByVal cb As MSForms.ComboBox, ByVal txt As String) As Boolean
    Dim i As Long, t As String, it As String, hit As Long, nHit As Long
    t = NormTxt(txt)
    If t = "" Then cb.ListIndex = -1: PickCombo = True: Exit Function
    For i = 0 To cb.ListCount - 1
        If NormTxt(CStr(cb.List(i))) = t Then cb.ListIndex = i: PickCombo = True: Exit Function
    Next i
    hit = -1
    For i = 0 To cb.ListCount - 1
        it = NormTxt(CStr(cb.List(i)))
        If it <> "" Then
            If Left$(it, Len(t)) = t Or Left$(t, Len(it)) = it Then hit = i: nHit = nHit + 1
        End If
    Next i
    If nHit = 1 Then cb.ListIndex = hit: PickCombo = True
End Function

Private Function PickPay(ByVal txt As String) As Boolean
    Dim i As Long, t As String
    t = NormTxt(txt)
    For i = 0 To UBoundS(mPays)
        If NormTxt(mPays(i)) = t Then
            ClearPay
            frPay.Controls("optPay_" & i).Value = True
            PickPay = True: Exit Function
        End If
    Next i
End Function

Private Function NormTxt(ByVal s As String) As String
    s = LCase$(Trim$(s))
    s = Replace(s, "ё", "е"): s = Replace(s, Chr(160), "")
    s = Replace(s, " ", ""): s = Replace(s, ".", "")
    NormTxt = s
End Function

' Выгрузить форму, только если она загружена (не создавая её заново)
Private Sub UnloadForm(ByVal nm As String)
    Dim f As Object
    On Error Resume Next
    For Each f In VBA.UserForms
        If TypeName(f) = nm Then Unload f: Exit For
    Next f
End Sub

Private Sub ToggleExcel()
    ' скрыть/показать окно Excel — чтобы форму можно было поставить рядом с эл. историей
    On Error Resume Next
    Application.Visible = Not Application.Visible
    SetTopMost (Application.Visible = False)   ' при скрытом Excel держим форму поверх всех окон
End Sub

Private Sub SetTopMost(ByVal onTop As Boolean)
    On Error Resume Next
    Dim h As Long
    h = FindWindow("ThunderDFrame", Me.Caption)          ' немодальная форма
    If h = 0 Then h = FindWindow("ThunderXFrame", Me.Caption)   ' на случай модальной
    If h <> 0 Then SetWindowPos h, IIf(onTop, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    On Error Resume Next
    Application.Visible = True        ' на всякий случай вернуть окно Excel
    CurrentRow = 0: Set gEditSheet = Nothing
End Sub