MyTetra Share
Делитесь знаниями!
OpenRecordset.xlsm
Время создания: 16.03.2019 23:43
Текстовые метки: DAO.Recordset, DAO, Recordset
Раздел: !Закладки - VBA - Access

'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





Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.53
Яндекс индекс цитирования