'Option Compare Database

 

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

' ##### Загрузка рекордсета

'   Если  таблица существует - вернет True (Истина = -1)

'   В остальных случаях: False

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

Sub InsertPJI_Tbl()

t = Timer

'Call Wind_Off

 

    Dim oDb As DAO.Database

    Dim rstData As DAO.Recordset

    Dim oTbl As TableDef

    Dim arrTemp()

   

   

    Call Проверка_библиотек_на_MISSING

    Call Подключение_библиотеки

   

    'arrTemp

    strPath = "strPath.mdb"

'    strPath = "strPath.mdb"

    TblDbName = "strTblName"

   

'    Set oDb = OpenDatabase("strPath.mdb") 'CurrentDb '

    Set oDb = FnCreateDataBaseDAO(strPath)

    'Проверка на наличие таблицы в текущей базе данных

    intFields = FnIsTablePresent(oDb, TblDbName)

   

    If intFields > 0 Then

    '    StrSQL = "SELECT " & TblDbName & ".* FROM " & TblDbName & " ORDER BY " & TblDbName & ".DatePJI DESC;"

        Set rstData = oDb.OpenRecordset("select * from " & TblDbName)

       

        If rstData.RecordCount = 0 Then

            rstData.Close

            MsgBox "Таблица " & NameTbl & " пустая!" _

            , 64, "Содержимое таблицы"

        End If

        ' определяем количество записей в рекордсете

        rstData.MoveLast ' перемещение в конец рекордсета

        rstData.MoveFirst ' перемещение в начало рекордсета

        eData = rstData.RecordCount ' количество записей в рекордсете

       

        'если таблица очень большая, то жрет память

        ReDim arrTemp(intFields, eData)

       

        ' первый параметр - число столбцов в массиве (полей в запросе)

        ' второй параметр - число строк в массиве (число записей в запросе)

        ' сброс данных из рекордсета в массив

        arrTemp = rstData.GetRows(eData)

        Set rstData = Nothing

        Erase arrTemp

        Set oDb = Nothing

    End If

t = Timer - t

Debug.Print t

 

End Sub

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

 

'#####=====================================================================================================

' Создание(назначение) базы данных

'Sub test_CreateDataBaseDAO()

'    Dim strTblName As String: strTblName = "strTblName"

'    strPathDb = Range("strPathDb").Value

'    Set oDb = FnCreateDataBaseDAO(strPathDb)

'    Таблица = FnIsTablePresent(oDb, strTblName)

'    If Not Таблица Then Создать_таблицу = FnCreateTblInDB(oDb, strTblName)

'End Sub

'

'Sub KillDataBase()

'    On Error Resume Next

'    Kill "strPath.accdb"

'End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnCreateDataBaseDAO(ByVal strPathDb As String) As DAO.Database

'Dim strPathDb As String

Dim oDb As DAO.Database ' бд, в которой будет создаваться таблица

 

'    strPathDb = Range("strPathDb").Value 'newDB = "strPath.accdb"

 

    If Len(Dir(strPathDb, 16)) = 0 Then 'если база отсутствует

        MsgBox "База данных не обнаружена!" & vbCrLf & "Будет создана новая. " & _

                vbCrLf & "Посмотрите предыдущие версии и восстановите." & _

                vbCrLf & "После восстановления, внесите данные повторно", 48, "Внимание"

        Stop

        Set oDb = DBEngine.Workspaces(0).CreateDatabase(strPathDb, dbLangCyrillic)

'        Set oDb = Nothing

    Else

   

    End If

   

    Set oDb = OpenDatabase(strPathDb)

   

    Set FnCreateDataBaseDAO = oDb

End Function

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

 

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

' ##### Проверка на наличие таблицы в текущей базе данных

'es - 13.06.2013

'Проверка на наличие таблицы в текущей базе данных

'   Если  таблица существует - вернет True (Истина = -1)

'   В остальных случаях: False

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

Public Function FnIsTablePresent(ByVal oDb As DAO.Database, _

                                ByVal strTableName As String) As Long 'As Boolean

Dim i As Integer

On Error Resume Next

'On Error GoTo IsTablePresent_Err

 

' Пытаемся посчитать кол-во полей в заданной таблице

    i = oDb.TableDefs(strTableName).Fields.Count

   

' Если поля есть - значит и таблица существует (что вполне логично)

    If i > 0 Then FnIsTablePresent = i

 

'IsTablePresent_Bye:

'    Exit Function

'

'IsTablePresent_Err:

'    'Болок [Select Case] ниже в принцие не нужен - так ... на всякий случай

'    Select Case Err.Number

'        Case 3265  ' Ошибка обращения к обьекту (т.е. НЕТ таблицы)

'        Case Else

'            'MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _

'            "in procedure IsTablePresent", vbCritical, "Error!"

'    End Select

'    Resume IsTablePresent_Bye

End Function

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

 

'Sub Auto_open()

'    Проверка_библиотек_на_MISSING

'    Подключение_библиотеки

'

'End Sub

Sub Подключение_библиотеки() ' В данном случае Word

On Error Resume Next

'dd = Application.Path & Application.PathSeparator & "MSWORD.OLB"

'ThisWorkbook.VBProject.References.AddFromFile Application.Path & Application.PathSeparator & "MSWORD.OLB"

 

    With ThisWorkbook.VBProject.References

'        .AddFromGuid "{00000300-0000-0010-8000-00AA006D2EA4}", 1, 0  'Microsoft ActiveX Data Objects Recordset 6.0 Library

'        .AddFromGuid "{2A75196C-D9EB-4129-B803-931327F72D5C}", 1, 0  '    Microsoft ActiveX Data Objects 2.8 Library

'        .AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 1, 0  '    Microsoft ADO Ext. 2.8 for DDL and Security

'        .AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 1, 0 '    Microsoft ADO Ext. 6.0 for DDL and Security

        .AddFromGuid "{00025E01-0000-0000-C000-000000000046}", 1, 0 '    Microsoft DAO 3.6 Object Library

        .AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0 '    Microsoft Scripting Runtime

'        .AddFromGuid "{00062FFF-0000-0000-C000-000000000046}", 1, 0 '    Microsoft Outlook 15.0 Object Library

        .AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0 '    Microsoft Scripting Runtime '(для словарей)

    End With

End Sub

 

Sub Проверка_библиотек_на_MISSING()

    Dim iReference As Object, iReferences As Object    'или Variant

    Set iReferences = ThisWorkbook.VBProject.References

    For Each iReference In iReferences

        If (iReference.IsBroken) Then _

           iReferences.Remove Reference:=iReference

'    Debug.Print iReference.Name

'    Debug.Print iReference.FullPath

    Next

End Sub

 

 

 

Sub ref_check()

 

Dim i As Integer

 

With ThisWorkbook.VBProject.References

  For i = 1 To .Count

    Debug.Print .Item(i).GUID, .Item(i).Major, .Item(i).Minor, .Item(i).Description

    a = .Item(i).GUID

    b = .Item(i).Description

    c = .Item(i).Major

    d = .Item(i).Minor

 

'    If .Item(i).GUID = "{420B2830-E718-11CF-893D-00A0C9054228}" Then Exit Sub

 

  Next i

  'Microsoft scripting

'  .AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0

End With

 

End Sub

'.AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}" '    Microsoft ADO Ext. 6.0 for DDL and Security

'.AddFromGuid "{00025E01-0000-0000-C000-000000000046}" '    Microsoft DAO 3.6 Object Library

'.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}" '    Microsoft Scripting Runtime

'.AddFromGuid "{00062FFF-0000-0000-C000-000000000046}" '    Microsoft Outlook 15.0 Object Library

'.AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}" '    Microsoft ADO Ext. 2.8 for DDL and Security

'{2A75196C-D9EB-4129-B803-931327F72D5C}    Microsoft ActiveX Data Objects 2.8 Library

'{00000300-0000-0010-8000-00AA006D2EA4}    Microsoft ActiveX Data Objects Recordset 6.0 Library