m_CreateDataBase

'Option Compare Database

'http://msa.polarcom.ru/st/s0000353.htm

'Программное создание базы данных (ADO) _

С помощью ADO можно легко изменять структуру данных. Для создания и изменения таблиц, _

запросов и других объектов данных, например индексов, следует использовать специальную библиотеку ADO, _

называемую ADOx. Перед использованием ADOx необходимо установить ссылку на библиотеку _

Microsoft ADO Ext. 2.1 For DDL and Security, выполнив команды меню Tools | References (Сервис | Ссылки) в VBE. _

Если ссылка установлена, ADOx готов к использованию. _

При использовании ADOx все операции так или иначе связаны с объектом Catalog. _

Этот объект представляет базу данных. Работая в Access, необходимо всего лишь _

присвоить свойству ActiveConnection объекта Catalog допустимое значение, соответствующее _

объекту ADO Command, с которого начинается выполнение. _

'Создание базы данных _

Для создания с помощью ADOx новой пустой базы данных необходимо использовать метод _

Create объекта Catalog, передав ему значение, содержащее путь и имя создаваемой базы данных.

Sub CreateDataBaseADO(ByVal strDate As String)

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

Dim strTblName As String: strTblName = "Старение_авто"

Dim strDateSQL As String

'Stop

' newDB = ThisWorkbook.Path & "\Старение_авто.mdb"

newDB = ThisWorkbook.Path & "\Старение_авто.accdb"

'newDB = Left(newDB, Len(newDB) - 4) & "_New.mdb"

'On Error GoTo x:

'Kill newDB

'x:

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

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

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

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

Создать_базу = FnCreateDataBaseADO(newDB)

Set oDb = OpenDatabase(newDB)

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

' Set oDb = Nothing

Else

Set oDb = OpenDatabase(newDB)

End If

'''' выбор интервала дат

'' ' Удалить_даты

'' Set oDb = OpenDatabase(newDB)

'' таблица = IsTablePresent(oDb, strTblName)

' Dim dDate As Date: dDate = Format(Now, "DD.MM.YYYY")

' Dim strDate As String:

' Удалить_даты = FnAllRecordsInRecordset(oDb, strTblName, 0, dDate) 'удаление записей

strDateSQL = FnDatePi(strDate)

'DELETE Старение_авто.*, Старение_авто.Дата From Старение_авто WHERE (((Старение_авто.Дата)=#11/23/2017#));

' strSQL = "DELETE " & strTblName & ".*, " & strTblName & ".Дата From Старение_авто WHERE (((Старение_авто.Дата)=#" & strDate & "#));"

strSQL = "DELETE " & strTblName & ".*, " & strTblName & ".Дата From " & strTblName & " WHERE (((" & strTblName & ".Дата) Between #" & strDateSQL & "# And #" & strDateSQL & "#));"

' Debug.Print strSQL

oDb.Execute strSQL

'добавляем записи

With ThisWorkbook

'СКИНУТЬ ФИЛЬТР

iNbTemp = FnFindiRowINCln("Config", "Стартовая_строка", 1)

iNbRowStart = ThisWorkbook.Sheets("Config").Cells(iNbTemp, 2).value

Фильтр = FnFiltersSheet(ThisWorkbook.Sheets("Анкур"), iNbRowStart, 1)

With .Sheets("Анкур")

iNbRowEnd = .Columns(1).Rows(65536).End(xlUp).Row

iNbClnEnd = .Cells(iNbRowStart, 256).End(xlToLeft).Column

vData = Range(.Cells(iNbRowStart + 1, 1), .Cells(iNbRowEnd, iNbClnEnd)).value

End With

End With

InsertToTable newDB, vData, strDate

End Sub

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

'### Преобразует дату в басурманский формат

Function FnDatePi(ByVal strDate As String) As String

' m = Split(strDate, "/", -1, vbBinaryCompare)

m = Split(strDate, ".", -1, vbBinaryCompare)

' If Len(m(0)) = 1 Then m(0) = "0" & m(0)

' If Len(m(1)) = 1 Then m(1) = "0" & m(1)

If Left(m(0), 1) = 0 Then m(0) = Right(m(0), Len(m(0) - 1))

If Left(m(1), 1) = 0 Then m(1) = Right(m(1), Len(m(1) - 1))

FnDatePi = m(1) & "/" & m(0) & "/" & m(2)

End Function

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

'Перебор всех записей (DAO) для удаления

'strTblName - имя таблицы

'iNbFld - номер столбца для проверки

'vValue - запись для удаления

Function FnAllRecordsInRecordset(ByVal oDb As DAO.Database, _

ByVal strTblName As String, _

ByVal iNbFld As Integer, _

ByVal vValue As Variant) As Variant

'Перебор всех записей в наборе

Dim rst As DAO.Recordset, i As Long

Dim dDateCheck As Date

On Error GoTo AllRecordsInRecordsetErr

'Set rst = CurrentDb.OpenRecordset("tblExample", dbOpenDynaset) 'Открытие на редакцию

Set rst = oDb.OpenRecordset(strTblName, dbOpenSnapshot) 'Только просмотр

i = 1

With rst

Do Until .EOF = True 'Цикл до конца таблицы

' Debug.Print Format(!exRecordID, "00000") & " - " & !exName

dDateCheck = Format(rst.Fields(0).value, "DD.MM.YYYY")

If vValue = dDateCheck Then Debug.Print i & ": " & rst.Fields(iNbFld).value & " - " & rst.Fields(1).value

'...

'...операции с записью

.MoveNext

i = i + 1

Loop

End With

AllRecordsInRecordsetEnd:

On Error Resume Next

rst.Close

Set rst = Nothing

Exit Function

AllRecordsInRecordsetErr:

MsgBox "Процедура [...] привела к ошибке:" & vbCrLf & _

Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical

Resume AllRecordsInRecordsetEnd

End Function

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

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

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

ByVal strTableName As String) As Boolean

'es - 13.06.2013

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

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

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

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

Dim i As Integer

On Error GoTo IsTablePresent_Err

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

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

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

If i > 0 Then IsTablePresent = True

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

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

'добавляем записи

Function InsertToTable(ByVal strDb As String, _

ByVal vData As Variant, _

ByVal dDate As Date)

' Const lastRow = 400000, lastCol = 15

Dim ilastRow As Long: ilastRow = UBound(vData)

Dim ilastCol As Long: ilastCol = UBound(vData, 2)

' Dim pCon As New ADODB.Connection, pRSet As New ADODB.Recordset

Dim pCon As New ADODB.Connection, pRSet As New ADODB.Recordset

' Dim vData As Variant

Dim k As Long, t As Single, i As Long

t = Timer: k = 0

pCon.CursorLocation = adUseClient

' pCon.Open "DBQ=c:\Projects\Database2 min.accdb;Driver={Microsoft Access Driver (*.mdb, *.accdb)};DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;ReadOnly=0;ExtendedAnsiSQL=1;"

pCon.Open "DBQ=" & strDb & ";Driver={Microsoft Access Driver (*.mdb, *.accdb)};DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;ReadOnly=0;ExtendedAnsiSQL=1;"

pRSet.CursorLocation = adUseClient: pRSet.CursorType = adOpenStatic

' pRSet.Open "Select * From " & "Старение_авто" & " Where FLong1 Is Null", pCon, adOpenStatic, adLockOptimistic

pRSet.Open "Select * From " & "Старение_авто", pCon, adOpenStatic, adLockOptimistic

'' vData = Range("A2").Resize(lastRow, lastCol).value

' vData = Range("A11:O211").value

pCon.BeginTrans

For i = 1 To ilastRow

k = k + 1

If (k Mod 10000) = 0 Then Debug.Print k: DoEvents

pRSet.AddNew

pRSet(0).value = dDate 'Format(Now, "DD.MM.YYYY")

pRSet(1).value = vData(i, 1)

pRSet(2).value = vData(i, 2)

pRSet(3).value = vData(i, 3)

pRSet(4).value = vData(i, 4)

pRSet(5).value = vData(i, 5)

pRSet(6).value = vData(i, 6)

'

pRSet(7).value = vData(i, 7)

pRSet(8).value = vData(i, 8)

pRSet(9).value = vData(i, 9)

pRSet(10).value = vData(i, 10)

pRSet(11).value = vData(i, 11)

pRSet(12).value = vData(i, 12)

pRSet(13).value = vData(i, 13)

pRSet(14).value = vData(i, 14)

pRSet(15).value = vData(i, 15)

Next

pRSet.UpdateBatch: pCon.CommitTrans

pRSet.Close: pCon.Close

Debug.Print Timer - t 'MsgBox; Timer - t

End Function

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

'Создаем новую базу

http://msa.polarcom.ru/st/s0000353.htm

Function FnCreateDataBaseADO(ByVal newDB As String) As Boolean

''Данная процедура создает новую базу данных с использованием возможностей ADOx.

''По материалам книги "Microsoft Access 2000 Development Unleashed" издательства SAMS

''Авторы: Forte, Howe, Ralston

''Объект Catalog в ADOx

Dim cat As ADOX.Catalog

Err.Clear

' On Error GoTo Proc_Err

Set cat = New ADOX.Catalog

cat.Create "provider=Microsoft.JET.OLEDB.4.0;data source=" & newDB

' MsgBox "Database Created!", vblnformation

If Len(Err.Description) = 0 Then FnCreateDataBaseADO = True

'Proc_Exit:

'Exit Function

'

'Proc_Err:

' MsgBox Err.Description

' Resume Proc_Exit

End Function

''Перед использованием ADOx необходимо установить ссылку на библиотеку _

Microsoft ADO Ext. 2.1 For DDL and Security, _

выполнив команды меню Tools | References (Сервис | Ссылки) в VBE.

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

'Создаем таблицу в базе

Function FnCreateTblInDB(ByVal oDb As DAO.Database, _

ByVal strTblName As String) As Boolean

Dim Tbl As TableDef ' создаваемая таблица

Dim oFld As Field

On Error Resume Next

Err.Clear

Set oTbl = oDb.CreateTableDef(strTblName)

For i = 1 To 16

Select Case i

Case 1: Set oFld = oTbl.CreateField("Дата", 8)

Case 2: Set oFld = oTbl.CreateField("ПЖИ", 10, 12)

Case 3: Set oFld = oTbl.CreateField("Зона", 10, 4): oFld.AllowZeroLength = True 'пустые строки

Case 4: Set oFld = oTbl.CreateField("Дата_ТСМ", 8)

Case 5: Set oFld = oTbl.CreateField("Цвет", 10, 5): oFld.AllowZeroLength = True

Case 6: Set oFld = oTbl.CreateField("Тип", 10, 10): oFld.AllowZeroLength = True

Case 7: Set oFld = oTbl.CreateField("Dept", 10, 10): oFld.AllowZeroLength = True

Case 8: Set oFld = oTbl.CreateField("Критерий", 3)

Case 9: Set oFld = oTbl.CreateField("Описание", 10, 250): oFld.AllowZeroLength = True

Case 10: Set oFld = oTbl.CreateField("Место", 10, 10): oFld.AllowZeroLength = True

Case 11: Set oFld = oTbl.CreateField("ФИО", 10, 250): oFld.AllowZeroLength = True

Case 12: Set oFld = oTbl.CreateField("Дата_MADU", 8)

Case 13: Set oFld = oTbl.CreateField("Текущая_зона", 10, 50): oFld.AllowZeroLength = True

Case 14: Set oFld = oTbl.CreateField("Группа", 10, 50): oFld.AllowZeroLength = True

Case 15: Set oFld = oTbl.CreateField("Проверка_344", 3)

Case 16: Set oFld = oTbl.CreateField("CLES", 3)

End Select

oTbl.Fields.Append oFld

Next i

' добавляю таблицу

oDb.TableDefs.Append oTbl

' обновляю данные о таблицах

oDb.TableDefs.Refresh

Set oDb = Nothing

If Len(Err.Description) = 0 Then FnCreateTblInDB = True

End Function