Pastein: ## ConsumerPickerPresenter.bas ```vb Attribute VB_Name = "ConsumerPickerPresenter" Option Explicit ' Presenter logic for the consumer picker form. ' Keeps UserForm1 handlers thin and uses a s

Загрузка данных
## ConsumerPickerPresenter.bas

```vb
Attribute VB_Name = "ConsumerPickerPresenter"
Option Explicit

' Presenter logic for the consumer picker form.
' Keeps UserForm1 handlers thin and uses a separate prompt dialog for custom naming.

Private mSyncingSpecial As Boolean
Private mUserSpecialChoice As Boolean

Public Sub InitializeForm(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub

    SelectionSession.CancelSelection
    SelectionSession.SetSelectionLevelCode vbNullString

    mUserSpecialChoice = SelectionSession.GetSelectionSpecial()
    SyncSpecialControls frm, mUserSpecialChoice
    frm.cmdDelete.Enabled = SelectionSession.CanDeleteSelectedRow()
    frm.cmdBack.Visible = False
    LoadLevel1 frm
    UpdateOkButtonState frm
End Sub

Public Sub HandleSpecialToggle(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub
    If mSyncingSpecial Then Exit Sub

    mUserSpecialChoice = CBool(frm.chkSpecial.Value)
    SyncSpecialControls frm, mUserSpecialChoice
End Sub

Public Sub HandleListSelectionChanged(ByVal frm As Object)
    Dim rowNorms As Long
    Dim targetSpecial As Boolean

    If frm Is Nothing Then Exit Sub

    rowNorms = GetSelectedNormRow(frm)
    targetSpecial = mUserSpecialChoice
    If rowNorms > 0 Then
        If NormsCatalog.IsNormDefaultSpecial(rowNorms) Then
            targetSpecial = True
        End If
    End If

    SyncSpecialControls frm, targetSpecial
    UpdateOkButtonState frm
End Sub

Public Sub HandleBack(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub

    SelectionSession.SetSelectionLevelCode vbNullString
    LoadLevel1 frm
    UpdateOkButtonState frm
End Sub

Public Function HandleListDoubleClick(ByVal frm As Object) As Boolean
    HandleListDoubleClick = FinalizeCurrentSelection(frm)
End Function

Public Function HandleOkClick(ByVal frm As Object) As Boolean
    HandleOkClick = FinalizeCurrentSelection(frm)
End Function

Public Function HandleCustomClick(ByVal frm As Object) As Boolean
    Dim customName As String

    If frm Is Nothing Then Exit Function

    If Not CustomConsumerPresenter.ShowCustomConsumerPrompt(customName) Then
        SyncSpecialControls frm, SelectionSession.GetSelectionSpecial()
        Exit Function
    End If

    SelectionSession.AcceptCustomSelection customName, SelectionSession.GetSelectionSpecial()
    HandleCustomClick = True
End Function

Public Function HandleDeleteClick(ByVal frm As Object) As Boolean
    If frm Is Nothing Then Exit Function
    If Not SelectionSession.CanDeleteSelectedRow() Then Exit Function

    SelectionSession.AcceptDeleteSelection CBool(frm.chkSpecial.value)
    HandleDeleteClick = True
End Function

Public Sub HandleQueryClose(ByVal CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        SelectionSession.CancelSelection
    End If
End Sub

Private Function FinalizeCurrentSelection(ByVal frm As Object) As Boolean
    Dim rowNorms As Long
    Dim codeText As String
    Dim customName As String
    Dim promptResult As Long

    If frm Is Nothing Then Exit Function

    rowNorms = GetSelectedNormRow(frm)
    If rowNorms <= 0 Then Exit Function

    codeText = NormsCatalog.GetNormCode(rowNorms)
    If Right$(codeText, 1) = "." And NormsCatalog.HasChildNorms(codeText) Then
        SelectionSession.SetSelectionLevelCode codeText
        LoadLevel2 frm, codeText
        UpdateOkButtonState frm
        Exit Function
    End If

    If NormsCatalog.IsNormDefaultSpecial(rowNorms) And (Not CBool(frm.chkSpecial.Value)) Then
        SyncSpecialControls frm, False
    ElseIf NormsCatalog.IsNormDefaultSpecial(rowNorms) Then
        SyncSpecialControls frm, True
    Else
        SyncSpecialControls frm, mUserSpecialChoice
    End If

    promptResult = CustomNamePromptPresenter.ShowCustomNamePrompt()
    If promptResult < 0 Then
        SyncSpecialControls frm, SelectionSession.GetSelectionSpecial()
        Exit Function
    End If

    If promptResult > 0 Then
        customName = InputBox(PromptCustomNameText(), PromptCustomNameCaption())
        If StrPtr(customName) = 0 Then Exit Function
    End If

    SelectionSession.AcceptNormSelection rowNorms, Trim$(customName), SelectionSession.GetSelectionSpecial()
    FinalizeCurrentSelection = True
End Function

Private Sub LoadLevel1(ByVal frm As Object)
    Dim count As Long

    count = NormsCatalog.PopulateConsumerList(frm.ListBox1)
    frm.cmdBack.Visible = False
    frm.caption = Level1Caption(count)
    ClearCurrentSelection frm
End Sub

Private Sub LoadLevel2(ByVal frm As Object, ByVal levelCode As String)
    Dim count As Long

    count = NormsCatalog.PopulateConsumerList(frm.ListBox1, levelCode)
    frm.cmdBack.Visible = True
    frm.caption = Level2Caption(levelCode, count)
    ClearCurrentSelection frm
End Sub

Private Sub ClearCurrentSelection(ByVal frm As Object)
    On Error Resume Next
    frm.ListBox1.ListIndex = -1
    On Error GoTo 0
End Sub

Private Sub UpdateOkButtonState(ByVal frm As Object)
    SetControlEnabled frm, "cmdOK", (GetSelectedNormRow(frm) > 0)
End Sub

Private Function GetSelectedNormRow(ByVal frm As Object) As Long
    On Error Resume Next
    If frm.ListBox1.ListIndex < 0 Then Exit Function
    GetSelectedNormRow = CLng(Val(CStr(frm.ListBox1.List(frm.ListBox1.ListIndex, 1))))
    On Error GoTo 0
End Function

Private Sub SyncSpecialControls(ByVal frm As Object, ByVal newValue As Boolean)
    mSyncingSpecial = True
    SelectionSession.SetSelectionSpecial newValue

    On Error Resume Next
    frm.chkSpecial.value = newValue
    frm.chkSpecial.ForeColor = IIf(newValue, vbRed, vbBlack)
    frm.Label1.ForeColor = IIf(newValue, vbRed, vbBlack)
    On Error GoTo 0

    mSyncingSpecial = False
End Sub

Private Sub SetControlEnabled(ByVal frm As Object, ByVal controlName As String, ByVal isEnabled As Boolean)
    On Error Resume Next
    CallByName frm.Controls(controlName), "Enabled", VbLet, isEnabled
    On Error GoTo 0
End Sub

Private Function Level1Caption(ByVal count As Long) As String
    Level1Caption = PromptSelectConsumerText() & ". " & PromptLevel1Text() & " (" & PromptFoundText() & ": " & count & ")"
End Function

Private Function Level2Caption(ByVal levelCode As String, ByVal count As Long) As String
    Level2Caption = PromptLevel2Text() & ": " & levelCode & " (" & PromptFoundText() & ": " & count & ")"
End Function

Private Function PromptSelectConsumerText() As String
    PromptSelectConsumerText = ChrW$(1042) & ChrW$(1099) & ChrW$(1073) & ChrW$(1086) & ChrW$(1088) & " " & ChrW$(1087) & ChrW$(1086) & ChrW$(1090) & ChrW$(1088) & ChrW$(1077) & ChrW$(1073) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & ChrW$(1083) & ChrW$(1103)
End Function

Private Function PromptLevel1Text() As String
    PromptLevel1Text = ChrW$(1059) & ChrW$(1088) & ChrW$(1086) & ChrW$(1074) & ChrW$(1077) & ChrW$(1085) & ChrW$(1100) & " 1"
End Function

Private Function PromptLevel2Text() As String
    PromptLevel2Text = ChrW$(1059) & ChrW$(1088) & ChrW$(1086) & ChrW$(1074) & ChrW$(1077) & ChrW$(1085) & ChrW$(1100) & " 2"
End Function

Private Function PromptFoundText() As String
    PromptFoundText = ChrW$(1085) & ChrW$(1072) & ChrW$(1081) & ChrW$(1076) & ChrW$(1077) & ChrW$(1085) & ChrW$(1086)
End Function

Private Function PromptCustomNameText() As String
    PromptCustomNameText = ChrW$(1042) & ChrW$(1074) & ChrW$(1077) & ChrW$(1076) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & " " & ChrW$(1085) & ChrW$(1072) & ChrW$(1079) & ChrW$(1074) & ChrW$(1072) & ChrW$(1085) & ChrW$(1080) & ":"
End Function

Private Function PromptCustomNameCaption() As String
    PromptCustomNameCaption = ChrW$(1050) & ChrW$(1072) & ChrW$(1089) & ChrW$(1090) & ChrW$(1086) & ChrW$(1084) & ChrW$(1085) & ChrW$(1086) & ChrW$(1077) & " " & ChrW$(1085) & ChrW$(1072) & ChrW$(1079) & ChrW$(1074) & ChrW$(1072) & ChrW$(1085) & ChrW$(1080) & ChrW$(1077)
End Function

Private Function PromptCustomConsumerText() As String
    PromptCustomConsumerText = ChrW$(1042) & ChrW$(1074) & ChrW$(1077) & ChrW$(1076) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & " " & ChrW$(1085) & ChrW$(1072) & ChrW$(1079) & ChrW$(1074) & ChrW$(1072) & ChrW$(1085) & ChrW$(1080) & ChrW$(1077) & " " & ChrW$(1087) & ChrW$(1086) & ChrW$(1090) & ChrW$(1088) & ChrW$(1077) & ChrW$(1073) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & ChrW$(1083) & ChrW$(1103) & ":"
End Function

Private Function PromptCustomConsumerCaption() As String
    PromptCustomConsumerCaption = ChrW$(1057) & ChrW$(1074) & ChrW$(1086) & ChrW$(1080) & " " & ChrW$(1076) & ChrW$(1072) & ChrW$(1085) & ChrW$(1085) & ChrW$(1099) & ChrW$(1077)
End Function

```



222222



## CustomConsumerPresenter.bas

```vb
Attribute VB_Name = "CustomConsumerPresenter"
Option Explicit

' Presenter for the dedicated fully custom consumer form.
' This path does not use the regular yes/no name prompt.

Private mSyncing As Boolean
Private mAccepted As Boolean
Private mCustomName As String

Private Const CUSTOM_NAME_LABEL_NAME As String = "lblDynamicCustomName"
Private Const CUSTOM_NAME_TEXTBOX_NAME As String = "txtDynamicCustomName"

Public Function ShowCustomConsumerPrompt(ByRef customName As String) As Boolean
    Dim frm As Object

    mAccepted = False
    mCustomName = vbNullString

    Set frm = New CustomConsumerForm
    frm.Show vbModal

    If Not mAccepted Then Exit Function

    customName = mCustomName
    ShowCustomConsumerPrompt = (Len(Trim$(customName)) > 0)
End Function

Public Sub InitializeForm(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub

    ConfigureDynamicControls frm

    On Error Resume Next
    frm.caption = ChrW$(1057) & ChrW$(1074) & ChrW$(1086) & ChrW$(1080) & " " & ChrW$(1076) & ChrW$(1072) & ChrW$(1085) & ChrW$(1085) & ChrW$(1099) & ChrW$(1077)
    frm.cmdYes.caption = ChrW$(1054) & ChrW$(1050)
    frm.cmdNo.caption = ChrW$(1054) & ChrW$(1090) & ChrW$(1084) & ChrW$(1077) & ChrW$(1085) & ChrW$(1072)
    frm.cmdYes.Default = True
    frm.cmdNo.Cancel = True
    frm.Controls(CUSTOM_NAME_TEXTBOX_NAME).Text = vbNullString
    frm.Controls(CUSTOM_NAME_TEXTBOX_NAME).SetFocus
    On Error GoTo 0

    SyncSpecialControls frm, SelectionSession.GetSelectionSpecial()
End Sub

Public Sub HandleSpecialToggle(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub
    If mSyncing Then Exit Sub

    SyncSpecialControls frm, CBool(frm.chkSpecialMirror.value)
End Sub

Public Function HandleOkClick(ByVal frm As Object) As Boolean
    If frm Is Nothing Then Exit Function

    mCustomName = Trim$(ReadNameValue(frm))
    If Len(mCustomName) = 0 Then Exit Function

    SelectionSession.SetSelectionSpecial CBool(frm.chkSpecialMirror.value)
    mAccepted = True
    HandleOkClick = True
End Function

Public Function HandleCancelClick(ByVal frm As Object) As Boolean
    mAccepted = False
    HandleCancelClick = True
End Function

Public Function HandleQueryClose(ByVal frm As Object) As Boolean
    mAccepted = False
    HandleQueryClose = True
End Function

Private Sub SyncSpecialControls(ByVal frm As Object, ByVal newValue As Boolean)
    mSyncing = True
    SelectionSession.SetSelectionSpecial newValue

    On Error Resume Next
    frm.chkSpecialMirror.value = newValue
    frm.chkSpecialMirror.ForeColor = IIf(newValue, vbRed, vbBlack)
    frm.lblSpecialMirror.ForeColor = IIf(newValue, vbRed, vbBlack)
    On Error GoTo 0

    mSyncing = False
End Sub

Private Function ReadNameValue(ByVal frm As Object) As String
    Dim ctrl As Object

    On Error Resume Next
    Set ctrl = frm.Controls(CUSTOM_NAME_TEXTBOX_NAME)
    If Not ctrl Is Nothing Then
        ReadNameValue = Trim$(CStr(ctrl.Value))
        If Len(ReadNameValue) = 0 Then ReadNameValue = Trim$(CStr(ctrl.Text))
    End If
    On Error GoTo 0
End Function

Private Sub ConfigureDynamicControls(ByVal frm As Object)
    Dim lbl As Object
    Dim txt As Object

    On Error Resume Next
    frm.Controls.Remove CUSTOM_NAME_LABEL_NAME
    frm.Controls.Remove CUSTOM_NAME_TEXTBOX_NAME
    On Error GoTo 0

    On Error Resume Next
    Set lbl = frm.Controls.Add("Forms.Label.1", CUSTOM_NAME_LABEL_NAME, True)
    With lbl
        .caption = ChrW$(1042) & ChrW$(1074) & ChrW$(1077) & ChrW$(1076) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & " " & ChrW$(1085) & ChrW$(1072) & ChrW$(1079) & ChrW$(1074) & ChrW$(1072) & ChrW$(1085) & ChrW$(1080) & ChrW$(1077) & " " & ChrW$(1087) & ChrW$(1086) & ChrW$(1090) & ChrW$(1088) & ChrW$(1077) & ChrW$(1073) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & ChrW$(1083) & ChrW$(1103) & ":"
        .Left = 300
        .Top = 360
        .Width = 5000
        .Height = 240
        .Font.Name = "Arial"
        .Font.Size = 8
        .ForeColor = vbBlack
        .BackStyle = fmBackStyleTransparent
    End With

    Set txt = frm.Controls.Add("Forms.TextBox.1", CUSTOM_NAME_TEXTBOX_NAME, True)
    With txt
        .Left = 300
        .Top = 630
        .Width = 7600
        .Height = 300
        .Font.Name = "Arial"
        .Font.Size = 8
        .Text = vbNullString
    End With
    On Error GoTo 0
End Sub

```




33333




## CustomConsumerPresenter.bas

```vb
Attribute VB_Name = "CustomConsumerPresenter"
Option Explicit

' Presenter for the dedicated fully custom consumer form.
' This path does not use the regular yes/no name prompt.

Private mSyncing As Boolean
Private mAccepted As Boolean
Private mCustomName As String

Private Const CUSTOM_NAME_LABEL_NAME As String = "lblDynamicCustomName"
Private Const CUSTOM_NAME_TEXTBOX_NAME As String = "txtDynamicCustomName"

Public Function ShowCustomConsumerPrompt(ByRef customName As String) As Boolean
    Dim frm As Object

    mAccepted = False
    mCustomName = vbNullString

    Set frm = New CustomConsumerForm
    frm.Show vbModal

    If Not mAccepted Then Exit Function

    customName = mCustomName
    ShowCustomConsumerPrompt = (Len(Trim$(customName)) > 0)
End Function

Public Sub InitializeForm(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub

    ConfigureDynamicControls frm

    On Error Resume Next
    frm.caption = ChrW$(1057) & ChrW$(1074) & ChrW$(1086) & ChrW$(1080) & " " & ChrW$(1076) & ChrW$(1072) & ChrW$(1085) & ChrW$(1085) & ChrW$(1099) & ChrW$(1077)
    frm.cmdYes.caption = ChrW$(1054) & ChrW$(1050)
    frm.cmdNo.caption = ChrW$(1054) & ChrW$(1090) & ChrW$(1084) & ChrW$(1077) & ChrW$(1085) & ChrW$(1072)
    frm.cmdYes.Default = True
    frm.cmdNo.Cancel = True
    frm.Controls(CUSTOM_NAME_TEXTBOX_NAME).Text = vbNullString
    frm.Controls(CUSTOM_NAME_TEXTBOX_NAME).SetFocus
    On Error GoTo 0

    SyncSpecialControls frm, SelectionSession.GetSelectionSpecial()
End Sub

Public Sub HandleSpecialToggle(ByVal frm As Object)
    If frm Is Nothing Then Exit Sub
    If mSyncing Then Exit Sub

    SyncSpecialControls frm, CBool(frm.chkSpecialMirror.value)
End Sub

Public Function HandleOkClick(ByVal frm As Object) As Boolean
    If frm Is Nothing Then Exit Function

    mCustomName = Trim$(ReadNameValue(frm))
    If Len(mCustomName) = 0 Then Exit Function

    SelectionSession.SetSelectionSpecial CBool(frm.chkSpecialMirror.value)
    mAccepted = True
    HandleOkClick = True
End Function

Public Function HandleCancelClick(ByVal frm As Object) As Boolean
    mAccepted = False
    HandleCancelClick = True
End Function

Public Function HandleQueryClose(ByVal frm As Object) As Boolean
    mAccepted = False
    HandleQueryClose = True
End Function

Private Sub SyncSpecialControls(ByVal frm As Object, ByVal newValue As Boolean)
    mSyncing = True
    SelectionSession.SetSelectionSpecial newValue

    On Error Resume Next
    frm.chkSpecialMirror.value = newValue
    frm.chkSpecialMirror.ForeColor = IIf(newValue, vbRed, vbBlack)
    frm.lblSpecialMirror.ForeColor = IIf(newValue, vbRed, vbBlack)
    On Error GoTo 0

    mSyncing = False
End Sub

Private Function ReadNameValue(ByVal frm As Object) As String
    Dim ctrl As Object

    On Error Resume Next
    Set ctrl = frm.Controls(CUSTOM_NAME_TEXTBOX_NAME)
    If Not ctrl Is Nothing Then
        ReadNameValue = Trim$(CStr(ctrl.Value))
        If Len(ReadNameValue) = 0 Then ReadNameValue = Trim$(CStr(ctrl.Text))
    End If
    On Error GoTo 0
End Function

Private Sub ConfigureDynamicControls(ByVal frm As Object)
    Dim lbl As Object
    Dim txt As Object

    On Error Resume Next
    frm.Controls.Remove CUSTOM_NAME_LABEL_NAME
    frm.Controls.Remove CUSTOM_NAME_TEXTBOX_NAME
    On Error GoTo 0

    On Error Resume Next
    Set lbl = frm.Controls.Add("Forms.Label.1", CUSTOM_NAME_LABEL_NAME, True)
    With lbl
        .caption = ChrW$(1042) & ChrW$(1074) & ChrW$(1077) & ChrW$(1076) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & " " & ChrW$(1085) & ChrW$(1072) & ChrW$(1079) & ChrW$(1074) & ChrW$(1072) & ChrW$(1085) & ChrW$(1080) & ChrW$(1077) & " " & ChrW$(1087) & ChrW$(1086) & ChrW$(1090) & ChrW$(1088) & ChrW$(1077) & ChrW$(1073) & ChrW$(1080) & ChrW$(1090) & ChrW$(1077) & ChrW$(1083) & ChrW$(1103) & ":"
        .Left = 300
        .Top = 360
        .Width = 5000
        .Height = 240
        .Font.Name = "Arial"
        .Font.Size = 8
        .ForeColor = vbBlack
        .BackStyle = fmBackStyleTransparent
    End With

    Set txt = frm.Controls.Add("Forms.TextBox.1", CUSTOM_NAME_TEXTBOX_NAME, True)
    With txt
        .Left = 300
        .Top = 630
        .Width = 7600
        .Height = 300
        .Font.Name = "Arial"
        .Font.Size = 8
        .Text = vbNullString
    End With
    On Error GoTo 0
End Sub

```





44444




## Diagnostics.bas

```vb
Attribute VB_Name = "Diagnostics"
Option Explicit

' Lightweight diagnostics for runtime and layout invariants.
' Output goes to the VBA Immediate window via Debug.Print.

Private CurrentOperationName As String
Private CurrentOperationStartedAt As Date
Private CurrentOperationSteps As Collection
Private CurrentOperationHasError As Boolean

Public Sub BeginOperation(ByVal operationName As String)
    CurrentOperationName = Trim$(operationName)
    CurrentOperationStartedAt = Now
    CurrentOperationHasError = False
    Set CurrentOperationSteps = New Collection

    Debug.Print TimestampPrefix() & "BEGIN " & CurrentOperationName
End Sub

Public Sub MarkStepOk(ByVal stepName As String, Optional ByVal details As String = "")
    AppendStep "OK", stepName, details
End Sub

Public Sub MarkStepError(ByVal stepName As String, Optional ByVal details As String = "")
    CurrentOperationHasError = True
    AppendStep "ERROR", stepName, details
End Sub

Public Sub FinishOperation(Optional ByVal finalStatus As String = "OK")
    Dim statusText As String
    Dim item As Variant

    If Len(CurrentOperationName) = 0 Then Exit Sub

    statusText = UCase$(Trim$(finalStatus))
    If CurrentOperationHasError And statusText = "OK" Then statusText = "ERROR"

    Debug.Print TimestampPrefix() & "END " & CurrentOperationName & " [" & statusText & "]"
    If Not CurrentOperationSteps Is Nothing Then
        For Each item In CurrentOperationSteps
            Debug.Print "  " & CStr(item)
        Next item
    End If

    CurrentOperationName = vbNullString
    CurrentOperationStartedAt = 0
    CurrentOperationHasError = False
    Set CurrentOperationSteps = Nothing
End Sub

Public Function IsOperationActive() As Boolean
    IsOperationActive = (Len(CurrentOperationName) > 0)
End Function

Public Function AssertCoreState(Optional ByVal stageName As String = "") As Boolean
    Dim runtimeIssues As String
    Dim layoutIssues As String
    Dim issueText As String

    runtimeIssues = ValidateRuntimeState()
    layoutIssues = ValidateLayoutState()

    If Len(runtimeIssues) > 0 Then issueText = runtimeIssues
    If Len(layoutIssues) > 0 Then
        If Len(issueText) > 0 Then issueText = issueText & " | "
        issueText = issueText & layoutIssues
    End If

    AssertCoreState = (Len(issueText) = 0)
    If AssertCoreState Then Exit Function

    If Len(stageName) > 0 Then
        Debug.Print TimestampPrefix() & "CORE CHECK FAILED [" & stageName & "] " & issueText
    Else
        Debug.Print TimestampPrefix() & "CORE CHECK FAILED " & issueText
    End If
End Function

Public Function ValidateRuntimeState() As String
    Dim rowIndex As Long
    Dim rowText As String

    If StateRuntime.RuntimeRowsCount < 1 Then
        AddIssue ValidateRuntimeState, "RuntimeRowsCount < 1"
        Exit Function
    End If

    If StateRuntime.RuntimeEFCount < StateRuntime.RuntimeRowsCount Then
        AddIssue ValidateRuntimeState, "RuntimeEFCount < RuntimeRowsCount"
    End If

    For rowIndex = 1 To StateRuntime.RuntimeRowsCount
        If Not StateRuntime.RuntimeRowExists(rowIndex) Then
            AddIssue ValidateRuntimeState, "Missing runtime slot " & rowIndex
            GoTo NextRow
        End If

        If StateRuntime.RuntimeRowHasData(rowIndex) And StateRuntime.RuntimeRows(rowIndex).rowID <= 0 Then
            AddIssue ValidateRuntimeState, "Row " & rowIndex & " has data but no RowID"
        End If

        If StateRuntime.RuntimeRows(rowIndex).IsCustom Then
            rowText = Trim$(StateRuntime.RuntimeRows(rowIndex).consumerName)
            If Len(rowText) = 0 Then AddIssue ValidateRuntimeState, "Custom row " & rowIndex & " has blank ConsumerName"
        End If
NextRow:
    Next rowIndex
End Function

Public Function ValidateLayoutState() As String
    Dim layout As CoreBlockLayout
    Dim rowIndex As Long
    Dim previousPhysicalRow As Long
    Dim currentPhysicalRow As Long

    layout = LayoutEngine.BuildBlockLayout()

    If layout.LogicalRowCount <> StateRuntime.GetRuntimeLogicalRowCount() Then
        AddIssue ValidateLayoutState, "LogicalRowCount mismatch"
    End If

    If layout.filledNormalCount <> LayoutEngine.CountNormalRows() Then
        AddIssue ValidateLayoutState, "FilledNormalCount mismatch"
    End If

    If layout.filledSpecialCount <> LayoutEngine.CountSpecialRows() Then
        AddIssue ValidateLayoutState, "FilledSpecialCount mismatch"
    End If

    If layout.blockSize < 2 Then
        AddIssue ValidateLayoutState, "BlockSize < 2"
    End If

    For rowIndex = 1 To layout.LogicalRowCount
        currentPhysicalRow = LayoutEngine.GetPhysicalRow(1, rowIndex, layout)
        If currentPhysicalRow <= 0 Then
            AddIssue ValidateLayoutState, "Missing physical row for logical row " & rowIndex
            GoTo NextRow
        End If

        If previousPhysicalRow > 0 And currentPhysicalRow < previousPhysicalRow Then
            AddIssue ValidateLayoutState, "Physical rows are not monotonic"
            Exit For
        End If
        previousPhysicalRow = currentPhysicalRow
NextRow:
    Next rowIndex

    If layout.HasMixedGroups Then
        If layout.upperTotalRow <= layout.UpperPlaceholderRow Then AddIssue ValidateLayoutState, "Upper total row order is invalid"
        If layout.LowerFirstRow <= layout.upperTotalRow Then AddIssue ValidateLayoutState, "Lower section starts before upper total"
        If layout.lowerTotalRow <= layout.LowerPlaceholderRow Then AddIssue ValidateLayoutState, "Lower total row order is invalid"
        If layout.GrandTotalRow <= layout.lowerTotalRow Then AddIssue ValidateLayoutState, "Grand total row order is invalid"
    End If
End Function

Public Function SnapshotState() As String
    Dim layout As CoreBlockLayout
    Dim rowIndex As Long
    Dim lineText As String

    layout = LayoutEngine.BuildBlockLayout()
    lineText = "rows=" & StateRuntime.RuntimeRowsCount & ", normals=" & layout.filledNormalCount & ", specials=" & layout.filledSpecialCount & ", blockSize=" & layout.blockSize

    For rowIndex = 1 To StateRuntime.RuntimeRowsCount
        lineText = lineText & " | #" & rowIndex & ":" & RowSnapshot(rowIndex)
    Next rowIndex

    SnapshotState = lineText
End Function

Private Sub AppendStep(ByVal statusText As String, ByVal stepName As String, ByVal details As String)
    Dim lineText As String

    lineText = "[" & UCase$(Trim$(statusText)) & "] " & Trim$(stepName)
    If Len(Trim$(details)) > 0 Then lineText = lineText & " - " & Trim$(details)

    If CurrentOperationSteps Is Nothing Then Set CurrentOperationSteps = New Collection
    CurrentOperationSteps.Add lineText
    Debug.Print TimestampPrefix() & lineText
End Sub

Private Sub AddIssue(ByRef issueText As String, ByVal newIssue As String)
    If Len(issueText) > 0 Then issueText = issueText & "; "
    issueText = issueText & newIssue
End Sub

Private Function RowSnapshot(ByVal rowIndex As Long) As String
    Dim stateText As String

    If Not StateRuntime.RuntimeRowExists(rowIndex) Then
        RowSnapshot = "missing"
        Exit Function
    End If

    If StateRuntime.RuntimeRowHasData(rowIndex) Then
        stateText = "filled"
    Else
        stateText = "empty"
    End If

    RowSnapshot = StateRuntime.RuntimeRows(rowIndex).rowID & _
        ":" & IIf(StateRuntime.RuntimeRows(rowIndex).IsSpecial, "S", "N") & _
        ":" & stateText
End Function

Private Function TimestampPrefix() As String
    TimestampPrefix = Format$(Now, "hh:nn:ss") & " "
End Function

```


55555





## NormsCatalog.bas

```vb
Attribute VB_Name = "NormsCatalog"
Option Explicit

' Read-only access to the Norms sheet.
' This module centralizes row lookup and editable-mask rules.

Private CachedNormRows() As Variant
Private CachedNormRowLoaded() As Boolean
Private CachedNormRowUpperBound As Long
Private CachedNormLookupLoaded As Boolean
Private CachedNormLookupLastRow As Long
Private CachedNormCodes() As String
Private CachedNormNames() As String
Private CachedNormDefaultSpecial() As Boolean
Private CachedNormByConsumer As Object
Private CachedNormByCode As Object

Public Function LoadNormsValues(ByVal rowNorms As Long) As Variant
    Dim wsN As Worksheet

    If rowNorms <= 0 Then Exit Function

    EnsureNormRowCacheCapacity rowNorms
    If CachedNormRowLoaded(rowNorms) Then
        LoadNormsValues = CachedNormRows(rowNorms)
        Exit Function
    End If

    Set wsN = GetNormsSheet()
    If wsN Is Nothing Then Exit Function

    CachedNormRows(rowNorms) = wsN.Range(wsN.Cells(rowNorms, 2), wsN.Cells(rowNorms, 14)).value
    CachedNormRowLoaded(rowNorms) = True
    LoadNormsValues = CachedNormRows(rowNorms)
End Function

Public Function ResolveNormsRow(ByVal consumerName As String, ByVal codeB As String) As Long
    ResolveNormsRow = ResolveNormsRowByConsumer(consumerName)
    If ResolveNormsRow > 0 Then Exit Function

    If Len(Trim$(codeB)) > 0 Then
        ResolveNormsRow = ResolveNormsRowByCode(codeB)
    End If
End Function

Public Function ResolveNormsRowByConsumer(ByVal consumerName As String) As Long
    Dim searchName As String

    searchName = NormalizeNormsText(consumerName)
    If Len(searchName) = 0 Then Exit Function

    EnsureNormLookupCache
    If CachedNormByConsumer Is Nothing Then Exit Function
    If CachedNormByConsumer.Exists(searchName) Then ResolveNormsRowByConsumer = CLng(CachedNormByConsumer(searchName))
End Function

Public Function ResolveNormsRowByCode(ByVal codeB As String) As Long
    Dim searchCode As String

    searchCode = Trim$(Replace(CStr(codeB), " ", vbNullString))
    If Len(searchCode) = 0 Then Exit Function

    EnsureNormLookupCache
    If CachedNormByCode Is Nothing Then Exit Function
    If CachedNormByCode.Exists(searchCode) Then ResolveNormsRowByCode = CLng(CachedNormByCode(searchCode))
End Function

Public Function GetNormCode(ByVal rowNorms As Long) As String
    If rowNorms <= 0 Then Exit Function
    EnsureNormLookupCache
    If rowNorms > CachedNormLookupLastRow Then Exit Function
    GetNormCode = CachedNormCodes(rowNorms)
End Function

Public Function PopulateConsumerList(ByVal listBox As Object, Optional ByVal levelCode As String = "") As Long
    Dim rowNum As Long
    Dim codeText As String
    Dim nameText As String

    If listBox Is Nothing Then Exit Function

    EnsureNormLookupCache
    If CachedNormLookupLastRow < 7 Then Exit Function

    listBox.Clear

    For rowNum = 7 To CachedNormLookupLastRow
        codeText = CachedNormCodes(rowNum)
        nameText = CachedNormNames(rowNum)
        If Len(nameText) = 0 Then GoTo NextRow

        If Len(levelCode) = 0 Then
            If IsTopLevelNorm(codeText) Then
                listBox.AddItem nameText
                listBox.List(listBox.ListCount - 1, 1) = rowNum
                PopulateConsumerList = PopulateConsumerList + 1
            End If
        ElseIf Left$(codeText, Len(levelCode)) = levelCode And Len(codeText) > Len(levelCode) Then
            listBox.AddItem nameText
            listBox.List(listBox.ListCount - 1, 1) = rowNum
            PopulateConsumerList = PopulateConsumerList + 1
        End If
NextRow:
    Next rowNum
End Function

Public Function HasChildNorms(ByVal levelCode As String) As Boolean
    Dim rowNum As Long
    Dim codeText As String

    If Len(levelCode) = 0 Then Exit Function

    EnsureNormLookupCache
    If CachedNormLookupLastRow < 7 Then Exit Function

    For rowNum = 7 To CachedNormLookupLastRow
        codeText = CachedNormCodes(rowNum)
        If Left$(codeText, Len(levelCode)) = levelCode And Len(codeText) > Len(levelCode) Then
            HasChildNorms = True
            Exit Function
        End If
    Next rowNum
End Function

Public Function GetNormEditableMask(ByVal rowNorms As Long, ByVal blockNum As Long) As Variant
    Dim mask(1 To 4) As Boolean
    Dim valueIndex As Long

    If rowNorms <= 0 Then
        GetNormEditableMask = mask
        Exit Function
    End If

    For valueIndex = 1 To 4
        mask(valueIndex) = NeedsManualReplacement(GetNormDefaultValue(rowNorms, blockNum, valueIndex))
    Next valueIndex

    GetNormEditableMask = mask
End Function

Public Function GetNormDefaultValue(ByVal rowNorms As Long, ByVal blockNum As Long, ByVal valueIndex As Long) As Variant
    Dim normsValues As Variant

    If rowNorms <= 0 Then Exit Function
    If valueIndex < 1 Or valueIndex > 4 Then Exit Function

    normsValues = LoadNormsValues(rowNorms)
    If IsEmpty(normsValues) Then Exit Function

    Select Case blockNum
        Case 1
            Select Case valueIndex
                Case 1: GetNormDefaultValue = normsValues(1, 4)
                Case 2: GetNormDefaultValue = normsValues(1, 6)
                Case 3: GetNormDefaultValue = normsValues(1, 9)
                Case 4: GetNormDefaultValue = normsValues(1, 10)
            End Select
        Case 2
            Select Case valueIndex
                Case 1: GetNormDefaultValue = ResolveBlock2GValue(normsValues)
                Case 2: GetNormDefaultValue = normsValues(1, 8)
                Case 3: GetNormDefaultValue = normsValues(1, 11)
                Case 4: GetNormDefaultValue = normsValues(1, 12)
            End Select
        Case 3
            Select Case valueIndex
                Case 1: GetNormDefaultValue = normsValues(1, 5)
                Case 2: GetNormDefaultValue = normsValues(1, 7)
                Case 3: GetNormDefaultValue = normsValues(1, 11)
                Case 4: GetNormDefaultValue = normsValues(1, 12)
            End Select
    End Select
End Function

Public Function IsNormValueManual(ByVal rowNorms As Long, ByVal blockNum As Long, ByVal valueIndex As Long) As Boolean
    IsNormValueManual = NeedsManualReplacement(GetNormDefaultValue(rowNorms, blockNum, valueIndex))
End Function

Public Function IsNormDefaultSpecial(ByVal rowNorms As Long) As Boolean
    If rowNorms <= 0 Then Exit Function
    EnsureNormLookupCache
    If rowNorms > CachedNormLookupLastRow Then Exit Function
    IsNormDefaultSpecial = CachedNormDefaultSpecial(rowNorms)
End Function

Public Function GetNormWorkTime(ByVal rowNorms As Long) As Variant
    Dim normsValues As Variant

    If rowNorms <= 0 Then Exit Function

    normsValues = LoadNormsValues(rowNorms)
    If IsEmpty(normsValues) Then Exit Function

    GetNormWorkTime = normsValues(1, 13)
End Function

Public Sub ResetNormsRowCache()
    Erase CachedNormRows
    Erase CachedNormRowLoaded
    CachedNormRowUpperBound = 0
    CachedNormLookupLoaded = False
    CachedNormLookupLastRow = 0
    Erase CachedNormCodes
    Erase CachedNormNames
    Erase CachedNormDefaultSpecial
    Set CachedNormByConsumer = Nothing
    Set CachedNormByCode = Nothing
End Sub

Private Sub EnsureNormLookupCache()
    Dim wsN As Worksheet
    Dim lastRow As Long
    Dim rawData As Variant
    Dim rowNum As Long
    Dim codeText As String
    Dim nameText As String
    Dim markerText As String

    If CachedNormLookupLoaded Then Exit Sub

    Set wsN = GetNormsSheet()
    If wsN Is Nothing Then Exit Sub

    lastRow = wsN.Cells(wsN.Rows.count, 3).End(xlUp).Row
    CachedNormLookupLastRow = lastRow
    If lastRow < 7 Then
        CachedNormLookupLoaded = True
        Exit Sub
    End If

    rawData = wsN.Range(wsN.Cells(7, 2), wsN.Cells(lastRow, 15)).value
    ReDim CachedNormCodes(1 To lastRow)
    ReDim CachedNormNames(1 To lastRow)
    ReDim CachedNormDefaultSpecial(1 To lastRow)
    Set CachedNormByConsumer = CreateObject("Scripting.Dictionary")
    Set CachedNormByCode = CreateObject("Scripting.Dictionary")

    For rowNum = 7 To lastRow
        codeText = Trim$(CStr(rawData(rowNum - 6, 1)))
        nameText = Trim$(CStr(rawData(rowNum - 6, 2)))
        markerText = Trim$(CStr(rawData(rowNum - 6, 14)))

        CachedNormCodes(rowNum) = codeText
        CachedNormNames(rowNum) = nameText
        CachedNormDefaultSpecial(rowNum) = (markerText = "!")

        If Len(nameText) > 0 Then
            nameText = NormalizeNormsText(nameText)
            If Len(nameText) > 0 Then
                If Not CachedNormByConsumer.Exists(nameText) Then CachedNormByConsumer.Add nameText, rowNum
            End If
        End If

        If Len(codeText) > 0 Then
            codeText = Trim$(Replace(codeText, " ", vbNullString))
            If Not CachedNormByCode.Exists(codeText) Then CachedNormByCode.Add codeText, rowNum
        End If
    Next rowNum

    CachedNormLookupLoaded = True
End Sub

Private Function GetNormsSheet() As Worksheet
    On Error Resume Next
    Set GetNormsSheet = ThisWorkbook.Worksheets(NormsSheetName())
    On Error GoTo 0
End Function

Private Function NormalizeNormsText(ByVal rawValue As Variant) As String
    NormalizeNormsText = Trim$(Replace(CStr(rawValue), " ", vbNullString))
End Function

Private Function IsManualNormToken(ByVal rawValue As Variant) As Boolean
    Dim textValue As String

    textValue = Trim$(CStr(rawValue))
    If Len(textValue) = 0 Then Exit Function
    If IsNumeric(rawValue) Then Exit Function

    IsManualNormToken = True
End Function

Private Function NeedsManualReplacement(ByVal rawValue As Variant) As Boolean
    If IsEmpty(rawValue) Or IsNull(rawValue) Then Exit Function
    If Len(Trim$(CStr(rawValue))) = 0 Then Exit Function
    If IsNumeric(rawValue) Then Exit Function

    NeedsManualReplacement = True
End Function

Private Function ResolveBlock2GValue(ByVal normsValues As Variant) As Variant
    If IsNumeric(normsValues(1, 4)) And IsNumeric(normsValues(1, 5)) Then
        ResolveBlock2GValue = CDbl(normsValues(1, 4)) - CDbl(normsValues(1, 5))
        Exit Function
    End If

    If IsManualNormToken(normsValues(1, 4)) Then
        ResolveBlock2GValue = CStr(normsValues(1, 4))
    ElseIf IsManualNormToken(normsValues(1, 5)) Then
        ResolveBlock2GValue = CStr(normsValues(1, 5))
    End If
End Function

Private Function IsTopLevelNorm(ByVal codeText As String) As Boolean
    If Len(codeText) < 2 Then Exit Function
    If Right$(codeText, 1) <> "." Then Exit Function
    If Not IsNumeric(Left$(codeText, 1)) Then Exit Function

    IsTopLevelNorm = True
End Function

Private Sub EnsureNormRowCacheCapacity(ByVal rowNorms As Long)
    Dim newUpperBound As Long

    If rowNorms <= CachedNormRowUpperBound Then Exit Sub

    newUpperBound = rowNorms + 64
    If newUpperBound < 128 Then newUpperBound = 128

    If CachedNormRowUpperBound = 0 Then
        ReDim CachedNormRows(1 To newUpperBound)
        ReDim CachedNormRowLoaded(1 To newUpperBound)
    Else
        ReDim Preserve CachedNormRows(1 To newUpperBound)
        ReDim Preserve CachedNormRowLoaded(1 To newUpperBound)
    End If

    CachedNormRowUpperBound = newUpperBound
End Sub
```
Больше возможностей при регистрации:
