Все соединения с сервером в MQ работають а через ВБ неа
(
вот код:
Sub preparerepo()
On Error GoTo ErrHandler:
fin = False
UserForm2.Calendar1.Value = Date
UserForm4.Show
If fin Then GoTo 1:
UserForm3.TextBox1.Text = Worksheets("Serv").Cells(1, 1).Value
UserForm3.Show
If fin Then GoTo 1:
login = UserForm3.TextBox1.Text
pass = UserForm3.TextBox2.Text
Dim objConn As New ADODB.Connection
Dim objCmd As New ADODB.Command
Dim objRs As New ADODB.Recordset
If UserForm4.OptionButton1.Value Then
objCmd.CommandText = "select id,name,paramcode,reffercode from sv_connotationlist l where taskcode='clients' and exists(select 1 from connotationvalues v where v.kind=l.id) order by paramcode"
Else
objCmd.CommandText = "select id,name,paramcode,reffercode from sv_connotationlist l where taskcode='amounts' and exists(select 1 from connotationvalues v where v.kind=l.id) order by paramcode"
End If
objCmd.CommandType = adCmdText
objCmd.CommandTimeout = 0
Dim sCnStr As String
sCnStr = "Provider='SQLOLEDB';Data Source='" + Worksheets("Serv").Cells(1, 3).Value + "';" & _
"User ID = " + login + ";Password= " + pass + ";Initial Catalog='" + Worksheets("Serv").Cells(1, 2).Value + "';"
'sCnStr = "Provider='SQLOLEDB';Data Source='" + Worksheets("Serv").Cells(1, 3).Value + "';" & _
' "User ID = sa;Password= sa;Initial Catalog='" + Worksheets("Serv").Cells(1, 2).Value + "';"
objConn.CommandTimeout = 0
objConn.ConnectionTimeout = 0
objConn.Open sCnStr
objCmd.ActiveConnection = objConn
Set objRs = objCmd.Execute
Dim mname As Integer, mparcode As Integer, mrefcode As Integer
mname = 0
mparcode = 0
mrefcode = 0
i = 0
While Not (objRs.EOF)
ReDim Preserve res(1 To 4, 0 To i)
res(4, i) = objRs.Fields("id")
res(3, i) = objRs.Fields("Name")
res(1, i) = objRs.Fields("paramcode")
res(2, i) = objRs.Fields("reffercode")
If Len(res(3, i)) > mname Then mname = Len(res(3, i))
If Len(res(1, i)) > mparcode Then mparcode = Len(res(1, i))
If Len(res(2, i)) > mrefcode Then mrefcode = Len(res(2, i))
i = i + 1
objRs.MoveNext
Wend
objRs.Close
'Set objCmd = Nothing
'Set objCmd = New ADODB.Command
'objCmd.ActiveConnection = objConn
UserForm1.ListBox1.Column = res
UserForm1.ListBox1.ColumnWidths = "90;60;400;0"
UserForm1.Show
If fin Then GoTo 1:
objCmd.CommandType = adCmdStoredProc
If UserForm4.OptionButton1.Value Then
objCmd.CommandText = "sc_rekvizit;1"
Else
objCmd.CommandText = "sc_rekvizit;2"
End If
objCmd.Parameters.Refresh
Dim kinds As String
kinds = ""
For i = 0 To UserForm1.ListBox1.ListCount - 1
If UserForm1.ListBox1.Selected(i) Then kinds = kinds + res(4, i) + ";"
Next i
objCmd.Parameters("@kinds").Value = kinds
objCmd.Parameters("@Daydate").Value = UserForm2.Calendar1.Value - 2
Set objRs = objCmd.Execute
'MsgBox (Str(objRs.RecordCount))
If UserForm4.OptionButton1 Then
Worksheets("Êëèåíòû").Range("a2").CopyFromRecordset objRs
Application.DisplayAlerts = False
Worksheets("Ñ÷åòà").Delete
Application.DisplayAlerts = True
Else
Worksheets("Ñ÷åòà").Range("a2").CopyFromRecordset objRs
Application.DisplayAlerts = False
Worksheets("Êëèåíòû").Delete
Application.DisplayAlerts = True
End If
Application.DisplayAlerts = False
Worksheets("Serv").Delete
Application.DisplayAlerts = True
objRs.Close
objConn.Close
Set objRs = Nothing
Set objConn = Nothing
Set objCmd = Nothing
1:
pass = ""
UserForm3.TextBox2.Text = ""
Exit Sub
ErrHandler:
'clean up
If objRs.State = adStateOpen Then
objRs.Close
End If
If objConn.State = adStateOpen Then
objConn.Close
End If
Set objRs = Nothing
Set objConn = Nothing
Set objCmd = Nothing
If Err <> 0 Then
MsgBox Err.Source & "-->" & Err.Description, , "Error"
End If
pass = ""
UserForm3.TextBox2.Text = ""
End Sub
Function WorkbookDeleteVBA(oWorkbook As Excel.Workbook) As Boolean
Dim oComponent As Object
Dim oComponents As Object
On Error GoTo ErrFailed
Set oComponents = oWorkbook.VBProject.VBComponents
For Each oComponent In oComponents
Select Case oComponent.Type
'vbext_ct_StdModule, vbext_ct_MSForm, vbext_ct_ClassModule
Case 1, 3, 2
oComponents.Remove oComponent
Case Else
oComponent.CodeModule.DeleteLines 1, oComponent.CodeModule.CountOfLines
End Select
Next
WorkbookDeleteVBA = True
Exit Function
ErrFailed:
Debug.Print "Error in WorkbookDeleteVBA: " & Err.Description
WorkbookDeleteVBA = False
End Function
