strsql = "Select * from clients"
get_conn
get_rs (strsql)
k =  0 
If Not get_rs.EOF Then
    get_rs.MoveFirst
    Do Until get_rs.EOF
        a = get_rs.Fields("id").Value
        b = get_rs.Fields("name").Value
        Combo1.AddItem b, k
        Combo1.ItemData(Combo1.NewIndex) = a
        get_rs.MoveNext
        k = k +  1 
    Loop
End If
conn_rs_comma_close ( 2 )
conn_rs_comma_close ( 1 )

strsql = "Select * from clients"
Set cn = get_conn
Set rs = get_rs(cn, strsql)
k =  0 
If Not rs.EOF Then
    rs.MoveFirst
    Do Until rs.EOF
        a = rs.Fields("id").Value
        b = rs.Fields("name").Value
        Combo1.AddItem b, k
        Combo1.ItemData(Combo1.NewIndex) = a
        rs.MoveNext
        k = k +  1 
    Loop
End If
CloseRs rs
CloseCn cn

Public Function get_conn() As ADODB.Connection
strconn = "Driver={MySQL ODBC 3.51 Driver};Server=localhost;Database=it; User=root;Password=506;Option=3;"
Set Conn = New ADODB.Connection
Conn.Open strconn
End Function
...
Public Function get_rs(strquery As String) As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open strquery, Conn, adCmdText
End Function

Public Function get_comm(get_conn As ADODB.Connection, proc As String) As ADODB.Command
Set comm = New ADODB.Command
comm.ActiveConnection = get_conn
comm.CommandType = adCmdStoredProc
comm.CommandText = proc
Set get_comm = comm
Set comm = Nothing
End Function
......
Public Function get_rs(get_conn, strquery) As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open strquery, get_conn, adOpenDynamic
Set get_rs = rs
Set rs = Nothing
End Function

Option Explicit
Private cn As New ADODB.Connection
Private cmd As New ADODB.Command

Private bIsOpen As Boolean

'Private mProgramSettings As CProgramSettings


'***********************************************************************
'* Открывает коннест к базе
'***********************************************************************
Function OpenConnect(sConnectionString As String) As Boolean
Dim sErrDesc As String
OpenConnect = False
bIsOpen = False
On Error GoTo labErr

'cn.Provider = "LCPI.IBProvider"
cn.Open sConnectionString
'cn.State
cmd.ActiveConnection = cn
OpenConnect = True
bIsOpen = True
'cn.BeginTrans
Exit Function
labErr:
'OpenConnect = False
sErrDesc = Err.Description
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
'Call OutputErrorMessage(sErrDesc, , , "OpenConnect")
End Function

'***********************************************************************
'* Закрывает коннест к базе
'***********************************************************************
Private Sub CloseConnect()
On Error GoTo labErr
'cn.CommitTrans

labErr:
cn.Close
Set cn = Nothing
Set cmd = Nothing

End Sub

'Private Sub CreateProgramSettings()
'  Set mProgramSettings = New CProgramSettings
'
'  ' Set property settings to determine where the settings will
'  ' be saved. In this example, the settings to into the same location
'  ' used by the VB SaveSetting/GetSettings routines. This could be your
'  ' company name, or the name of another known company such as "Microsoft"
'
'  With mProgramSettings
'    .RootKey = psrHKEY_LOCAL_MACHINE
'    .MainBranch = "SOFTWARE"
'    .RegBase = "ECUS"
'    .Program = "DBOptions"
'    .Section = ""
'
'  End With
'
'End Sub

'***********************************************************************
'* Выполняет запрос подготовленный заранее
'***********************************************************************
Public Function ExecQueryBase(sSql As String) As Boolean
Dim sErrDesc As String
Dim erCur As ADODB.Error
On Error GoTo labErr

ExecQueryBase = False
If Not bIsOpen Then
'    If Not OpenConnect Then
        Exit Function
'    End If
End If
'If cn.State = adStateClosed Then Exit Function

cn.BeginTrans
cmd.CommandText = sSql
cmd.Prepared = True
cmd.Execute
cn.CommitTrans
ExecQueryBase = True
Exit Function

labErr:
On Error Resume Next
If cn.State <> adStateClosed Then
    cn.RollbackTrans
End If

sErrDesc = "" 'Err.Description & " <-> "


' Get the ADO errors.
If cn.Errors.count >  0  Then
    For Each erCur In cn.Errors
        sErrDesc = sErrDesc & erCur.Source  ": " & erCur.Description & " | "
    Next erCur
End If

sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "ExecQueryBase", cmd.CommandText)
End Function

'***********************************************************************
'* Выполняет запрос подготовленный заранее
'***********************************************************************
Public Function ExecQueryBaseRS(sSql As String) As ADODB.Recordset
Dim sErrDesc As String
Dim erCur As ADODB.Error

Set ExecQueryBaseRS = Nothing
'If Not bIsOpen Then
'    If Not OpenConnect Then
'        Exit Function
'    End If
'End If

'cn.BeginTrans
On Error GoTo labErr
cmd.CommandText = sSql
cmd.Prepared = True
Set ExecQueryBaseRS = cmd.Execute.NextRecordset
'cn.CommitTrans
Exit Function
labErr:

If cn.State <> adStateClosed Then
    cn.RollbackTrans
End If

sErrDesc = "" 'Err.Description & " <-> "

On Error Resume Next

' Get the ADO errors.
If cn.Errors.count >  0  Then
    For Each erCur In cn.Errors
        sErrDesc = sErrDesc & erCur.Source & ": " & erCur.Description & " | "
    Next erCur
End If
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "GetID", cmd.CommandText)
End Function


'***********************************************************************
'* Получает из базы значения генераторов
'* для вставки данных в базу
'***********************************************************************
'Public Function GetId(val As TypeID) As Long
'Dim sErrDesc As String
'Dim erCur As ADODB.Error
'
''If Not bIsOpen Then
''    If Not OpenConnect Then
''        Exit Function
''    End If
''End If
'
'On Error GoTo labErr
'cn.BeginTrans
'Select Case val
'Case ID_PHONE
'    cmd.CommandText = "execute procedure SP_GEN_INF_PHONE_ID"
'Case ID_SUBSCRIBER
'    cmd.CommandText = "execute procedure SP_GEN_INF_SUBSCRIBER_ID"
'Case ID_DIVISION
'    cmd.CommandText = "execute procedure SP_GEN_INF_DIVISION_ID"
'End Select
' 'automating defining of parameters ----------------------------------------------
''cmd.Parameters.Refresh
'cmd.Parameters.Append cmd.CreateParameter("ID", adInteger, adParamOutput)
'cmd.Execute
'GetId = cmd.Parameters("ID").Value
'cmd.Parameters.Delete (0)
'cn.CommitTrans
'Exit Function
'labErr:
'cmd.Parameters.Delete (0)
'If cn.State <> adStateClosed Then
'    cn.RollbackTrans
'End If
'
'sErrDesc = "" 'Err.Description & " <-> "
'
'On Error Resume Next
'
'' Get the ADO errors.
'If cn.Errors.Count > 0 Then
'    For Each erCur In cn.Errors
'        sErrDesc = sErrDesc & erCur.Source & ": " & erCur.Description & " | "
'    Next erCur
'End If
'sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
'Call OutputErrorMessage(sErrDesc, , , "GetID", cmd.CommandText)
'Err.Raise 70, "GetID"
'End Function

Public Sub ClearDataInBD()
' Очищаем БД от данных
'If Not bIsOpen Then
'    If Not OpenConnect Then
'        If g_iRowError > 2 Then
'            If Not shErr Is Nothing Then
'                 shErr.Visible = xlSheetVisible
'                 shErr.Select
'                 Set shErr = Nothing
'                 g_iRowError = 2
'            End If
'        End If
'        Exit Sub
'    End If
'End If
Call ExecQueryBase("delete from INF_SUBSCRIBER")
Call ExecQueryBase("delete from INF_DIVISION")
Call ExecQueryBase("delete from INF_PHONE")
Call ExecQueryBase("delete from INF_LINK_PDS")
Call ExecQueryBase("delete from CATEG")
End Sub


Private Sub Class_Initialize()
'If Not OpenConnect Then
'    Err.Raise vbObjectError + 1, "clsDataBaseWork : Class_Initialize", _
'        , ThisWorkbook.Path & "\Создание_справочника.chm"
'End If
End Sub

Private Sub Class_Terminate()
Call CloseConnect
End Sub

Option Explicit
Dim g_BD As clsDataBaseWork
Dim v As Variant
Dim mCol As Collection
Dim sh As Worksheet, shOut As Worksheet

Sub LoopInData()
If g_BD Is Nothing Then
    Set g_BD = New clsDataBaseWork
End If
Set mCol = New Collection
'Set sh = Application.Worksheets("Лист3")
Set sh = Application.Worksheets("Лист1")
' Если база не открылась, работать дальше нельзя
If Not g_BD.OpenConnect("Provider=sqloledb;Data Source=igor;Initial Catalog=ttt;Integrated Security=SSPI;") Then
    Set g_BD = Nothing
    Exit Sub
End If
Dim nRow As Long, nCol As Long, i As Long
nRow =  1 
nCol =  1 
For nRow =  2  To  666 
    sh.Cells(nRow,  15 ).Value = InsertRec(nRow)
Next nRow
Set g_BD = Nothing
Set mCol = Nothing
Set sh = Nothing
Set shOut = Nothing
End Sub

Function InsertRec(nRow As Long) As String
Dim s As String, sCode As String, rs As Recordset
s = "INSERT INTO [ttt].[dbo].[objects](code_owher, name, land_tipe, number, code_land, adres) VALUES(" & _
    CStr(sh.Cells(nRow,  1 ).Value) & ", '" & Trim(CStr(sh.Cells(nRow,  3 ).Value)) & "', " & _
    CStr(sh.Cells(nRow,  4 ).Value) & ", " & CStr(sh.Cells(nRow,  5 ).Value) & ", " & _
    CStr(sh.Cells(nRow,  6 ).Value) & ", " & CStr(sh.Cells(nRow,  7 ).Value) & ", " & _
    vbCrLf & "SELECT SCOPE_IDENTITY() AS code"
Set rs = g_BD.ExecQueryBaseRS(s)
'rs.MoveFirst
sCode = CStr(rs.Fields("code").Value)
Set rs = Nothing
InsertRec = sCode
s = "INSERT INTO [ttt].[dbo].[objects_plus_directions](code_directions, code_objects) VALUES(" & _
    CStr(sh.Cells(nRow,  14 ).Value) & ", " & sCode & ")"
 Call g_BD.ExecQueryBase(s)

'Call g_BD.ExecQueryBase(s)
'rs.MoveFirst
Debug.Print s
End Function

Option Explicit
Private strquery As String, proc As String
Private strconn As String
Private conn As ADODB.Connection
Private comm As ADODB.Command
Private prm As ADODB.Parameters
Private rs As ADODB.Recordset
Private i As Integer
Dim err_num As Integer
Private bIsOpen As Boolean
Public sErrDesc As String
Private erCur As ADODB.Error
''''''''''''''''''''''''''''''''''''''''''''''
' Создаем connection
''''''''''''''''''''''''''''''''''''''''''''''
Public Function get_conn() As ADODB.Connection
On Error GoTo My_Err
bIsOpen = False
strconn = "Driver={MySQL ODBC 3.51 Driver};Server=localhost;Database=it; User=root;Password=506;Option=3;"
Set conn = New ADODB.Connection
conn.Open strconn
bIsOpen = True
Set get_conn = conn
Set conn = Nothing
Exit Function
My_Err:
sErrDesc = ""
sErrDesc = Err.Description
err_num = Err.Number
OutputErrorMessage sErrDesc, "connection", err_num
End Function
''''''''''''''''''''''''''''''''''''''''''''''
' Заполняем grid
''''''''''''''''''''''''''''''''''''''''''''''
Public Sub flexname(get_rs As ADODB.Recordset, gridname As FlexGridPlus)
On Error GoTo My_Err
gridname.Cols = get_rs.Fields.Count
gridname.Rows =  1 
For i =  0  To get_rs.RecordCount -  1 
    gridname.TextMatrix( 0 , i) = get_rs.Fields(i).Name
Next i
Do While Not get_rs.EOF
    gridname.Rows = gridname.Rows +  1 
    For i =  0  To get_rs.Fields.Count -  1 
    If Not get_rs.Fields(i) = "" Then
        gridname.TextMatrix(gridname.Rows -  1 , i) = get_rs.Fields(i)
    End If
    Next i
get_rs.MoveNext
Loop
Set gridname = Nothing
Exit Sub
My_Err:
sErrDesc = ""
err_num =  0 
sErrDesc = Err.Description
err_num = Err.Number
OutputErrorMessage sErrDesc, "grid", err_num
End Sub
''''''''''''''''''''''''''''''''''''''''''''''
' создаем command для работы с хранимыми процедурами
'''''''''''''''''''''''''''''''''''''''''''''''
Public Function get_comm(get_conn As ADODB.Connection, proc As String) As ADODB.Command
On Error GoTo My_Err
If Not bIsOpen Then
    Exit Function
End If
Set comm = New ADODB.Command
comm.ActiveConnection = get_conn
comm.CommandType = adCmdStoredProc
comm.CommandText = proc
Set get_comm = comm
Set comm = Nothing
Exit Function
My_Err:
sErrDesc = ""
err_num =  0 
sErrDesc = Err.Description
err_num = Err.Number
OutputErrorMessage sErrDesc, "command", err_num
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''
' создаем recordset
''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function get_rs(get_conn, strquery) As ADODB.Recordset
On Error GoTo My_Err
If Not bIsOpen Then
    Exit Function
End If
Set rs = New ADODB.Recordset
rs.Open strquery, get_conn, adOpenDynamic
Set get_rs = rs
Set rs = Nothing
Exit Function
My_Err:
sErrDesc = ""
err_num =  0 
sErrDesc = Err.Description
err_num = Err.Number
OutputErrorMessage sErrDesc, "recordset", err_num
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''
' закрываем recordset
'''''''''''''''''''''''''''''''''''''''''''''''
Public Sub CloseRs(get_rs As ADODB.Recordset)
    On Error Resume Next
    If IsObject(get_rs) Then
        If get_rs.State =  1  Then: get_rs.Close
    End If
    'If Err.Number <> 0 Then strErr = strErr & Err.Number & " / " & Err.Description & "<br>"
    Set get_rs = Nothing
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''
' закрываем connection
''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub CloseCn(get_conn As ADODB.Connection)
    On Error Resume Next
    If IsObject(get_conn) Then
        If get_conn.State =  1  Then: get_conn.Close
    End If
    'If Err.Number <> 0 Then strErr = strErr & Err.Number & " / " & Err.Description & "<br>"
    Set get_conn = Nothing
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''
' закрываем command
'''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub CloseComm(get_comm As ADODB.Command)
    On Error Resume Next
'    If IsObject(get_comm) Then
'        If get_comm.State = 1 Then: get_comm.Cancel
'    End If
    'If Err.Number <> 0 Then strErr = strErr & Err.Number & " / " & Err.Description & "<br>"
    Set get_comm = Nothing
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''
' записываем ошибки в таблицу errors
' используя command и хранимую процедуру
'''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub OutputErrorMessage(err_des As String, from As String, num As Integer)
'On Error GoTo My_Err
Set conn = get_conn
Set comm = get_comm(conn, "add_to_err")
Set prm = comm.Parameters
prm.Append comm.CreateParameter("my_err", adVarChar, adParamInput,  200 , err_des)
prm.Append comm.CreateParameter("fr", adVarChar, adParamInput,  45 , from)
prm.Append comm.CreateParameter("num", adBigInt, adParamInput,  40 , num)
comm.Execute
CloseComm comm
CloseCn conn
Exit Sub
My_Err:
End Sub