The following VBA code creates a new database from within Excel and adds a table to it. Everything works great until the line objConn.Close. This line causes Excel to crash with a BEX error. If I comment out that line the code runs fine but the database lock remains. Any help would be appreciated.
Option Explicit
Sub openADB()
Dim adoxTab As ADOX.Table
Dim adoxCat As ADOX.Catalog
Dim adoxCol As ADOX.Column
Dim adoxInd As New ADOX.Index
Dim objConn As New ADODB.Connection
Dim oCatalog As Object
Const DB_NAME = "item_details.accdb"
Const DB_PATH = "c:\temp\"
'create the database
Set oCatalog = CreateObject("ADOX.Catalog")
oCatalog.Create "Provider='Microsoft.ACE.OLEDB.12.0';Data Source=" & DB_PATH & DB_NAME
objConn.Open "Provider='Microsoft.ACE.OLEDB.12.0';Data Source=" & DB_PATH & DB_NAME
If (objConn.State <> adStateOpen) Then
MsgBox "A connection to the database " & DB_PATH & DB_NAME & " could not be established. Program terminated."
objConn.Close
Set objConn = Nothing
End
End If
'create a table for currency
Set adoxTab = CreateObject("ADOX.Table")
Set adoxCat = CreateObject("ADOX.Catalog")
Set adoxCat.ActiveConnection = objConn
'field properties
adoxTab.Name = "tblCurrency"
adoxTab.Columns.Append "Currency", adVarWChar, 3
adoxTab.Columns.Append "Factor", adSingle
adoxTab.Columns("Currency").ParentCatalog = adoxCat
adoxTab.Columns("Currency").Properties("JET OLEDB:Compressed Unicode Strings") = True
adoxTab.Columns("Currency").Properties("JET OLEDB:Allow Zero Length") = False
adoxTab.Columns("Currency").Properties("Nullable") = True
adoxTab.Columns("Factor").ParentCatalog = adoxCat
adoxTab.Columns("Factor").Properties("Nullable") = True
adoxCat.Tables.Append adoxTab
'set up a primary key for Item
adoxTab.Keys.Append "PrimaryKey", adKeyPrimary, "Currency"
'give back memory
Set adoxCat = Nothing
Set adoxTab = Nothing
Set oCatalog = Nothing
objConn.Close '<== this is the line that causes the error
Set objConn = Nothing
End Sub
Related
I am trying to create a VBA script that will pull the results from a View (SELECT * FROM view_name) from the RecordSet.Source property, but when attempted, my CloseConnection error handler keeps getting caught. I can get results from a table using a simple query like SELECT * FROM tbl_name with no issues.
Below is the code I am using. Note: my Const variable has the Provider and Database information removed.
I guess it really comes down to is it even possible to get results from a View like I would from a table?
Option Explicit
Const ConStrMSSQL As String = _
"Provider=provider_name;Database=database_name;Trusted_Connection=yes;"
Sub test()
Dim formConnect As ADODB.connection
Dim formData As ADODB.recordSet
Dim formField As ADODB.Field
Set formConnect = New ADODB.connection
Set formData = New ADODB.recordSet
formConnect.ConnectionString = ConStrMSSQL
formConnect.Open
On Error GoTo CloseConnection
With formData
.ActiveConnection = formConnect
.Source = "SELECT * FROM v_data_extract_658"
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With
On Error GoTo CloseRecordset
Sheets("test").Range("A1").Select
For Each formField In formData.Fields
ActiveCell.Value = formField.Name
ActiveCell.Offset(0, 1).Select
Next formField
Sheets("test").Range("A2").CopyFromRecordset formData
On Error GoTo 0
CloseRecordset:
formData.Close
CloseConnection:
formConnect.Close
End Sub
This is the error message:
run-time error 2147467259 (80004005): unknown token received from SQL Server
I think the big issue here is that you haven't defined a Command Object.
I somewhat put this together "freehand" and for certain, didn't test it but it should get you to where you need to go.
Sub test()
On Error GoTo ErrorHandle:
Dim formConnect As ADODB.Connection
Set formConnect = New ADODB.Connection
formConnect.ConnectionString = ConStrMSSQL
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
formConnect.Open
With cmd
.ActiveConnection = formConnect
.CommandType = adCmdText
.CommandText = "SELECT * FROM v_data_extract_658"
.CommandTimeout = 30
End With
Dim formData As ADODB.Recordset
Set formData = New ADODB.Recordset
formData.Open cmd, , adOpenStatic, adLockReadOnly
Sheets("test").Range("A1").Select
Dim formField As ADODB.Field
For Each formField In formData.Fields
ActiveCell.value = formField.Name
ActiveCell.Offset(0, 1).Select
Next formField
Range("A2").CopyFromRecordset formData
On Error GoTo 0
Cleanup:
If Not formData Is Nothing Then
If formData.State <> adStateClosed Then formData.Close
Set formData = Nothing
End If
If Not formConnect Is Nothing Then
If formConnect.State <> adStateClosed Then formConnect.Close
Set formConnect = Nothing
End If
Set cmd = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description
'Do whatever else is needed to respond to errors.
Resume Cleanup
End Sub
Using Excel & VBA to fetch dta from SLQ Server is quite easy (not always, but these days).
Sub ADOExcelSQLServer()
' Carl SQL Server Connection
'
' FOR THIS CODE TO WORK
' In VBE you need to go Tools References and check Microsoft Active X Data Objects 2.x library
'
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim SQLStr As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Server_Name = "EXCEL-PC\SQLEXPRESS" ' Enter your server name here
Database_Name = "NORTHWND" ' Enter your database name here
User_ID = "" ' enter your user ID here
Password = "" ' Enter your password here
SQLStr = "SELECT * FROM [Customers]" ' Enter your SQL here
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
rs.Open SQLStr, Cn, adOpenStatic
' Dump to spreadsheet
For iCols = 0 To rs.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With Worksheets("sheet1").Range("a2:z500") ' Enter your sheet name and range here
'.ClearContents
.CopyFromRecordset rs
End With
' Tidy up
rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
As an aside, you can try this as well (please change to suit your specific setup/configuration)...
Sub Working2()
Dim con As Connection
Dim rst As Recordset
Dim strConn As String
Set con = New Connection
strConn = "EXCEL-PC\SQLEXPRESS;Database=Northwind;Trusted_Connection=True"
con.Open strConn
'Put a country name in Cell E1
Set rst = con.Execute("Exec dbo.MyOrders '" & ActiveSheet.Range("E1").Text & "'" & ActiveSheet.Range("E2").Text & "'")
'The total count of records is returned to Cell A5
ActiveSheet.Range("A5").CopyFromRecordset rst
rst.Close
con.Close
End Sub
Please see the link below for more details.
https://www.excel-sql-server.com/excel-sql-server-import-export-using-vba.htm#Excel%20Data%20Export%20to%20SQL%20Server%20Test%20Code
Public Function `RecordsetSybase(sqlstr As String) As ADODB.Recordset
If TestSybaseConnection() = False Then
setLogin
End If
Dim commandObject As ADODB.Command
Set commandObject = New ADODB.Command
Dim data As New ADODB.Recordset
With commandObject
.CommandText = sqlstr
.ActiveConnection = SybaseConnection(getUID, getPASS)
.CommandTimeout = 350
End With
data.Open commandObject.CommandText, commandObject.ActiveConnection
'Do Until data.EOF = True
'MsgBox data(0)
'data.MoveNext
'Loop
commandObject.ActiveConnection.Close
Set RecordsetSybase = data
Set commandObject = Nothing
End Function
Sub classific()
Dim conn As WorkbookConnection
Dim strSQL As String
Dim rs As New ADODB.Recordset
'Query
strSQL = "SELECT DISTINCT name_short_orig, cl_rating " & _
"FROM pbsm_hist.dbo.pbsm_auths_hist_adjusted " & _
"WHERE name_short_orig IS NOT Null " & _
"AND cl_rating NOT IN ('F+','F','Z') "
Set rs = RecordsetSybase(strSQL)
MsgBox rs
End Sub
I can display the recordset in the function (see comments).
But I cannot do it in the sub, I get the following error message:
Run-time error '13':
Type mismatch
You are completely bypassing the command object, currently its just sitting there storing the command text and connection.
To actually use the command object:
set data = commandObject.execute()
As for the error, MsgBox rs is not valid - what would you expect to see as the string representation of the rs object?
If you wanted the 1st value:
if not rs.eof then msgbox rs.collect(0)
Dim colResults As New Collection
Dim intI As Integer
Dim objConn As ADODB.Connection
Dim objCmd As ADODB.Command
Dim objRs As ADODB.Recordset
Dim strErrText As String
Dim oField As ADODB.Field
Dim sVal
On Error GoTo RaiseError
Set objConn = New ADODB.Connection
objConn.open DBConnString
Set objCmd = New ADODB.Command
Set objCmd.ActiveConnection = objConn
objCmd.CommandType = adCmdStoredProc
objCmd.CommandText = "spSearchHistory_Read"
objCmd.Parameters(1) = CLng(sUserID)
Set objRs = objCmd.Execute
intI = 1
For Each oField In objRs.fields
If IsNull(oField.Value) Then
'fix null vals so the front end doesnt trip up trying to access them
sVal = ""
Else
If oField.Type = adDBTimeStamp Then
sVal = Format(oField.Value, "dd/mm/yyyy hh:mm")
Else
sVal = oField.Value
End If
End If
colResults.Add sVal, oField.Name
Next
objConn.Close
Set SearchHistory = colResults
Set objRs = Nothing
Set objCmd = Nothing
Set objConn = Nothing
GoTo END_OF_FUNC
RaiseError:
strErrText = "CutomerSearch.SearchHistory" & vbTab & " - " & vbTab & Err.Number & " - " & Err.Description
WriteToLogFile strErrText
WriteToEventLog strErrText
END_OF_FUNC:
a collection will accept only elements with no duplicated keys
it must be that your code at some point tries to add to colResults a new "value" but with a "key" you already gave to a previously added element
to find out what's happening you can adopt this snippet:
On Error Resume Next '<~~ temporarily suspend your error handling mode to detect duplicates
colResults.Add sVal, oField.Name '<~~ this will result in error 457 if trying to add a new item with a key you assigned to an element already in collection
If Err <> 0 Then
'possible code to handle duplicates
'On Error GoTo RaiseError '<~~ resume your error handling mode
'... code
End If
On Error GoTo RaiseError '<~~ resume your error handling mode
from your code I could guess it's happening because you're adding elements to the collection even if IsNull(oField.Value), thus making it possible to add elements with the same Null key
should that be the case you may want to keep colResults.Add sVal, oField.Name statements inside the Else-End If block, like follows
If IsNull(oField.Value) Then
'fix null vals so the front end doesnt trip up trying to access them
sVal = ""
Else
If oField.Type = adDBTimeStamp Then
sVal = Format(oField.Value, "dd/mm/yyyy hh:mm")
Else
sVal = oField.Value
End If
colResults.Add sVal, oField.Name '<~~ add elements only if oField.Value is not Null
End If
I'm trying to get data that is produced from a SQL Stored Procedure to be appended on to the end of existing data within my excel spreadsheet using VBA. I want it pasted to the right of the last column. Each time I run it i get the error above: "Method 'Range' of object '_Global' failed.
I would like the new data pasted into row 3 to the right of the existing data. Below is my vba code:
Sub RefreshStatus()
Dim db As DAO.Database
Dim con As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim StoredProc As String
Dim RWS As Worksheet
Dim DWS As Worksheet
Dim ServerName As String
Dim DatabaseName As String
Dim StoredProcedure As String
Set con = New ADODB.Connection
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
Set RWS = Worksheets("Refresh")
Set DWS = Worksheets("141215")
Application.DisplayStatusBar = True
Application.StatusBar = "Contacting SQL Server..."
RWS.Activate
ServerName = "tns-reports-01" ' Enter your server name here
DatabaseName = "GroupPerformance" ' Enter your database name here
StoredProcedure = "JM_Recruitment_Status_141215" ' Enter Stored Procedure here
con.Open "Provider=SQLOLEDB;Data Source=" & ServerName & ";Initial Catalog=" & DatabaseName & ";Trusted_Connection=yes"
cmd.ActiveConnection = con
Application.StatusBar = "Running stored procedure..."
cmd.CommandTimeout = 0
cmd.CommandText = StoredProcedure
Set rs = cmd.Execute(, , adCmdStoredProc)
' Copy the results to cell A1 on the first Worksheet
DWS.Activate
Dim Lastcol As Long
Lastcol = Range("3" & Columns.Count).End(xlRight).Row
If rs.EOF = False Then DWS.Cells(2, 1).CopyFromRecordset rs
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
Application.StatusBar = "Data successfully updated."
End Sub
If anybody could help me out, I would greatly appreciate it.
Many thanks.
You made some errors when trying to find the last non-empty column and some other minor errors.
Below is your code with a few changes (changes are described in comments).
I have assumed that your recordset contains only one field and many records and
you want to paste all those records horizontally from cell _3 to the right where _ is the first empty column.
Sub RefreshStatus()
Dim db As DAO.Database
Dim con As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim StoredProc As String
Dim RWS As Worksheet
Dim DWS As Worksheet
Dim ServerName As String
Dim DatabaseName As String
Dim StoredProcedure As String
Set con = New ADODB.Connection
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
Set RWS = Worksheets("Refresh")
Set DWS = Worksheets("141215")
With Application
.DisplayStatusBar = True
.StatusBar = "Contacting SQL Server..."
End With
'NOTE: You don't have to activate worksheet to operate on its ranges.
'Actually, you shouldn't do that, since it's time-consuming, make the
'user experience worst and can cause errors in specific cases.
'Additionaly, I can't see where you use RWS worksheet later in the code.
'RWS.Activate
ServerName = "tns-reports-01" ' Enter your server name here
DatabaseName = "GroupPerformance" ' Enter your database name here
StoredProcedure = "JM_Recruitment_Status_141215" ' Enter Stored Procedure here
con.Open "Provider=SQLOLEDB;Data Source=" & ServerName & ";Initial Catalog=" & DatabaseName & ";Trusted_Connection=yes"
cmd.ActiveConnection = con
Application.StatusBar = "Running stored procedure..."
cmd.CommandTimeout = 0
cmd.CommandText = StoredProcedure
Set rs = cmd.Execute(, , adCmdStoredProc)
' Copy the results to cell A1 on the first Worksheet
'Again, it is not necessary to activate worksheet.
'DWS.Activate
Dim lastCol As Long
'If rs.EOF = False Then DWS.Cells(2, 1).CopyFromRecordset rs
row = 3
lastCol = DWS.Cells(row, DWS.Columns.Count).End(xlRight).Column + 1
Do Until rs.EOF
DWS.Cells(row, lastCol).value = rs.Fields(0).value
row = row + 1
Call rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
Application.StatusBar = "Data successfully updated."
End Sub
I have the following code:
Sub Stats1()
Workbooks("2006_2007_2008.xls").Sheets("Sheet1").Select
Worksheets("Sheet1").Activate
Dim my_cell As String
my_cell = InputBox("Which cell?")
Dim objConn As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim strSQL As String
Dim mycell As String
szconnect = "Provider=SQLOLEDB;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=*****;Data Source=*****"
'Create the Connection and Recordset objects.
Set objConn = New ADODB.Connection
Set rsData = New ADODB.Recordset
On Error GoTo errHandler
'Open the Connection and execute the stored procedure
objConn.Open szconnect
strSQL = "SELECT *fom mytable"
objConn.CommandTimeout = 0
Set rsData = objConn.Execute(strSQL)
For iCols = 0 To rsData.Fields.Count - 1
ActiveSheet.Range(my_cell).Select
ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column + iCols).Value = rsData.Fields (iCols).Name
ActiveSheet.Cells.Font.Name = "Arial"
ActiveSheet.Cells.Font.Size = 8
Next
ActiveSheet.Range(ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column), ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column + rsData.Fields.Count)).Font.Bold = True
If Not rsData.EOF Then
'Dump the contents of the recordset onto the worksheet
On Error GoTo errHandler
ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column).CopyFromRecordset rsData
If Not rsData.EOF Then
MsgBox "Data set too large for a worksheet!"
End If
rsData.Close
End If
Unload frmSQLQueryADO
Exit Sub
errHandler:
MsgBox Err.Description, vbCritical, "Error No: " & Err.Number
'Unload frmSQLQueryADO
End Sub
i get the "424 Object required error"...dont know what the issue is...!
i think i have added all the correct references
One obvious problem:
strSQL = "SELECT *fom mytable"
should be
strSQL = "SELECT * from mytable"
EDIT: I tested the code above in a mock-up, and while it ought to be considerably tidied, it does work. Therefore, I suggest the error is in this line:
Unload frmSQLQueryADO
Try commenting the line and seeing if it works.
rsData is the Record Set returned from the query, not the connection.
Try objConn.Close instead