Базы даных Access. Вставка значения с бази в Acad2002

Attribute VB_Name = "modUpdateTables"
Option Explicit
'' Требуются следующие библиотеки:
'' Microsoft Access 11.0 Object Library
'' microsofta ActiveX Data Objects 2.8 Library
'' Microsoft ADO Ext. 2.8 for Dll and Security
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Const dbPath As String = "D:\AUTOLISP\LISPS\PRIMITIVES\###JOB\##DISC\#VBA\ACAD\Access\db1.mdb"
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim tblName As String
Dim strSQL As String
Dim cadaStr As String
Dim Fio As String
Dim ploshStr As String
Dim celStr As String
Dim rstData() As String
Dim colCnt As Integer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function TableExists(ByVal MyTableName As String, ByVal oConn As Connection) As Boolean
Dim oRS As Recordset
  On Error Resume Next
    Set oRS = oConn.Execute(MyTableName, , adCmdTable)
    TableExists = Not (oRS Is Nothing)
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. (c)2006 * all rights removed '
' SourceArr - two dimensional array '
' iPos - "column" number (starting from 1) '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function CoolSort(SourceArr As Variant, iPos As Integer) As Variant
     Dim Check As Boolean
     ReDim tmpArr(UBound(SourceArr, 2)) As Variant
     Dim iCount As Integer
     Dim jCount As Integer
     Dim nCount As Integer
     iPos = iPos - 1
     Check = False
     Do Until Check
          Check = True
          For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
               If SourceArr(iCount, iPos) < SourceArr(iCount + 1, iPos) Then
                    For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                         tmpArr(jCount) = SourceArr(iCount, jCount)
                         SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                         SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                         Check = False
                    Next
               End If
          Next
     Loop
     CoolSort = SourceArr
End Function
Sub UpdateCadastr()
     Dim oSSet As AcadSelectionSet
     Dim oEnt As AcadEntity
     Dim oText As AcadText
     Dim eCnt As Integer
     Dim iCnt As Integer
     Dim iNdx As Integer
     Dim jNdx As Integer
     Dim insPnt() As Double
     Dim fcode(0) As Integer
     Dim fData(0) As Variant
     Dim dxfcode, dxfdata
     Dim setName As String
     Dim i As Integer, icol As Integer
     Dim p1, p2, varPt
     ThisDrawing.Regen True
     MsgBox "Выбрать кадастровый номер", vbInformation
     ThisDrawing.Utility.GetEntity oEnt, varPt, vbCrLf & "Выбрать кадастровый номер"
     If oEnt Is Nothing Then Exit Sub
     If Not TypeOf oEnt Is AcadText Then Exit Sub
     Set oText = oEnt
     cadaStr = oText.TextString
     ''//
     fcode(0) = 0
     fData(0) = "TEXT"
     dxfcode = fcode
     dxfdata = fData
     setName = "$TEXT$"
     For i = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(i).Name = setName Then
               ThisDrawing.SelectionSets.Item(i).Delete
               Exit For
          End If
     Next i
     Set oSSet = ThisDrawing.SelectionSets.Add(setName)
     '// selection #1
     MsgBox "Выбрать в штампе:" & vbCr & _
     vbTab & "- Фамилию-имя-отчество" & vbCr & _
            vbTab & "- Адрес" & vbCr & _
            vbTab & "- Селищну раду" & vbCr & _
            vbTab & "( по одной строчке )", vbInformation
     oSSet.SelectOnScreen dxfcode, dxfdata
     If oSSet.Count <> 3 Then Exit Sub
     ReDim infoArr(0 To oSSet.Count - 1) As String
     For eCnt = 0 To oSSet.Count - 1
          Set oEnt = oSSet.Item(eCnt)
          Set oText = oEnt
          infoArr(eCnt) = oText.TextString
     Next
     '//
      Fio = infoArr(0)
     '//
     '//
     oSSet.Clear
     '// selection #2
     MsgBox "Выбрать в экспликации:" & vbCr & _
     vbTab & "- Целевое" & vbCr & _
            vbTab & "- Площадь участка" & vbCr & _
            vbTab & "( по одной строчке )", vbInformation
     oSSet.SelectOnScreen dxfcode, dxfdata
     If oSSet.Count <> 2 Then Exit Sub
     Set oEnt = oSSet.Item(0)
     Set oText = oEnt
     celStr = oText.TextString
     Set oEnt = oSSet.Item(1)
     Set oText = oEnt
     ploshStr = oText.TextString
     oSSet.Clear
     MsgBox vbCr & "Выбрать текст с видами рамкой -" & vbCr & _
     "указать две точки", vbInformation
'//
With ThisDrawing.Utility
     p1 = .GetPoint(, vbCr & "Pick first corner point")
     p2 = .GetCorner(p1, vbCr & "Digitize opposite corner point")
End With
oSSet.Select acSelectionSetWindow, p1, p2, dxfcode, dxfdata
iCnt = oSSet.Count
If iCnt = 0 Then Exit Sub
ReDim SelPnt(0 To iCnt - 1, 0 To 3) As Variant
eCnt = 0
For Each oEnt In oSSet
     Set oText = oEnt
     insPnt = oText.InsertionPoint
     SelPnt(eCnt, 0) = insPnt(0)
     SelPnt(eCnt, 1) = insPnt(1)
     SelPnt(eCnt, 2) = insPnt(2)
     SelPnt(eCnt, 3) = oText.TextString
     eCnt = eCnt + 1
Next oEnt
Dim collPts As Collection
Set collPts = New Collection
colCnt = 2
ReDim sortpnt(0 To (iCnt - 1), 0 To 2) As Variant
sortpnt = CoolSort(SelPnt, 2)     '<--sort by Y
ReDim tmpsort(0 To colCnt - 1, 0 To UBound(sortpnt, 2)) As Variant
Dim itmArr As Variant
'**************************************************************'
eCnt = 0
For iCnt = 0 To UBound(sortpnt, 1) Step colCnt
     'Do While eCnt <= UBound(sortpnt, 1) + 1
     iNdx = 0
     Do While iNdx < colCnt
          For jNdx = 0 To UBound(sortpnt, 2)
               tmpsort(iNdx, jNdx) = sortpnt(eCnt, jNdx)
          Next
          eCnt = eCnt + 1
          If eCnt >= UBound(sortpnt, 1) + 1 Then
               Exit Do
          End If
          iNdx = iNdx + 1
     Loop
     itmArr = CoolSort(tmpsort, 1)
     collPts.Add itmArr
Next
Dim collTxt As Collection
Set collTxt = New Collection
icol = UBound(sortpnt, 2)
For iNdx = 1 To collPts.Count
     For jNdx = UBound(tmpsort, 1) To 0 Step -1
          collTxt.Add collPts.Item(iNdx)(jNdx, icol)
     Next
Next
ReDim tabData(0 To (collTxt.Count \ 2) - 1, 1) As String
iCnt = 0
For iNdx = 1 To collTxt.Count Step 2
     tabData(iCnt, 0) = collTxt.Item(iNdx)
     tabData(iCnt, 1) = collTxt.Item(iNdx + 1)
     iCnt = iCnt + 1
Next
ReDim rstData(0 To UBound(tabData, 1), 0 To UBound(tabData, 2)) As String
For iNdx = 0 To UBound(tabData, 1)
     rstData(iNdx, 0) = cadaStr
     rstData(iNdx, 1) = tabData(iNdx, 1)
Next
oSSet.Clear
'///////////////////// * working with Access * //////////////////////'
On Error Resume Next
' Variables for AutoCAD Objects
Dim PolylineSelection As AutoCAD.AcadSelectionSet
Dim PolylineObject As AutoCAD.AcadObject
Dim groupCode(0) As Integer
Dim dataValue(0) As Variant
' Variables for ADO Objects
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
'//***************************таблица №1************************//''
' Connect to the database
tblName = "Информация"
strSQL = "INSERT INTO [" & tblName & "]"
With cnn
     .CursorLocation = adUseServer
     .Provider = "Microsoft.Jet.OLEDB.4.0"
     .Properties("Data Source").Value = dbPath    ' <-- change database name here
     .Open
End With
If Not TableExists(tblName, cnn) Then
MsgBox "Таблица " & Chr(34) & tblName & Chr(34) & " не существует" & vbCr & _
"проверь правильность написания имени таблицы", vbCritical
End If
With rst
     .LockType = adLockPessimistic
     .ActiveConnection = cnn
     .CursorType = adOpenKeyset
     .CursorLocation = adUseServer
     .Source = strSQL
End With
If Err <> 0 Then
     MsgBox "Could not open the table. Make sure " & _
            "it has been configured in the DbConnect Manager."
     Exit Sub
End If
' Open the recordset
rst.Open tblName, cnn, adOpenDynamic, adLockOptimistic
If Err <> 0 Then
     MsgBox "Could not open " & Chr(34) & tblName & Chr(34) & " recordset"
     Exit Sub
End If
' Make sure the Recordset supports AddNew
If Not rst.Supports(adAddNew) Then
     MsgBox "Cannot add records to the recordset."
     Exit Sub
End If
' Add a new blank record
rst.AddNew
' Set the field values
rst("Ф_И_О") = infoArr(0)
rst("Адрес") = infoArr(1)
rst("Селищна_рада") = infoArr(2)
' Commit the changes
rst.Update
' Close the recordset
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox "Таблица " & Chr(34) & tblName & Chr(34) & " заполнена", vbInformation
'//***************************таблица №2************************//''
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
tblName = "Участок"
strSQL = "INSERT INTO [" & tblName & "]"
     With cnn
          .CursorLocation = adUseServer
          .Provider = "Microsoft.Jet.OLEDB.4.0"
          .Properties("Data Source").Value = dbPath
          .Open
     End With
If Not TableExists(tblName, cnn) Then
MsgBox "Таблица " & Chr(34) & tblName & Chr(34) & " не существует" & vbCr & _
"проверь правильность написания имени таблицы", vbCritical
End If
With rst
     .LockType = adLockPessimistic
     .ActiveConnection = cnn
     .CursorType = adOpenKeyset
     .CursorLocation = adUseServer
     .Source = strSQL
End With
If Err <> 0 Then
     MsgBox "Could not open the table. Make sure " & _
            "it has been configured in the DbConnect Manager."
     Exit Sub
End If
' Open the recordset
rst.Open tblName, cnn, adOpenDynamic, adLockOptimistic
If Err <> 0 Then
     MsgBox "Could not open " & Chr(34) & tblName & Chr(34) & " recordset"
     Exit Sub
End If
' Make sure the Recordset supports AddNew
If Not rst.Supports(adAddNew) Then
     MsgBox "Cannot add records to the recordset."
     Exit Sub
End If
' add the data to the database
     ' Add a new blank record
     rst.AddNew
     ' Set the field values
     rst("Ф_И_О") = Fio
     rst("Кадастровый_№") = cadaStr
     rst("Целевое") = celStr
     rst("Площа_га") = Replace(ploshStr, ".", ",")
     ' Commit the changes
     rst.Update
' Close the recordset
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox "Таблица " & Chr(34) & tblName & Chr(34) & " заполнена", vbInformation
'//***************************таблица №3************************//''
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
tblName = "Смежники"
strSQL = "INSERT INTO [" & tblName & "]"
     With cnn
          .CursorLocation = adUseClient
          .Provider = "Microsoft.Jet.OLEDB.4.0"
          .Properties("Data Source").Value = dbPath
          .Open
     End With
If Not TableExists(tblName, cnn) Then
MsgBox "Таблица " & Chr(34) & tblName & Chr(34) & " не существует" & vbCr & _
"проверь правильность написания имени таблицы", vbCritical
End If
With rst
     .LockType = adLockPessimistic
     .ActiveConnection = cnn
     .CursorType = adOpenKeyset
     .CursorLocation = adUseServer
     .Source = strSQL
End With
If Err <> 0 Then
     MsgBox "Could not open the table. Make sure " & _
            "it has been configured in the DbConnect Manager."
     Exit Sub
End If
' Open the recordset
rst.Open tblName, cnn, adOpenDynamic, adLockOptimistic
If Err <> 0 Then
     MsgBox "Could not open " & Chr(34) & tblName & Chr(34) & " recordset"
     Exit Sub
End If
' Make sure the Recordset supports AddNew
If Not rst.Supports(adAddNew) Then
     MsgBox "Cannot add records to the recordset."
     Exit Sub
End If
' add the data to the database
For iNdx = 0 To UBound(rstData, 1)
     ' Add a new blank record
     rst.AddNew
     ' Set the field values
     rst("Кадастровый_№") = rstData(iNdx, 0)
     rst("Смежники") = rstData(iNdx, 1)
     ' Commit the changes
     rst.Update
     rst.MoveNext
Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox "Таблица " & Chr(34) & tblName & Chr(34) & " заполнена", vbInformation
End Sub