Option Explicit

Public cn As ADODB.Connection
Public cn_ok As Boolean
Public ServerName As String
Public DatabaseName As String
Public UserName As String
Public Password As String
Public delta_pr As Single

'рабочие переменные
Dim aSheet As Worksheet
Dim sqlstr As String

Dim rs_rep As ADODB.Recordset

Sub cn_open()

ServerName = "...."
DatabaseName = "...."
UserName = "..."
Password = "..."

' Set connection properties.
Set cn = New ADODB.Connection
cn.ConnectionTimeout = 25
cn.CommandTimeout = 180
cn.Provider = "sqloledb.1"
cn.Properties("Data Source").Value = ServerName
cn.Properties("Initial Catalog").Value = DatabaseName
cn.Properties("User ID").Value = UserName
cn.Properties("Password").Value = Password
cn.CursorLocation = adUseClient


' Change mousepointer while trying to open database.
Application.Cursor = xlWait

' Open the database.
cn.Open

Debug.Print cn.State
' Change mousepointer back to the default after open.
Application.Cursor = xlDefault

cn_ok = True 'формируем признак
Exit Sub

ErrorConnect:
' Change mousepointer back to the default after open.
Application.Cursor = xlDefault

cn_ok = False
MsgBox "No server connection.", , "Login"
'Call cn_close

End Sub

Sub cn_close()
cn.Close
Set cn = Nothing
End Sub

Sub read_data() 'процедура чтения выборки и переноса данных на лист

Dim sqlstr As String
Dim i_rows As Integer
Dim i_cols As Integer
Dim i As Integer
Dim j As Integer

'считываем данные
sqlstr = "set nocount on set dateformat dmy "
sqlstr = sqlstr & " declare @dtmDatBeg datetime declare @dtmDatEnd datetime "
sqlstr = sqlstr & " set @dtmDatBeg='" & dtmDatBeg & "'"
sqlstr = sqlstr & " set @dtmDatEnd='" & dtmDatEnd & "'"
sqlstr = sqlstr & " exec li_Pkol_get_lg @dtmDatBeg, @dtmDatEnd"

'MsgBox (sqlstr)
Debug.Print sqlstr

On Error GoTo Error_Checker

Set rs_rep = New ADODB.Recordset
rs_rep.CursorLocation = adUseClient
rs_rep.CursorType = adOpenStatic

Application.Cursor = xlWait
rs_rep.Open sqlstr, cn, , , adCmdText

Application.Cursor = xlDefault

If rs_rep.EOF = True And rs_rep.BOF = True Then
MsgBox "Пустая таблица для данных параметров"
GoTo exit_sub
End If

'создаем лист
add_list = True
'создаем лист
Set aSheet = Worksheets.Add
aSheet.Name = "данные"
aSheet.Visible = False

'настраиваем лист
i = 2 'куда вставлять
i_cols = rs_rep.Fields.Count
i_rows = rs_rep.RecordCount

'вставляем заголовки
For j = 1 To i_cols
aSheet.Cells(1, j) = rs_rep.Fields.Item(j - 1).Name
Next j

'заполняем лист из рекордсета
Application.StatusBar = " заносим на лист "
While rs_rep.EOF = False '---------------------------

For j = 1 To i_cols

'w = rs_rep.Fields.Item(j - 1).Type

If rs_rep.Fields.Item(j - 1).Type = 200 Then 'для символьных

If IsNull(rs_rep.Fields.Item(j - 1)) Then
w = ""
Else
w = Trim(rs_rep.Fields.Item(j - 1))
End If
If InStr(w, vbCr) > 0 Then
w = Replace(w, vbCr, "_")
w = Replace(w, vbLf, "_")
End If
Else
w = rs_rep.Fields.Item(j - 1)
End If

aSheet.Cells(i, j) = w
Next j
i = i + 1
rs_rep.MoveNext
Wend '----------------------------


exit_sub:

rs_rep.Close
Set rs_rep = Nothing
'On Error GoTo 0
Exit Sub

Error_Checker:
'display a comprehensive (исчерпывающий) MsgBox error handler
With Err
MsgBox "Error: " & .Number & vbCrLf & _
"Possible Causes: " & .Description, _
vbOKOnly, "ERROR in: " & .Source
End With
'On Error GoTo 0
End Sub