Проверка параграфа

gistfile1.vb

Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rsFundData As ADODB.Recordset
Dim rsFundStats As ADODB.Recordset
Dim rsInventoryData As ADODB.Recordset
Dim rsInventoryStats As ADODB.Recordset
Dim rsInventoriesWithPdf As ADODB.Recordset
Dim rsInventoriesWithPdfCount As ADODB.Recordset
Dim rsFilledIsnInventory As ADODB.Recordset
Dim totalInventories As Integer

Private Sub ConnectSqlServer()
    Dim sConnString As String
 
    ' Create the connection string.
    sConnString = "Provider=SQLOLEDB;Data Source=winserver2008;" & _
                  "Initial Catalog=ArchiveFund5;" & _
                  "Integrated Security=SSPI;"
    
    ' Create the Connection and Recordset objects.
    Set conn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseClient
    
    ' Open the connection and execute.
    conn.Open sConnString
End Sub

' Удаляет все содержимое документа
Private Sub PrepareDocument()
  Selection.WholeStory
  Selection.TypeBackspace
  Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
  Selection.Font.Name = "Times New Roman"
  Selection.Font.Size = 14
    With Selection.ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceMultiple
        .LineSpacing = LinesToPoints(1.15)
        .Alignment = wdAlignParagraphJustify
        .WidowControl = True
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
    End With
End Sub

' Показывает текст загрузки
Private Sub LoadingText()
  MsgBox "Сейчас начнется обработка данных. Не закрывайте документ и ничего не печатайте. Нажмите ОК.", vbExclamation
End Sub

Private Sub FinishText()
  MsgBox "Обработка данных закончена. Можете сохранить или распечатать отчет.", vbInformation
End Sub

' Пишет, сколько всего записей внес параграф
Private Sub ShowTotalRecords()
  Set rs = conn.Execute("SELECT COUNT(*) as count FROM tblUNIT " & _
           "WHERE NOTE LIKE '%параграф%' and Deleted <> 1;")
  ' Проверить, что есть данные
  If Not rs.EOF Then
    rs.MoveFirst
    totalRecords = rs![Count].value
  End If
  ' Закрыть рекордсет
  rs.Close
  
  ' Запишем в ворд
  Selection.TypeText Text:="В общей сложности введено единиц хранения: "
  Selection.Font.Bold = True
  Selection.TypeText Text:=totalRecords & "."
  Selection.TypeParagraph
  Selection.Font.Bold = False
End Sub

Private Sub ShowRecordsInInventoriesAndFunds()
  ' во сколько описей вносились заголовки
  Set rs = conn.Execute("SELECT TOP 1 COUNT(*) OVER() as Count FROM tblUNIT " & _
                        "WHERE NOTE LIKE '%параграф%' and Deleted <> 1 GROUP BY ISN_INVENTORY;")
  ' Проверить, что есть данные
  If Not rs.EOF Then
    rs.MoveFirst
    totalInventories = rs![Count].value
  End If
  ' Закрыть рекордсет
  rs.Close
  
  ' во сколько фондов заносились заголовки
  Set rs = conn.Execute("SELECT TOP 1 COUNT(*) OVER() as Count FROM tblINVENTORY WHERE " & _
                        "ISN_INVENTORY IN (SELECT ISN_INVENTORY FROM tblUNIT WHERE NOTE LIKE " & _
                        "'%параграф%' and Deleted <> 1 GROUP BY ISN_INVENTORY) GROUP BY ISN_FUND;")
  ' Проверить, что есть данные
  If Not rs.EOF Then
    rs.MoveFirst
    totalFunds = rs![Count].value
  End If
  ' Закрыть рекордсет
  rs.Close
  
  ' Вывести инфу в ворд
  Selection.TypeText Text:="Записи введены в "
  Selection.Font.Bold = True
  Selection.TypeText Text:=totalInventories
  Selection.Font.Bold = False
  Selection.TypeText Text:=" описей в "
  Selection.Font.Bold = True
  Selection.TypeText Text:=totalFunds
  Selection.Font.Bold = False
  Selection.TypeText Text:=" фондах."
  Selection.TypeParagraph
End Sub

Private Sub ShowFilledFunds()
  ' Вычислить ID фондов, в которые заносились записи
  Set rs = conn.Execute("SELECT ISN_FUND FROM tblINVENTORY WHERE " & _
                        "ISN_INVENTORY IN (SELECT ISN_INVENTORY FROM tblUNIT WHERE NOTE LIKE " & _
                        "'%параграф%' and Deleted <> 1 GROUP BY ISN_INVENTORY) GROUP BY ISN_FUND;")
                        
  ' Нарисовать шапку, если в выборке были результаты
  If Not rs.EOF Then
    Selection.TypeParagraph
    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _
        3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With Selection.Tables(1)
        If .Style <> "Сетка таблицы" Then
            .Style = "Сетка таблицы"
        End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
    End With
    Selection.TypeText Text:="номер"
    Selection.TypeParagraph
    Selection.TypeText Text:="фонда"
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="ед.хр. в"
    Selection.TypeParagraph
    Selection.TypeText Text:="итоговой записи"
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="введено"
    Selection.TypeParagraph
    Selection.TypeText Text:="ед.хр."
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=7, Extend:=wdExtend
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.Font.Bold = True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
  End If
  
  ' Пройтись по найденным фондам
  rs.MoveFirst
  While Not rs.EOF
    currentIsnFund = rs![ISN_FUND].value
    ' Выудить номер фонда
    Set rsFundData = conn.Execute("SELECT TOP 1 FUND_NUM_2 FROM tblFUND WHERE ISN_FUND = " & CStr(currentIsnFund) & ";")
    rsFundData.MoveFirst
    currentFundNum = rsFundData![FUND_NUM_2].value
    rsFundData.Close
    Set rsFundStats = conn.Execute("SELECT UNIT_COUNT, UNIT_REGISTERED FROM tblDOCUMENT_STATS where ISN_FUND=" & _
                                   currentIsnFund & " and CARRIER_TYPE IS NULL and ISN_INVENTORY IS NULL;")
    currentUnitCount = rsFundStats![UNIT_COUNT].value
    currentUnitRegistered = rsFundStats![UNIT_REGISTERED].value
    
    ''' Рисование строки с вытащенными данными
    Selection.InsertRowsBelow 1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentFundNum
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentUnitCount
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentUnitRegistered
    ''' Нарисовал строку
    
    rsFundStats.Close
    rs.MoveNext
  Wend
  ' Закрыть рекордсет
  rs.Close
  ' Убрать курсор из таблицы
  Selection.MoveDown Unit:=wdLine, Count:=1
End Sub

Private Sub ShowFilledInventories()
  ' Вычислить ID описей, в которые заносились записи
  Set rsFilledIsnInventory = conn.Execute("SELECT ISN_INVENTORY FROM tblUNIT WHERE NOTE " & _
                        "LIKE '%параграф%' and Deleted <> 1 GROUP BY ISN_INVENTORY;")
                        
  ' Нарисовать шапку, если в выборке были результаты
  If Not rsFilledIsnInventory.EOF Then
    Selection.TypeParagraph
    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _
        4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With Selection.Tables(1)
        If .Style <> "Сетка таблицы" Then
            .Style = "Сетка таблицы"
        End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
    End With
    Selection.TypeText Text:="номер"
    Selection.TypeParagraph
    Selection.TypeText Text:="фонда"
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="номер"
    Selection.TypeParagraph
    Selection.TypeText Text:="описи"
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="ед.хр. в"
    Selection.TypeParagraph
    Selection.TypeText Text:="итоговой записи"
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.TypeText Text:="введено"
    Selection.TypeParagraph
    Selection.TypeText Text:="ед.хр."
    Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=8, Extend:=wdExtend
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.Font.Bold = True
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
  End If
  
  ' Пройтись по найденным описям
  rsFilledIsnInventory.MoveFirst
  While Not rsFilledIsnInventory.EOF
    currentIsnInventory = rsFilledIsnInventory![ISN_INVENTORY].value
    ' Выудить номер описи
    Set rsInventoryData = conn.Execute("SELECT TOP 1 ISN_FUND, INVENTORY_NUM_1, INVENTORY_NUM_3 FROM tblINVENTORY WHERE ISN_INVENTORY = " & CStr(currentIsnInventory) & ";")
    rsInventoryData.MoveFirst
    currentInventoryNum = rsInventoryData![INVENTORY_NUM_1].value
    If Not IsEmpty(rsInventoryData![INVENTORY_NUM_3].value) And rsInventoryData![INVENTORY_NUM_3].value <> "" Then
      currentInventoryPart = " т. " & rsInventoryData![INVENTORY_NUM_3].value
    Else
      currentInventoryPart = ""
    End If
    currentInventoryIsnFund = rsInventoryData![ISN_FUND].value
    rsInventoryData.Close
    ' Выудить номер фонда
    Set rsFundData = conn.Execute("SELECT TOP 1 FUND_NUM_2 FROM tblFUND WHERE ISN_FUND = " & CStr(currentInventoryIsnFund) & ";")
    rsFundData.MoveFirst
    currentInventoryFundNum = rsFundData![FUND_NUM_2].value
    rsFundData.Close
    Set rsInventoryStats = conn.Execute("SELECT UNIT_COUNT, UNIT_REGISTERED FROM tblDOCUMENT_STATS where ISN_INVENTORY=" & _
                                   currentIsnInventory & " and CARRIER_TYPE IS NULL;")
    currentUnitCount = rsInventoryStats![UNIT_COUNT].value
    currentUnitRegistered = rsInventoryStats![UNIT_REGISTERED].value
    
    ''' Рисование строки с вытащенными данными
    Selection.InsertRowsBelow 1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentInventoryFundNum
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentInventoryNum
    Selection.TypeText Text:=currentInventoryPart
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentUnitCount
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.Font.Bold = False
    Selection.TypeText Text:=currentUnitRegistered
    ''' Нарисовал строку
    
    'rsInventoryStats.Close
    rsFilledIsnInventory.MoveNext
  Wend
  ' Потом этот рекордсет будет еще использоваться, так что вернем курсор на первую позицию
  rsFilledIsnInventory.MoveFirst
  ' Убрать курсор из таблицы
  Selection.MoveDown Unit:=wdLine, Count:=1
End Sub

Private Sub ShowInventoriesWithoutPdf()
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  Dim l As Integer
  Dim isFound As Boolean
  ' Массив с ID описей, внесенными параграфом
  Dim arrInventoriesOverall() As String
  ' Массив с ID описей, внесенных параграфом и к которым прикреплены pdf
  Dim arrInventoriesWithPdf() As String
  ' ID описей, внесенных параграфом и к которым не прикреплены pdf, строка,
  ' потому что потом это дело засунется в SQL запрос
  Dim InventoriesWoPdf As String
  
  ' Вычислить количество карточек описей с прикрепленными pdf-ками
  Set rsInventoriesWithPdfCount = conn.Execute("SELECT top 1 COUNT(*) OVER() as Count FROM tblREF_FILE where ISN_OBJ IN " & _
                                          "(SELECT ISN_INVENTORY FROM tblUNIT WHERE NOTE LIKE '%параграф%' " & _
                                          "and Deleted <> 1 GROUP BY ISN_INVENTORY) GROUP BY ISN_OBJ;")
  currentPdfCount = rsInventoriesWithPdfCount![Count].value
  rsInventoriesWithPdfCount.Close
  
  ' Вычислить ID описей с прикрепленными pdf файлами
  Set rsInventoriesWithPdf = conn.Execute("SELECT ISN_OBJ FROM tblREF_FILE where ISN_OBJ IN " & _
                                          "(SELECT ISN_INVENTORY FROM tblUNIT WHERE NOTE LIKE '%параграф%' " & _
                                          "and Deleted <> 1 GROUP BY ISN_INVENTORY) GROUP BY ISN_OBJ;")
  ' Преобразовать recordset в массив
  If Not rsInventoriesWithPdf.EOF Then
    k = 0
    rsInventoriesWithPdf.MoveFirst
    While Not rsInventoriesWithPdf.EOF
      ReDim Preserve arrInventoriesWithPdf(k)
      arrInventoriesWithPdf(k) = rsInventoriesWithPdf![ISN_OBJ].value
      k = k + 1
      rsInventoriesWithPdf.MoveNext
    Wend
  End If
  
  rsInventoriesWithPdf.Close
  
  ' Преобразовать recordset с найденными раньше ID описей, внесенных параграфом, в массив
  If Not rsFilledIsnInventory.EOF Then
    k = 0
    rsFilledIsnInventory.MoveFirst
    While Not rsFilledIsnInventory.EOF
      ReDim Preserve arrInventoriesOverall(k)
      arrInventoriesOverall(k) = rsFilledIsnInventory![ISN_INVENTORY].value
      k = k + 1
      rsFilledIsnInventory.MoveNext
    Wend
  End If

  ' Вычислить ID описей, к которым не прикреплены pdf
  l = 0
  InventoriesWoPdf = ""
  For i = 0 To UBound(arrInventoriesOverall)
    isFound = False
    For j = 0 To UBound(arrInventoriesWithPdf)
      If arrInventoriesOverall(i) = arrInventoriesWithPdf(j) Then
        isFound = True
      End If
    Next 'j
    If Not isFound Then
      If InventoriesWoPdf <> "" Then
        InventoriesWoPdf = InventoriesWoPdf & ", " & arrInventoriesOverall(i)
      Else
        InventoriesWoPdf = arrInventoriesOverall(i)
      End If
      l = l + 1
    End If
  Next i
  
  Set rsWoPdfInfo = conn.Execute("select tblFund.FUND_NUM_2, tblINVENTORY.INVENTORY_NUM_1, tblINVENTORY.INVENTORY_NUM_3  from tblInventory, tblFUND where tblInventory.isn_inventory IN (" & InventoriesWoPdf & ") and tblFund.ISN_FUND = tblINVENTORY.ISN_FUND;")
  
  Selection.TypeParagraph
  Selection.TypeText Text:="Из "
  Selection.Font.Bold = True
  Selection.TypeText Text:=totalInventories & " "
  Selection.Font.Bold = False
  Selection.TypeText Text:="описей pdf файлы прикреплены к "
  Selection.Font.Bold = True
  Selection.TypeText Text:=currentPdfCount
  Selection.Font.Bold = False
  Selection.TypeText Text:=" карточкам."
  
  If Not rsWoPdfInfo.EOF Then
    Selection.TypeParagraph
    Selection.TypeText Text:="Карточки описей, к которым не прикреплены PDF файлы:"
    rsWoPdfInfo.MoveFirst
    While Not rsWoPdfInfo.EOF
      Selection.TypeParagraph
      Selection.TypeText Text:="ф. " & rsWoPdfInfo![FUND_NUM_2].value & " оп. " & rsWoPdfInfo![INVENTORY_NUM_1].value
      If Not IsEmpty(rsWoPdfInfo![INVENTORY_NUM_3].value) And rsWoPdfInfo![INVENTORY_NUM_3].value <> "" And rsWoPdfInfo![INVENTORY_NUM_3].value <> 0 Then
        Selection.TypeText Text:=" т. " & rsWoPdfInfo![INVENTORY_NUM_3].value
      End If
      rsWoPdfInfo.MoveNext
    Wend
  End If
  Selection.TypeParagraph
  rsWoPdfInfo.Close
End Sub

' Вычисляет, в каких описях, введенных параграфом, пропущены заголовки
Private Sub ShowInventoriesWithMissingNumbers()
  Dim i As Integer
  Dim rsUnitsInfo As ADODB.Recordset
  ' Номер фонда, номер и том описи
  Dim rsInventoryInfo As ADODB.Recordset
  ' Пропущенные заголовки в описи
  Dim missedUnitsIndex As Integer
  Dim missedUnits() As Integer
  ' Пропущенные заголовки в описи, только в человеческом формате,
  ' диапазонами, а не сплошной нумерацией
  Dim missedUnitsS As String
  Dim CutFrom, CutDiff As Integer
  ' Логично, что пропуски в заголовках нужно искать, если описи ввели.
  rsFilledIsnInventory.MoveFirst
  If Not rsFilledIsnInventory.EOF Then
    Selection.TypeParagraph
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.TypeText Text:="Описи, в которых пропущены номера единиц хранения"
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineNone
    ' Изначально считаем, что пропущенных номеров нет
    noMissingNumbers = True
    ' Пройдемся по каждой описи
    While Not rsFilledIsnInventory.EOF
      Set rsUnitsInfo = conn.Execute("SELECT COUNT(*) OVER() as Count, cast(UNIT_NUM_1 as int) as UNIT_NUM_1 from tblUNIT where ISN_INVENTORY=" & rsFilledIsnInventory![ISN_INVENTORY].value & " and Deleted = 0 AND (UNIT_NUM_2 IS NULL OR UNIT_NUM_2 = '') GROUP BY UNIT_NUM_1 ORDER BY UNIT_NUM_1 DESC;")
      CutFrom = 0
      If Not rsUnitsInfo.EOF Then
        rsUnitsInfo.MoveFirst
        ' Задать размер массиву с пропущенными заголовками
        missedUnitsIndex = rsUnitsInfo![UNIT_NUM_1].value - rsUnitsInfo![Count].value
        ReDim Preserve missedUnits(missedUnitsIndex)
        ' Строковый вариант пропущенных заголовков опустошить
        missedUnitsS = ""
        ' Ни к чему прогонять тысячи записей, если в них не пропущена нумерация
        If missedUnitsIndex > 0 Then
          MoreUnitsForProcessing = 0
          While Not rsUnitsInfo.EOF
            MoreUnitsForProcessing = rsUnitsInfo![UNIT_NUM_1].value - 1
            If CutFrom <> 0 And CutFrom > rsUnitsInfo![UNIT_NUM_1].value Then
              ' Сколько выйдет в результате вычитания, столько номеров пропущено
              CutDiff = CutFrom - rsUnitsInfo![UNIT_NUM_1].value - 1
              ' Если больше нуля, значит, есть пропущенные
              If CutDiff > 0 Then
                ' Дополнить строковую переменную диапазоном пропущенных заголовков
                ' ну или одним заголовком
                If CutDiff = 1 Then
                  missedUnitsS = rsUnitsInfo![UNIT_NUM_1].value + 1 & ", " & missedUnitsS
                Else
                  missedUnitsS = rsUnitsInfo![UNIT_NUM_1].value + 1 & "-" & CutFrom - 1 & ", " & missedUnitsS
                End If
                noMissingNumbers = False
                For i = CutFrom - 1 To CutFrom - CutDiff Step -1
                  missedUnits(missedUnitsIndex - 1) = i
                  missedUnitsIndex = missedUnitsIndex - 1
                Next i
              End If
            End If
            ' На следующей итерации будем вычитать из текущего номера единицы хранения
            CutFrom = rsUnitsInfo![UNIT_NUM_1].value
            rsUnitsInfo.MoveNext
          Wend
          ' Если список дел начинается не с первого номера, автоматически дозаполнить
          ' список пропущенных заголовков до единицы
          If MoreUnitsForProcessing > 0 Then
            If MoreUnitsForProcessing = 1 Then
              missedUnitsS = "1, " & missedUnitsS
            Else
              missedUnitsS = "1-" & MoreUnitsForProcessing & ", " & missedUnitsS
            End If
            While Not MoreUnitsForProcessing = 0
              missedUnits(missedUnitsIndex - 1) = MoreUnitsForProcessing
              missedUnitsIndex = missedUnitsIndex - 1
              MoreUnitsForProcessing = MoreUnitsForProcessing - 1
            Wend
          End If
        End If
        ' Если есть пропущенные заголовки, получим информацию о фонде и описи
        ' и выведем список пропущенных заголовков
        If UBound(missedUnits) > 0 Then
          Set rsInventoryInfo = conn.Execute("select top 1 tblFund.FUND_NUM_2, tblINVENTORY.INVENTORY_NUM_1, tblINVENTORY.INVENTORY_NUM_3  from tblInventory, tblFUND where tblInventory.isn_inventory = " & rsFilledIsnInventory![ISN_INVENTORY] & " and tblFund.ISN_FUND = tblINVENTORY.ISN_FUND;")
          If Not rsInventoryInfo.EOF Then
            Selection.TypeParagraph
            Selection.TypeParagraph
            Selection.Font.Bold = True
            Selection.TypeText Text:="ф. " & rsInventoryInfo![FUND_NUM_2]
            Selection.TypeText Text:=" оп. " & rsInventoryInfo![INVENTORY_NUM_1]
            If Not IsEmpty(rsInventoryInfo![INVENTORY_NUM_3].value) And rsInventoryInfo![INVENTORY_NUM_3].value <> "" Then
              Selection.TypeText Text:=" т. " & rsInventoryInfo![INVENTORY_NUM_3].value
            End If
            Selection.TypeText Text:=" (пропущено " & UBound(missedUnits) & "): "
            Selection.Font.Bold = False
            ' Раскомментировать, если нужно вывести числовой вариант списка
            'For missedUnitNum = 0 To UBound(missedUnits) - 1
            '  Selection.TypeText Text:=missedUnits(missedUnitNum) & ", "
            'Next missedUnitNum
            Selection.TypeText Text:=missedUnitsS
            Selection.TypeBackspace
            Selection.TypeBackspace
          End If
        End If
      End If
      rsUnitsInfo.Close
      rsFilledIsnInventory.MoveNext
    Wend
    If noMissingNumbers Then
      Selection.Font.Bold = True
      Selection.TypeText Text:=" отсутствуют"
      Selection.Font.Bold = False
    End If
  End If
End Sub

Private Sub ShowInventoriesWithLetterUnits()
  ' Список единиц хранения с литерными номерами
  Dim rsInventoriesWithLetterUnits As ADODB.Recordset
  ' Флаг, указывающий на отсутствие литерных заголовков
  Dim noLetterNumbers As Boolean
  ' Идентификатор записанного ранее заголовка. Содержит номер фонда,
  ' описи и тома. Используется, если надо начать новый абзац
  Dim prevNumIdentifier As String
  ' Идентификатор текущего заголовка. Содержит номер фонда,
  ' описи и тома. Используется для сравнения с параметром prevNumIdentifier
  Dim currNumIdentifier As String
  ' Собственно, список литерных заголовков описи
  Dim unitsList As String
  
  ' Получить список единиц хранения с литерными номерами
  Set rsInventoriesWithLetterUnits = conn.Execute( _
    "SELECT" & _
      " cast (tblFUND.FUND_NUM_2 as int) AS FUND_NUM_2," & _
      " cast (tblINVENTORY.INVENTORY_NUM_1 as int) AS INVENTORY_NUM_1," & _
      " cast (tblINVENTORY.INVENTORY_NUM_3 as int) AS INVENTORY_NUM_3," & _
      " cast (tblUNIT.UNIT_NUM_1 as int) AS UNIT_NUM_1," & _
      " tblUNIT.UNIT_NUM_2 " & _
    "FROM tblUNIT, tblINVENTORY, tblFUND " & _
    "WHERE" & _
      " (tblUNIT.UNIT_NUM_2 IS NOT NULL AND tblUNIT.UNIT_NUM_2 <> '')" & _
      " AND tblUNIT.Deleted <> 1" & _
      " AND tblUNIT.NOTE LIKE '%параграф%'" & _
      " AND tblUNIT.ISN_INVENTORY = tblINVENTORY.ISN_INVENTORY" & _
      " AND tblINVENTORY.ISN_FUND = tblFUND.ISN_FUND " & _
    "ORDER BY" & _
      " FUND_NUM_2 ASC," & _
      " INVENTORY_NUM_1 ASC," & _
      " INVENTORY_NUM_3 ASC," & _
      " UNIT_NUM_1 ASC," & _
      " UNIT_NUM_2 ASC;")
  
  Selection.TypeParagraph
  Selection.TypeParagraph
  Selection.Font.UnderlineColor = wdColorAutomatic
  Selection.Font.Underline = wdUnderlineSingle
  Selection.TypeText Text:="Описи, в которых присутствуют литерные номера единиц хранения  "
  Selection.Font.UnderlineColor = wdColorAutomatic
  Selection.Font.Underline = wdUnderlineNone
  ' Изначально считаем, что литерных номеров нет
  noLetterNumbers = True
  ' Пока ни одного заголовка не посмотрели, так что
  ' иденификатор предыдущего заголовка пустой
  prevNumIdentifier = ""
  unitsList = ""
  rsInventoriesWithLetterUnits.MoveFirst
  If Not rsInventoriesWithLetterUnits.EOF Then
    ' Если есть результат запроса, значит есть литерные заголовки.
    ' Установим флаг в false, чтобы не вывелась запись об отсутствии
    noLetterNumbers = False
    While Not rsInventoriesWithLetterUnits.EOF
      If Not IsEmpty(rsInventoriesWithLetterUnits![INVENTORY_NUM_3].value) And rsInventoriesWithLetterUnits![INVENTORY_NUM_3].value <> "" Then
        currNumIdentifier = CStr(rsInventoriesWithLetterUnits![FUND_NUM_2]) & "." & _
                            CStr(rsInventoriesWithLetterUnits![INVENTORY_NUM_1]) & "." & _
                            CStr(rsInventoriesWithLetterUnits![INVENTORY_NUM_3])
      Else
        currNumIdentifier = CStr(rsInventoriesWithLetterUnits![FUND_NUM_2]) & "." & _
                            CStr(rsInventoriesWithLetterUnits![INVENTORY_NUM_1])
      End If
      ' Если текущий и предыдущий идентификаторы не совпадают,
      ' выведем вычисленный список литерных заголовков в текущей описи
      If currNumIdentifier <> prevNumIdentifier Then
        ' выводим список, только если он есть
        ' и сразу очищаем
        Selection.TypeText Text:=unitsList
        unitsList = ""
        ' записать новый номер описи, предварительно убрав две запятые в конце списка заголовков
        Selection.TypeBackspace
        Selection.TypeBackspace
        Selection.TypeParagraph
        Selection.TypeParagraph
        Selection.Font.Bold = True
        Selection.TypeText Text:="ф. " & rsInventoriesWithLetterUnits![FUND_NUM_2]
        Selection.TypeText Text:=" оп. " & rsInventoriesWithLetterUnits![INVENTORY_NUM_1]
        If Not IsEmpty(rsInventoriesWithLetterUnits![INVENTORY_NUM_3].value) And rsInventoriesWithLetterUnits![INVENTORY_NUM_3].value <> "" And rsInventoriesWithLetterUnits![INVENTORY_NUM_3].value <> 0 Then
          Selection.TypeText Text:=" т. " & rsInventoriesWithLetterUnits![INVENTORY_NUM_3].value
        End If
        Selection.TypeText Text:=": "
        Selection.Font.Bold = False
        ' сменить идентификатор на текущий
        prevNumIdentifier = currNumIdentifier
      End If
      unitsList = unitsList & rsInventoriesWithLetterUnits![UNIT_NUM_1] & rsInventoriesWithLetterUnits![UNIT_NUM_2] & ", "
      rsInventoriesWithLetterUnits.MoveNext
    Wend
    ' Вывести последний список литерных заголовков
    Selection.TypeText Text:=unitsList
    Selection.TypeBackspace
    Selection.TypeBackspace
  End If
  
  If noLetterNumbers Then
    Selection.Font.Bold = True
    Selection.TypeText Text:=" отсутствуют"
    Selection.Font.Bold = False
  End If
  
  ' Закрыть рекордсет
  rsInventoriesWithLetterUnits.Close
End Sub

Private Sub ShowInventoriesWithLostUnits()
  ' Список единиц хранения с выбывшими номерами
  Dim rsInventoriesWithLostUnits As ADODB.Recordset
  ' Флаг, указывающий на отсутствие выбывших заголовков
  Dim noLostNumbers As Boolean
  ' Идентификатор записанного ранее заголовка. Содержит номер фонда,
  ' описи и тома. Используется, если надо начать новый абзац
  Dim prevNumIdentifier As String
  ' Идентификатор текущего заголовка. Содержит номер фонда,
  ' описи и тома. Используется для сравнения с параметром prevNumIdentifier
  Dim currNumIdentifier As String
  ' Собственно, список выбывших заголовков описи
  Dim unitsList As String
  
  ' Получить список единиц хранения с выбывшими номерами
  Set rsInventoriesWithLostUnits = conn.Execute( _
    "SELECT" & _
      " cast (tblFUND.FUND_NUM_2 as int) AS FUND_NUM_2," & _
      " cast (tblINVENTORY.INVENTORY_NUM_1 as int) AS INVENTORY_NUM_1," & _
      " cast (tblINVENTORY.INVENTORY_NUM_3 as int) AS INVENTORY_NUM_3," & _
      " cast (tblUNIT.UNIT_NUM_1 as int) AS UNIT_NUM_1," & _
      " tblUNIT.UNIT_NUM_2 " & _
    "FROM tblUNIT, tblINVENTORY, tblFUND " & _
    "WHERE" & _
      " tblUNIT.IS_LOST = 'Y'" & _
      " AND tblUNIT.Deleted <> 1" & _
      " AND tblUNIT.NOTE LIKE '%параграф%'" & _
      " AND tblUNIT.ISN_INVENTORY = tblINVENTORY.ISN_INVENTORY" & _
      " AND tblINVENTORY.ISN_FUND = tblFUND.ISN_FUND " & _
    "ORDER BY" & _
      " FUND_NUM_2 ASC," & _
      " INVENTORY_NUM_1 ASC," & _
      " INVENTORY_NUM_3 ASC," & _
      " UNIT_NUM_1 ASC," & _
      " UNIT_NUM_2 ASC;")
  
  Selection.TypeParagraph
  Selection.TypeParagraph
  Selection.Font.UnderlineColor = wdColorAutomatic
  Selection.Font.Underline = wdUnderlineSingle
  Selection.TypeText Text:="Описи, в которых присутствуют выбывшие единицы хранения  "
  Selection.Font.UnderlineColor = wdColorAutomatic
  Selection.Font.Underline = wdUnderlineNone
  ' Изначально считаем, что выбывших номеров нет
  noLostNumbers = True
  ' Пока ни одного заголовка не посмотрели, так что
  ' иденификатор предыдущего заголовка пустой
  prevNumIdentifier = ""
  unitsList = ""
  If Not rsInventoriesWithLostUnits.EOF Then
    rsInventoriesWithLostUnits.MoveFirst
    ' Если есть результат запроса, значит есть выбывшие заголовки.
    ' Установим флаг в false, чтобы не вывелась запись об отсутствии
    noLostNumbers = False
    While Not rsInventoriesWithLostUnits.EOF
      If Not IsEmpty(rsInventoriesWithLostUnits![INVENTORY_NUM_3].value) And rsInventoriesWithLostUnits![INVENTORY_NUM_3].value <> "" Then
        currNumIdentifier = CStr(rsInventoriesWithLostUnits![FUND_NUM_2]) & "." & _
                            CStr(rsInventoriesWithLostUnits![INVENTORY_NUM_1]) & "." & _
                            CStr(rsInventoriesWithLostUnits![INVENTORY_NUM_3])
      Else
        currNumIdentifier = CStr(rsInventoriesWithLostUnits![FUND_NUM_2]) & "." & _
                            CStr(rsInventoriesWithLostUnits![INVENTORY_NUM_1])
      End If
      ' Если текущий и предыдущий идентификаторы не совпадают,
      ' выведем вычисленный список выбывших заголовков в текущей описи
      If currNumIdentifier <> prevNumIdentifier Then
        ' выводим список, только если он есть
        ' и сразу очищаем
        Selection.TypeText Text:=unitsList
        unitsList = ""
        ' записать новый номер описи, предварительно убрав две запятые в конце списка заголовков
        Selection.TypeBackspace
        Selection.TypeBackspace
        Selection.TypeParagraph
        Selection.TypeParagraph
        Selection.Font.Bold = True
        Selection.TypeText Text:="ф. " & rsInventoriesWithLostUnits![FUND_NUM_2]
        Selection.TypeText Text:=" оп. " & rsInventoriesWithLostUnits![INVENTORY_NUM_1]
        If Not IsEmpty(rsInventoriesWithLostUnits![INVENTORY_NUM_3].value) And rsInventoriesWithLostUnits![INVENTORY_NUM_3].value <> "" And rsInventoriesWithLostUnits![INVENTORY_NUM_3].value <> 0 Then
          Selection.TypeText Text:=" т. " & rsInventoriesWithLostUnits![INVENTORY_NUM_3].value
        End If
        Selection.TypeText Text:=": "
        Selection.Font.Bold = False
        ' сменить идентификатор на текущий
        prevNumIdentifier = currNumIdentifier
      End If
      unitsList = unitsList & rsInventoriesWithLostUnits![UNIT_NUM_1] & rsInventoriesWithLostUnits![UNIT_NUM_2] & ", "
      rsInventoriesWithLostUnits.MoveNext
    Wend
    ' Вывести последний список выбывших заголовков
    Selection.TypeText Text:=unitsList
    Selection.TypeBackspace
    Selection.TypeBackspace
  End If
  
  If noLostNumbers Then
    Selection.Font.Bold = True
    Selection.TypeText Text:=" отсутствуют"
    Selection.Font.Bold = False
  End If
  
  ' Закрыть рекордсет
  rsInventoriesWithLostUnits.Close
End Sub

Private Sub ShowInventoruesWithVolumes()
  ' Список описей с томами
  Dim rsInventoriesWithVolumes As ADODB.Recordset
  ' Флаг, указывающий на отсутствие описей с томами
  Dim noVolumes As Boolean
  
  ' Получить список описей с томами
  Set rsInventoriesWithVolumes = conn.Execute( _
    "SELECT" & _
      " cast (tblFUND.FUND_NUM_2 as int) AS FUND_NUM_2," & _
      " cast (tblINVENTORY.INVENTORY_NUM_1 as int) AS INVENTORY_NUM_1," & _
      " tblINVENTORY.INVENTORY_NUM_3 " & _
    "FROM tblUNIT, tblINVENTORY, tblFUND " & _
    "WHERE" & _
      " (tblINVENTORY.INVENTORY_NUM_3 IS NOT NULL AND tblINVENTORY.INVENTORY_NUM_3 <> '' AND tblINVENTORY.INVENTORY_NUM_3 <> '0')" & _
      " AND tblUNIT.Deleted <> 1" & _
      " AND tblUNIT.NOTE LIKE '%параграф%'" & _
      " AND tblUNIT.ISN_INVENTORY = tblINVENTORY.ISN_INVENTORY" & _
      " AND tblINVENTORY.ISN_FUND = tblFUND.ISN_FUND " & _
    "GROUP BY" & _
      " FUND_NUM_2, INVENTORY_NUM_1, INVENTORY_NUM_3 " & _
    "ORDER BY" & _
      " FUND_NUM_2 ASC," & _
      " INVENTORY_NUM_1 ASC," & _
      " INVENTORY_NUM_3 ASC;")
  
  Selection.TypeParagraph
  Selection.TypeParagraph
  Selection.Font.UnderlineColor = wdColorAutomatic
  Selection.Font.Underline = wdUnderlineSingle
  Selection.TypeText Text:="Описи с томами: "
  Selection.Font.UnderlineColor = wdColorAutomatic
  Selection.Font.Underline = wdUnderlineNone
  ' Изначально считаем, что описей с томами нет
  noVolumes = True
  If Not rsInventoriesWithVolumes.EOF Then
    rsInventoriesWithVolumes.MoveFirst
    ' Если есть результат запроса, значит есть описи с томами.
    ' Установим флаг в false, чтобы не вывелась запись об отсутствии
    noVolumes = False
    While Not rsInventoriesWithVolumes.EOF
        Selection.TypeBackspace
        Selection.TypeParagraph
        Selection.TypeParagraph
        Selection.Font.Bold = True
        Selection.TypeText Text:="ф. " & rsInventoriesWithVolumes![FUND_NUM_2]
        Selection.TypeText Text:=" оп. " & rsInventoriesWithVolumes![INVENTORY_NUM_1]
        If Not IsEmpty(rsInventoriesWithVolumes![INVENTORY_NUM_3].value) And rsInventoriesWithVolumes![INVENTORY_NUM_3].value <> "" And rsInventoriesWithVolumes![INVENTORY_NUM_3].value <> 0 Then
          Selection.TypeText Text:=" т. " & rsInventoriesWithVolumes![INVENTORY_NUM_3].value
        End If
        Selection.TypeText Text:=", "
        Selection.Font.Bold = False
      rsInventoriesWithVolumes.MoveNext
    Wend
    Selection.TypeBackspace
    Selection.TypeBackspace
  End If
  
  If noVolumes Then
    Selection.Font.Bold = True
    Selection.TypeText Text:=" отсутствуют"
    Selection.Font.Bold = False
  End If
  
  ' Закрыть рекордсет
  rsInventoriesWithVolumes.Close
End Sub

Private Sub Document_Open()
  Dim answer
  
  ConnectSqlServer
  
  answer = MsgBox("Могу я автоматически выполнить расчет? Понадобится некоторое время. Если вы просто хотите посмотреть страый отчет, можете нажать 'Нет'", vbYesNo)
  If answer = vbYes Then
    PrepareDocument
    LoadingText
    ShowTotalRecords
    ShowRecordsInInventoriesAndFunds
    ShowFilledFunds
    ShowFilledInventories
    ShowInventoriesWithoutPdf
    ShowInventoriesWithMissingNumbers
    ShowInventoriesWithLetterUnits
    ShowInventoriesWithLostUnits
    ShowInventoruesWithVolumes
    FinishText
  End If
End Sub

Private Sub Document_Close()
  ' Закрываем соединения
  If CBool(conn.State And adStateOpen) Then conn.Close
  Set conn = Nothing
  Set rs = Nothing
End Sub

Sub qt()
Set rs = conn.Execute("SELECT COUNT(*) as count FROM [ArchiveFund5].[dbo].[tblUNIT] WHERE NOTE LIKE '%параграф%' and Deleted <> 1;")
  ' Проверить, что есть данные
  If Not rs.EOF Then
    rs.MoveFirst
    If rs![Count].value <> "" Then
      MsgBox rs![Count].value
    End If
    rs.MoveNext
  End If
  ' Закрыть рекордсет
  rs.Close
End Sub