Ошибка при формировании отчета после перехода с 6.2 на 6.3

Option Compare Database

Public TCS As CSDN.TCS
Public TCSApp As CSDN.Tcs_Application

' Процедура для получения наименования классификатора номенклатуры
Public Sub PrepareData()

    LoadLibrary

' 1. Создание таблицы нужной структуры
    CreateKlassifTable

' 2. Подсоединиться к TechnologiCS API
    ConnectToTcs
    If Not TCSApp Is Nothing Then
    
' 3. Получаем и записываем классификатор
    WriteData

    End If ' If Not TCSApp Is Nothing
 
' 4. Обновляем БД
    CurrentDb.TableDefs.Refresh
    
' 5. Освободить объекты TechnologiCS API
    FreeTcsConnection
End Sub

' --------------------------------------------------------------------------------------

Sub LoadLibrary()
    Dim ref As Reference
    HasADO = False
  
    For Each ref In References
        If ref.Name = "ADODB" Then HasADO = True
    Next
    If Not HasADO Then
        On Error Resume Next
        References.AddFromGuid "{2A75196C-D9EB-4129-B803-931327F72D5C}", 2, 8
    End If
End Sub


' Процедура создания таблицы и занесение в нее идентификаторов СТД и М из RptSheet
Private Sub CreateKlassifTable()
    Const CreateQuery As String = "CREATE TABLE KlassifData (Klassif_ID int, Klassif string)"
 Const InsertQuery As String = "INSERT INTO KlassifData (Klassif_ID) SELECT P4 FROM RptSheet Where P24='СТД' or 'М'"
    
    Dim ADOCommand As ADODB.Command
    
    Debug.Print "Создаётся таблица KlassifData (с ID стандартных изделий) ..."
    
    Set ADOCommand = New ADODB.Command
    If Not ADOCommand Is Nothing Then
 ADOCommand.ActiveConnection = CurrentProject.AccessConnection  !Ошибка тут возникает!
        ADOCommand.CommandText = CreateQuery
        On Error Resume Next
        ADOCommand.Execute
        On Error GoTo 0
 ADOCommand.CommandText = InsertQuery
        On Error Resume Next
        ADOCommand.Execute
        On Error GoTo 0
    End If ' If Not ADOCommand Is Nothing
    Set ADOCommand = Nothing
    Debug.Print ""
End Sub

' *****************************************************************************

' Процедура соединения c текущим сеансом TechnologiCS API
Private Sub ConnectToTcs()

    Debug.Print "Подключение к текущему сеансу TechnologiCS API ..."
    Debug.Print ""
    If TCS Is Nothing Then
        Set TCS = New CSDN.TCS
    End If ' If TCS Is Nothing
    
    If Not TCS Is Nothing Then
        Set TCSApp = TCS.LoginCurrent
    End If ' If Not TCS Is Nothing Then
    
End Sub

' *****************************************************************************

' Процедура считывания ID, получение и запись классификатора
Private Sub WriteData()
    Const Query As String = "SELECT Klassif_ID FROM KlassifData"
    Dim ADORec As ADODB.Recordset ' Набор данных с идентификаторами
    Dim ID As Long ' Обрабатываемый идентификатор
    Dim ClassifName As String ' Наименование узла классификатора
    
    ' Создаём набор данных
    Set ADORec = New ADODB.Recordset
    
    ' Открываем набор данных
    ADORec.Open Query, CurrentProject.AccessConnection
 
    ' Позиционируемся на первой записи в наборе
    ADORec.MoveFirst
    ' В цикле пока не будет достигнута последняя запись
    Do While Not ADORec.EOF
        ' Получаем идентификатор
        ID = ADORec!Klassif_ID.Value
        ' Получаем наименование классификатора
        ClassifName = GetClassifName(ID)
        
        ' Записывем название классификатора
        Call WriteClassifName(ID, ClassifName)
        
        ' переходим на следующую запись
        ADORec.MoveNext
    Loop
  
    ' Закрываем и освобождаем набор данных
    ADORec.Close
    Set ADORec = Nothing
End Sub

' *****************************************************************************
    
' Процедура загрузки данных о классификаторах
Function GetClassifName(ID As Long) As String
    Dim SingleNmk As CSDN.ISingleNomenclature
    
    ' Получаем экземпляр (единственную запись) номенклатуры по идентификатору
    Set SingleNmk = TCSApp.SingleNmkFromId(ID)
    
    ' Проверяем, не пустой ли обект
    If Not SingleNmk Is Nothing Then
        ' Запоминаем именованный экземпляр
        SingleNmk.UserModuleName = SingleNmk.UniqueUserModuleName
        
        ' Получаем название узла классификатора номенклатуры
        ' Это же и значение, возвращаемое функцией
        GetClassifName = SingleNmk.Properties("CLASSIF_NAME").DisplayText
        
        ' Удаляем именованный экземпляр номенклатуры - если этого не делать,
        ' при большом количестве обрабатываемой номенклатуры память, используемая
        ' TCS API будет непомерно расти
        TCSApp.DeleteModuleByUserModuleName (SingleNmk.UserModuleName)
    End If
    Set SingleNmk = Nothing
    
End Function

' *****************************************************************************

' Процедура записи классификатора в БД
Private Sub WriteClassifName(ID, ClassifName)
Const UpdateQuery = "UPDATE KlassifData SET Klassif= '%ClassifName%' WHERE Klassif_ID = %ID%"
    
    Dim ADOCommand As ADODB.Command
    
    Dim Query As String
    
    Set ADOCommand = New ADODB.Command
    If Not ADOCommand Is Nothing Then
 
        Query = Replace(UpdateQuery, "%ClassifName%", ClassifName)
        Query = Replace(Query, "%ID%", CStr(ID))
        ADOCommand.ActiveConnection = CurrentProject.AccessConnection
        ADOCommand.CommandText = Query
        On Error Resume Next
        ADOCommand.Execute
        On Error GoTo 0
    End If ' If Not ADOCommand Is Nothing
    Set ADOCommand = Nothing
 End Sub
' *****************************************************************************
    
Private Function IsTableExist(ATableName As String) As Boolean
    Dim I As Integer    ' Счётчик цикла
    Dim R As Boolean    ' Временное значение результата
    
    R = False
    
    
    CurrentDb.TableDefs.Refresh
    For I = 0 To CurrentDb.TableDefs.Count
        If CurrentDb.TableDefs(I).Name = ATableName Then
            R = True
            Exit For
        End If '
    
    Next ' I
    
    IsTableExist = R

End Function ' IsTableExist(ATableName As String)

' *****************************************************************************

' Процедура освобождения объектов TechnologiCS API
Private Sub FreeTcsConnection()
    Set TCSApp = Nothing
    Set TCS = Nothing
End Sub