ADO with KDB+/qodbc.dll in VBA - vba

I have an Excel based application reliant on several different databases which I connect to using ADO (Microsoft ActiveX Data Objects 6.1 Library). The databases reside on regional servers and there is an overhead in establishing the initial connection so I cache the connections in a Scripting.Dictionary object for reuse.
Private moConnCacheDict As Scripting.Dictionary
When I use the kdb+ qodbc.dll database drivers I get unexpected behavior. I can connect and reuse multiple data sources (Oracle,Sybase,Access) and one KDB database instance as expected. However, if I create a second KDB database connection and execute a query on the new dataset, no data is returned despite the fact the query is legitimate.
Recordset.BOF = TRUE and Recordset.EOF = TRUE
It appears to execute fine and the fields are visible. The connection to the previous regional server seems to persist and I can successfully retrieve data which resides on the original server despite the fact that if I look at,
Recordset.ActiveCommand.ActiveConnection.Properties.Item("Extended Properties")
, is the new connection string.
The KDB+ connection string uses the following syntax:
DRIVER=kdb+;DBQ=XXXXX;UID=XXXXX;PWD=XXXXX;
I have included the core VBA functions used as an example:
Private Function ExecuteQuery(sDBName As String, ByRef oRst As ADODB.Recordset, Optional bDeleteConnection As Boolean) As Boolean
Dim oDBConn As ADODB.Connection
Dim sSql As String
'delete connection
If bDeleteConnection Then Call DropConnection(sDBName)
'get cached or new connection
Call GetConnection(sDBName, oDBConn)
Select Case sDBName
Case "MAIN_US"
sSql = mSQL_MAIN
Case "MD_ASIA"
sSql = mSQL_MDASIA
End Select
Set oRst = New Recordset
oRst.Open sSql, oDBConn, adOpenKeyset, adLockPessimistic
If Not oDBConn.State = adStateOpen Then Err.Raise vbObjectError + 1024, "ExecuteQuery", sDBName & ": Recordset Closed. Unable to execute query ->" & sSql
ExecuteQuery = True
End Function
Private Function GetConnection(sDBName As String, ByRef oDBConn As ADODB.Connection) As Boolean
If moConnCacheDict Is Nothing Then Set moConnCacheDict = New Dictionary
If moConnCacheDict.Exists(sDBName) Then
'get existing connection
Set oDBConn = moConnCacheDict.Item(sDBName)
Else
'create connection
Set oDBConn = New Connection
With oDBConn
.Mode = adModeRead
Select Case sDBName
Case "MAIN_US"
.Mode = adModeReadWrite
.ConnectionString = mCONN_MAIN
Case "MD_ASIA"
.Mode = adModeRead
.ConnectionString = mCONN_MDASIA
End Select
.CursorLocation = adUseServer
.Open
End With
moConnCacheDict.Add sDBName, oDBConn
End If
GetConnection = True
End Function
Private Function DropConnection(Optional sDBName As String) As Boolean
Dim oDBConn As ADODB.Connection
Dim i As Integer
'delete object directly from cache
If Not moConnCacheDict Is Nothing Then
If sDBName = vbNullString Then
'close all connections
For i = 0 To moConnCacheDict.Count - 1
If Not IsEmpty(moConnCacheDict.Items(i)) Then
Set oDBConn = moConnCacheDict.Items(i)
If Not oDBConn Is Nothing Then
If oDBConn.State = adStateOpen Then oDBConn.Close
Set oDBConn = Nothing
Debug.Print Now, "Dropping Database Connection - " & moConnCacheDict.Keys(i)
End If
End If
Next i
Set moConnCacheDict = Nothing
Else
If moConnCacheDict.Exists(sDBName) Then
If Not IsEmpty(moConnCacheDict.Item(sDBName)) Then
Set oDBConn = moConnCacheDict.Item(sDBName)
If Not oDBConn Is Nothing Then
If oDBConn.State = adStateOpen Then oDBConn.Close
Set oDBConn = Nothing
Debug.Print Now, "Dropping Database Connection - " & "Dropping Database Connection - " & sDBName
End If
End If
moConnCacheDict.Remove (sDBName)
End If
End If
End If
DropConnection = True
End Function
(Note the ADO.Recordset is always closed and set to nothing by the caller).
The only way to resolve the issue is to close all database connections (regardless of the provider) and then reconnect to the desired regional server. This is horrendously inefficient as I have to reopen all the existing connections. Also note that it is not sufficient to do this purely in the current workbook. This must be done at the application level. If ANY ADO connections to ANY database are still open, I can create a new KDB+ ADO Connection but it will still point to the previous instance.
I have looked at the error properties of the KDB+ connection object and there are two errors:
Multiple-step OLE DB operation generated errors. Check each OLE DB status value, if available. No work was done.
Provider does not support the property.
This appears to be documented in http://support.microsoft.com/kb/269495 but I am unable to locate any CLSID in the registry so am unable to experiment with the suggested change.
If I turn on ODBC logging I see the following message:
EXCEL 8dc-22d0 EXIT SQLGetInfoW with return code -1 (SQL_ERROR)
HDBC 0x02131EA8
UWORD 151 <SQL_KEYSET_CURSOR_ATTRIBUTES2>
PTR 0x003C4FB0
SWORD 4
SWORD * 0x00000000
DIAG [S1096] [Microsoft][ODBC Driver Manager] Information type out of range (0)
Would this be responsible for the error anyway?
As always, any help and suggestions would be much appreciated.

What you're seeing is a bug in the driver, and you should look for more recent drivers.
I shouldn't really give a full answer (instead of a comment) if I haven't run and tested the code myself, but I would recommend that you enumerate the properties collection of the connection object and look for connection pooling.
Setting connection pooling to 0 (or to false, depending on what you can guess from viewing the vartype of the property's value) is a promising workaround. Your other option is to use a forward-only recordset: that may or not work, but its worth trying.
NB: There was an open-source project a couple of years ago to write a proper OLEDB drive, but that seems to have faded from view.

Related

PostgreSQL/VBA: transaction block fail check or process

During a transaction block, if part of it fails or gets interrupted what is the best way to handle this?
I am thinking intermediate queries (see code comments) to confirm that the previous query was successful. Or is there a better way?
Sub SetDataProcessPriorities()
Dim cCon As New ADODB.Connection
Set cCon = Application.Run("Personal.xlsb!ConnectToPg")
Call Application.Run("Personal.xlsb!SendPgQueryOnly", "begin;", cCon)
Call Application.Run("Personal.xlsb!SendPgQueryOnly", "delete from data_proc_pri;", cCon)
'intermediate select query here?
Call Application.Run("Personal.xlsb!SendPgQueryOnly", "insert into data_proc_pri select * from data_proc_pri_store;", cCon)
'intermediate select query here?
Call Application.Run("Personal.xlsb!SendPgQueryOnly", "commit;", cCon)
End Sub
I'm open to a VBA (sorry) or PostgreSQL (or both) focused solution.
Bonus question: What do you call this type of programming? Infrastructure programming?
Personal workbook code if you need it:
Sub SendPgQueryOnly(sSql As String, Optional cCon As ADODB.Connection, Optional sOdbcName As String = "[omitted]")
sCaller = "SendPgQueryOnly"
Dim cnDB As New ADODB.Connection
Dim rsRecords As New ADODB.Recordset
If IsMissing(cCon) Or cCon Is Nothing Then
cnDB.Open sOdbcName
rsRecords.CursorType = 2 'adOpenDynamic
rsRecords.Open sSql, cnDB
Else
rsRecords.CursorType = 2 'adOpenDynamic
rsRecords.Open sSql, cCon 'use the passed connection obj
End If
cleanup:
Set rsRecords = Nothing
Set cnDB = Nothing
End Sub
Function ConnectToPg(Optional sOdbcName As String = "[omitted]") As ADODB.Connection
sCaller = "ConnectToPg"
Dim cnDB As New ADODB.Connection
cnDB.Open sOdbcName
Set ConnectToPg = cnDB
End Function
For transactional control you can use the BeginTrans, CommitTrans, and RollbackTrans Methods on a Connection object
https://msdn.microsoft.com/en-us/library/ms680895(v=vs.85).aspx
Whilst one has a degree of programming style and latitude given the specific problem I guess one could query the database using some Select queries to ensure that the database state was changed as expected; if as expected then commit and if not then rollback.

Access form linked to disconnected ADODB.Recordset: save changes

I am trying to set up a form to use a disconnected ADODB.Recordset as its source.
The issue I have is that changes are not saved into the original Access table upon closing the form and replying "Yes" to the prompt. What am I missing ?
Note: Please don't tell me the method is useless, it's just a POC with a local table, I plan to try later with a more "distant" recordset.
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Private Sub Form_Load()
Set conn = New ADODB.Connection
conn.Open CurrentProject.Connection
Set rs = New ADODB.Recordset
With rs
rs.CursorLocation = adUseClient
rs.Open "select * from amsPor", conn, adOpenStatic, adLockBatchOptimistic
Set rs.ActiveConnection = Nothing
End With
Set Me.Recordset = rs
conn.Close
End Sub
Private Sub Form_Unload(Cancel As Integer)
Select Case MsgBox("Save changes ?", vbQuestion + vbYesNoCancel)
Case vbNo
'do nothing
Case vbYes
conn.Open CurrentProject.Connection
rs.ActiveConnection = conn
rs.UpdateBatch
rs.Close
conn.Close
Set conn = Nothing
Case vbCancel
Cancel = True
End Select
End Sub
Steps to Reproduce:
Take a small table which has a primary key
Generate an automatic form with it
Save the form.
Add the above code to the form, replacing the table name in the select clause.
Empty the Record Source property of the form.
Save and Close the form.
You can open the form and make changes to the data. Upon close, you will be prompted for saving your changes.
EDIT: I wonder if the issue might be in the CurrentProject.Connection ?
In the debug window, I typed ? CurrentProject.Connection and got the following:
Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=\\xxxxxx\yyyy$\Documents\AMS.accdb;Mode=Share Deny None;Extended Properties="";Jet OLEDB:System database=C:\Users\G828992\AppData\Roaming\Microsoft\Access\System.mdw;Jet OLEDB:Registry Path=Software\Microsoft\Office\14.0\Access\Access Connectivity Engine;Jet OLEDB:Database Password="";Jet OLEDB:Engine Type=6;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=True;Jet OLEDB:Bypass UserInfo Validation=False
I came here looking for the same answer as you and after tons of googling and trial and error I finally was able to perform exactly what you are attempting to do. I understand this is an old post but I did not see any answers that actually provided an answer that would allow what you are attempting to do work. I will use your example and try and apply what I had to change and add to get it to work properly.
Dim rs As ADODB.Recordset
Dim conn As ADODB.Connection
Private Sub Form_Load()
If CurrentProject.Connection.State = adStateOpen Then CurrentProject.Connection.Close
Set conn = New ADODB.Connection
conn.Open CurrentProject.Connection.ConnectionString
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open "select * from amsPor", conn, adOpenForwardOnly, adLockBatchOptimistic
If Not rs Is Nothing Then
If Not rs.ActiveConnection Is Nothing Then Set rs.ActiveConnection = Nothing
If Not (rs.eof And rs.BOF) Then
Set Me.Recordset = rs
End If
If conn.State = adStateOpen Then
conn.Close
End If
End If
Call AddNewRecord(Me.Recordset)
End Sub
Private Sub AddNewRecord(ByRef rs As ADODB.Recordset)
On Error Resume Next
If Not rs Is Nothing Then
If rs.Supports(adAddNew) Then
rs.AddNew
rs.Fields("FirstName").Value = "John"
rs.Fields("LastName").Value = "Doe"
If rs.Supports(adUpdate) Then rs.Update
End If
End If
If Err.Number <> 0 Then
Debug.Print "AddNewRecord Err Msg: " & Err.Description
Err.Clear
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Select Case MsgBox("Save changes ?", vbQuestion + vbYesNoCancel)
Case vbYes
Call UpdateDbWithRS(Me.Recordset)
Case vbCancel
Cancel = True
Case Else
' Nothing.
End Select
End Sub
Private Sub UpdateDbWithRS(ByRef rs As ADODB.Recordset)
If Not rs Is Nothing Then
If CurrentProject.Connection.State = adStateOpen Then CurrentProject.Connection.Close
Set conn = New ADODB.Connection
conn.Open CurrentProject.Connection.ConnectionString
rs.ActiveConnection = conn
If rs.Supports(adUpdateBatch) Then
rs.UpdateBatch
If Not conn Is Nothing Then
If conn.State = adStateOpen Then conn.Close
Set conn = Nothing
End If
If Not rs Is Nothing Then
If rs.State = adStateOpen Then rs.Close
Set rs = Nothing
End If
End If
End If
End Sub
With the code above I was able to Add a Record to my Recordset and verify it did not show up in my database table. Then when I performed the UpdateDbWithRS the Record that I had added to the Recordset, previously, was now pushed to my database table.
The biggest changes I had to do with your code was changing conn.Open CurrentProject.Connection to conn.Open CurrentProject.Connection.ConnectionString, adding in the code If CurrentProject.Connection.State = adStateOpen Then CurrentProject.Connection.Close to fix the error I was receiving about the connection already being opened. Then the final biggest change I made was replacing your CursorType of adOpenStatic to adOpenForwardOnly. I am not sure if that last change is truly required but I used it based on a disconnected RecordSet example I found on this Microsoft Support Site.
When you use a disconnected recordset, you do not get the benefit of automatically updating changes to the tables. You need to actually run SQL Update and Insert Statements to save your data.
First of all, your code look perfect and should works as well, but...
Solution 1
As per my experience i'd suggest to forget about such of functionality. Several years ago i struggled with the same problem. I did not found any solution, but i'm almost sure that the access database used in multiuser environment could not be updated, because Jet/ACE engine does not allow to update static recordset when other user had made changes in a meanwhile (changes are rejected).
I resolved this issue by using "temporary table" binded with form:
DELETE * FROM ~TableName;
INSERT INTO ~TableName SELECT * FROM TableName;
User can edit records till Form is opened. On Form_Unload event i run query like this:
UPDATE t1 SET Field1 = t2.Field1,
Field1 = t2.Field2 ... and so on
FROM TableName As t1 INNER JOIN ~TableName AS t2 ON t1.Key = t2.Key
Note, that insertion and deletion of records (if its allowed) should be handled separately.
Solution2
Use dynamic cursor and does not disconnect recordset from database ;)
Catch changes by using Form.Dirty property.
None of your code has anything to do with DISCONNECTED RECORDSETS. Your recordsets are connected. A disconnected recordset can be saved to file as xml or binary. There is no underlying database.
Note we make the disconnected recordset.
Sub Randomise
Randomize
Set rs = CreateObject("ADODB.Recordset")
With rs
.Fields.Append "RandomNumber", 4
.Fields.Append "Txt", 201, 5000
.Open
Do Until Inp.AtEndOfStream
.AddNew
.Fields("RandomNumber").value = Rnd() * 10000
.Fields("Txt").value = Inp.readline
.UpDate
Loop
.Sort = "RandomNumber"
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
End Sub
Here are the states
ConnectionState
The ConnectionState enumeration is used to identify the state of a connector space object. The CSEntry.ConnectionState property contains one of the values of this enumeration.
Connected
The connector space object is connected to a metaverse object.
ExplicitlyConnected
The connector space object is connected explicitly by a member of the MIISAdmins or MIISOperators group to a metaverse object by the account joiner.
Disconnected
The connector space object is not connected to an metaverse object but may be a candidate for connection to a metaverse object in the future.
DisconnectedByFilter
The connector space object was disconnected by the connector filter rules.
Explicitly Disconnected
The connector space object is not connected to a metaverse object and will not be a candidate for connection to a metaverse object in the future.
Placeholder The connector space object exists implicitly in the connected directory, but has not been imported.

Code To eliminate need to enter password

I have an access form that pulls together data from different tables. Some of them require a username and password be entered. This is going out to other users and I would rather them not have to enter the information over and over. Is there a code that I can use that whenever it prompts for a password to have it automatically logged in?
Currently I already have a connection for one DB connection that runs whenever the DB is opened. It looks like:
Public Function StartUp()
Dim cnn As ADODB.Connection
Dim localrst As New ADODB.Recordset
Dim remoterst As New ADODB.Recordset
On Error Resume Next
Set cnn = New ADODB.Connection
cnn.Open "Provider=SQLOLEDB; Data Source=SOURCE; Initial Catalog=NAME;" _
& "User Id=ID; Password=PW;"
If cnn.State = adStateOpen Then
MsgBox ("You have an established connection with the L&TD SQL Server Database and the CDData table has been uploaded to the server.")
Else
MsgBox ("Cannot connect to SQL Server. Data will be stored locally to CDData Table until application is opened again with an established connection.")
End If
On Error GoTo 0
End Function
Is there a way to add more connections to this so it connects to all 3?
The literal answer is; no. You can't make a password form autofill. However, you can set up your connection string so that no one has to fill it in.
'Set up the connection string
strConn = "PROVIDER=SQLOLEDB;DATA SOURCE=MyServerName;INITIAL CATALOG=MyDatabaseName;UID=MyStandardUserID;PWD=MyStandardPassword;"
cnComments.Open strConn
You can also set it up without the username and password:
'Set up the connection string
strConn = "PROVIDER=SQLOLEDB;DATA SOURCE=MyServerName;INITIAL CATALOG=MyDatabaseName;TRUSTED_CONNECTION=yes;"
cnComments.Open strConn

Else Portion of Code keeps timing out

I have a code to check the connection between access and sql server upon opening the form. If there is a connection a message box pops up and says so. If not there is supposed to be a message box indicating there is no connection. Instead I get the error:
Run Time Error '-2147467259 (80004005)':
[DBNETLIB][ConnectionOpen (Connect()).]Specified SQL Server Not Found
Which is not what I am wanting it to do, is it something in my coding or is there no way to get this to work?
Public Sub AutoExec()
Dim cnn As ADODB.Connection
Dim localrst As New ADODB.Recordset
Dim remoterst As New ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "Provider=SQLOLEDB; Data Source=DB; Initial Catalog=HRLearnDev;" _
& "User Id=ID; Password=PW;"
If cnn.State = adStateOpen Then
MsgBox ("You have an established connection with the L&TD SQL Server Database.")
Else
MsgBox ("Cannot connect to remote server. Data will be stored locally to CDData Table until application is opened again.")
End If
cnn.Close
End Sub
In situations like these, you typically want to use an On Error GoTo construct - then send the code to your error handler if an error occurs (you can test to make sure the error number is what you expect with Err.Num).
However, in your case it may be even easier to use On Error Resume Next. This tells the interpreter "If an error occurs, go to the next line. I will figure out what went wrong and deal with it."
You usually do this when you have a single function call that either produces an error or a sensible value. I often do something like this:
On Error Resume Next
returnValue = -1
returnValue = functionThatReturnsPositiveValue()
If returnValue < 0 Then
MsgBox "oops - the function failed!"
Else
' <<<< do whatever needs doing >>>>
End If
In your case that's almost exactly what you would do. Complete example:
Public Sub AutoExec()
Dim cnn As ADODB.Connection
Dim localrst As New ADODB.Recordset
Dim remoterst As New ADODB.Recordset
On Error Resume Next ' <<<<<< add this line so an error doesn't stop the code
Set cnn = New ADODB.Connection
cnn.State = 0 ' <<<<< not sure if you need something like this, or if the New command
already set it to some sensible value other than "adStateOpen"
cnn.Open "Provider=SQLOLEDB; Data Source=DB; Initial Catalog=HRLearnDev;" _
& "User Id=ID; Password=PW;"
If cnn.State = adStateOpen Then ' <<<<<< this will only be true if no error occurred
MsgBox ("You have an established connection with the L&TD SQL Server Database.")
Else
MsgBox ("Cannot connect to remote server. Data will be stored locally to CDData Table until application is opened again.")
End If
On Error GoTo 0 ' <<<<<<<< turn off error handling - we have passed the "tricky" spot.
' <<<<<< lots more code goes here >>>>>>
If cnn.State = adStateOpen Then cnn.Close ' <<<<<<<< only close connection if it was open!!
End Sub

How do I make an ADO connection timeout sooner if the server doesnt exist?

I have been tasked w/ supporting an old VB6 app. (yay me) I am having trouble with the ADO connection timeout property. The method below works fine if the server exists, but if the server does not exist or network connections havent started up for the machine it will take a full 30 seconds to timeout even with the intTimeout set to 1.
Is there a way for ADO to fail to connect sooner?
Is this even possible?
Thanks!
Public Sub GetConnectionObject(ByRef oCn As ADODB.Connection, strServer As String, strInitialCatalog As String, Optional intTimeout = 10)
Dim strConnectionString As String
strConnectionString = "Data Source=[SERVER];Provider=SQLOLEDB.1;User ID=ScanReq1;Password=ScanR3Q;Initial Catalog=[INITIALCATALOG];ConnectionTimeout=" & intTimeout & ";"
strConnectionString = Replace(strConnectionString, "[SERVER]", strServer)
strConnectionString = Replace(strConnectionString, "[INITIALCATALOG]", strInitialCatalog)
Set oCn = New ADODB.Connection
oCn.CursorLocation = adUseClient
oCn.ConnectionString = strConnectionString
oCn.CommandTimeout = intTimeout
oCn.ConnectionTimeout = intTimeout
oCn.Open
End Sub
The ConnectionTimeout kicks in after the TCP connection is made. If the server can't be found, this value is controlled by the Windows TCP subsystem.
If this really is an issue for you, I'd try to ping the box first (there are plenty examples of pinging via VB6 on the net).
I've also hit this one. An alternative to setting ConnectionTimeout could be to make the Open call asynchronous, then handle the timeout in your own code. Quick and dirty example below (note: this is in VBA, but should be easily ported to VB6):
Dim conn As New ADODB.Connection
Dim time As Single, timeOut As Single
conn.ConnectionString = "your connection string here"
conn.Open Options:=adAsyncConnect ' value is 16
timeOut = 5
time = Timer()
Do Until Timer() - time > timeOut Or conn.State = adStateOpen
DoEvents
Loop
If conn.State <> adStateOpen Then 'value is 1
'timed out
Else
'successful
End If
To do it "properly", there is a ConnectionComplete event which you could handle.