Old code SQLDMO 1

[Bluejay07]

Hello,

I have been given the task of trying to update an old program in VB6 that uses SQLDMO.
The problem is VB6 is trying to connect with SQL Server 2014 (or 2016) and SQLDMO isn't supported.
When it tries to connect, the following error appears:

-2147024891;[SQL-DMO]Service Control Error: Access is denied.

I haven't worked with VB6 in a long time and I'm pretty rusty.

How can I update the following code to work?

'// Select a server.
   Dim l_sngTime As Single, l_sngPauseTime As Single
   Dim objDatabases As SQLDMO.Database
   Dim objServer As SQLDMO.SQLServer
     On Error GoTo ERR_Handler
     frmSetup.MousePointer = vbHourglass
   DoEvents
      '// Determine the list of servers on the target.
   Set objDatabases = New SQLDMO.Database
   Set objServer = New SQLDMO.SQLServer
      objServer.Name = Trim$(cboServers.Text)
*** ERRORS ON NEXT LINE ****
   If objServer.Status = SQLDMOSvc_Stopped Then
      objServer.Start True, Trim$(cboServers.Text), "", ""
      DoEvents
      l_sngTime = Timer
      l_sngPauseTime = (60 * 3)
      Do
         If Timer > l_sngTime + l_sngPauseTime Then Exit Do
      Loop Until objServer.Status = SQLDMOSvc_Running
   Else
      objServer.LoginSecure = True
      objServer.Connect Trim$(cboServers.Text)
   End If
   
   For Each objDatabases In objServer.Databases
      If Left$(objDatabases.Name, 2) = "qm" Then
         lstSQLDBs.AddItem objDatabases.Name
      End If
   Next

Thanks.

If at first you don't succeed, then sky diving wasn't meant for you!

 

[gmmastros]

I have not been a fan of sqldmo for about 10 years now. I haven't found a situation where you can't do the same thing another way.

It appears as though this block of code is doing 2 things.

1. If the sql server service is stopped, start it.
2. get a list of databases on the server that start with qm.

I haven't played around with services too much, but I'm sure there's code here and elsewhere that shows how to start a service with VB6 code.

To get a list of databases that start with qm, I would use OLE DB to query the server for the list of databases. The trick with this is to set the name of the database to "master" in your connection string.

The query to get the list of databases is...

Select Name
From   sys.databases
where  name like 'qm%'
       and state = 0
Order BY Name

P.S. The where clause condition for "state = 0" is so that you don't return a databases that is set to offline. Put another way, this should only show a list of databases that start with qm and are available to be connected to.

-George
Microsoft SQL Server MVP
My Blogs
SQLCop
twitter
"The great things about standards is that there are so many to choose from." - Fortune Cookie Wisdom

 

[Bluejay07]

Hi George,

Thanks for the reply.
What would the best way to handle the return values.
Would I associate your query in a recordset or is there a better option?

I'm sort of working backwards.
The step before this, a combo box is filled with server names.
This is the same list you would see in the sql server list when adding a system dsn odbc entry.

   Dim i As Integer
   Dim objServers As SQLDMO.NameList
   Dim objSQLApp As SQLDMO.Application
   
   On Error GoTo ERR_Handler
   
   '// Determine the list of servers on the target.
   Set objSQLApp = New SQLDMO.Application
   Set objServers = objSQLApp.ListAvailableSQLServers()
   
   If objServers.Count <= 0 Then
      m_strServer = objServers.Item(0)
   Else
      cboServers.Clear
      For i = 1 To objServers.Count
         cboServers.AddItem objServers.Item(i)
      Next i
   End If

The servers are most likely not on the same system and may not be the same version.
How would you suggest changing your query so that it selects the qm database from the desired server?
Are the functions I can use?

Any suggestions on what I can search for to learn more on the approach you described and eliminating sqldmo?

Thanks.


If at first you don't succeed, then sky diving wasn't meant for you!

 

[gmmastros]

I'm a fan of ADO and OLEDB. To use it...

1. You need to add a reference to your project for "Microsoft ActiveX Data Objects 2.x Library" by clicking Project -> References, and then selecting it from the list.

2. I have a generic GetRecordset function and another for ExecuteSQL. The difference between the two is that GetRecordset returns a recordset and ExecuteSQL does not. Execute SQL would be used for things like Insert, Update, and Delete. GetRecordset is used for select statements.

Public Function GetRecordset(ByVal SQL As String) As ADODB.Recordset

    Dim DB As ADODB.Connection
    Dim RS As ADODB.Recordset
    
    Set DB = CreateObject("ADODB.Connection")
    DB.ConnectionString = globalConnectionString
    DB.CursorLocation = adUseClient
    DB.CommandTimeout = 0
    Call DB.Open
    
    Set RS = CreateObject("ADODB.Recordset")
    RS.CursorLocation = adUseClient
    Call RS.Open(SQL, DB, adOpenForwardOnly, adLockReadOnly)
    Set RS.ActiveConnection = Nothing
    Set GetRecordset = RS
    Set RS = Nothing
    DB.Close
    Set DB = Nothing
    
End Function

Public Sub ExecuteSQL(ByVal SQL As String)

    Dim DB As ADODB.Connection
    Set DB = CreateObject("ADODB.Connection")
    DB.ConnectionString = globalConnectionString
    DB.CursorLocation = adUseClient
    DB.CommandTimeout = 0
    Call DB.Open
    Call DB.Execute(SQL)
    DB.Close
    Set DB = Nothing
    
End Sub

3. You would use the GetRecordset function like this...

Private Sub GetDatabaseList()

    Dim RS As ADODB.Recordset
    Dim SQL As String

    SQL = "Select Name From sys.databases where name like 'qm%' and state = 0 Order BY Name"
    Set RS = GetRecordset(SQL)
    If RS Is Nothing Then 
        Exit Sub
    End If

    If RS.RecordCount = 0 Then
        Set RS = Nothing
        Exit Sub
    End If

    Do While Not RS.Eof
        Debug.Print RS.Fields.Item("Name").Value
        RS.MoveNext
    Loop
    RS.Close
    Set RS = Nothing

End Sub

To get a list of servers, I use the following code. I did not create this code. I found it on the internet years ago, and don't remember where.

Put the following code in a module.

Option Explicit
Private Const MODULE_NAME As String = "mdEnumServers"

Public Type typServer
    Name As String
    Clustered As String
    Version As String
End Type

Public Servers() As typServer
Public ServerCount As Long

'--- retvals
Private Const SQL_ERROR                     As Integer = -1
Private Const SQL_INVALID_HANDLE            As Integer = -2
Private Const SQL_NEED_DATA                 As Integer = 99
Private Const SQL_NO_DATA_FOUND             As Integer = 100
Private Const SQL_SUCCESS                   As Integer = 0
Private Const SQL_SUCCESS_WITH_INFO         As Integer = 1
'--- for SQLSetConnectOption
Private Const SQL_ATTR_LOGIN_TIMEOUT        As Long = 103
Private Const SQL_ATTR_CONNECTION_TIMEOUT   As Long = 113
Private Const SQL_ATTR_QUERY_TIMEOUT        As Long = 0
Private Const SQL_COPT_SS_BASE              As Long = 1200
Private Const SQL_COPT_SS_INTEGRATED_SECURITY As Long = (SQL_COPT_SS_BASE + 3) ' Force integrated security on login
Private Const SQL_COPT_SS_BASE_EX           As Long = 1240
Private Const SQL_COPT_SS_BROWSE_CONNECT    As Long = (SQL_COPT_SS_BASE_EX + 1) ' Browse connect mode of operation
Private Const SQL_COPT_SS_BROWSE_SERVER     As Long = (SQL_COPT_SS_BASE_EX + 2) ' Single Server browse request.
Private Const SQL_COPT_SS_BROWSE_CACHE_DATA As Long = (SQL_COPT_SS_BASE_EX + 5) ' Determines if we should cache browse info. Used when returned buffer is greater then ODBC limit (32K)

'--- param type
Private Const SQL_IS_UINTEGER               As Integer = (-5)
Private Const SQL_IS_INTEGER                As Integer = (-6)
'--- for SQL_COPT_SS_INTEGRATED_SECURITY
Private Const SQL_IS_OFF                    As Long = 0
Private Const SQL_IS_ON                     As Long = 1
'--- for SQL_COPT_SS_BROWSE_CACHE_DATA
Private Const SQL_CACHE_DATA_NO             As Long = 0
Private Const SQL_CACHE_DATA_YES            As Long = 1
'--- for SQLSetEnvAttr
Private Const SQL_ATTR_ODBC_VERSION         As Long = 200
Private Const SQL_OV_ODBC3                  As Long = 3

' QL_COPT_SS_BROWSE_CONNECT
Private Const SQL_MORE_INFO_NO              As Long = 0
Private Const SQL_MORE_INFO_YES             As Long = 1


Private Declare Function SQLAllocEnv Lib "odbc32.dll" (phEnv As Long) As Integer
Private Declare Function SQLAllocConnect Lib "odbc32.dll" (ByVal hEnv As Long, phDbc As Long) As Integer
Private Declare Function SQLSetEnvAttr Lib "odbc32" (ByVal EnvironmentHandle As Long, ByVal Attrib As Long, Value As Any, ByVal StringLength As Long) As Integer
Private Declare Function SQLBrowseConnect Lib "odbc32.dll" (ByVal hDbc As Long, ByVal szConnStrIn As String, ByVal cbConnStrIn As Integer, ByVal szConnStrOut As String, ByVal cbConnStrOutMax As Integer, pcbConnStrOut As Integer) As Integer
Private Declare Function SQLDisconnect Lib "odbc32.dll" (ByVal hDbc As Long) As Integer
Private Declare Function SQLFreeConnect Lib "odbc32.dll" (ByVal hDbc As Long) As Integer
Private Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal hEnv As Long) As Integer
Private Declare Function SQLSetConnectOption Lib "odbc32.dll" (ByVal ConnectionHandle As Long, ByVal Option_ As Integer, ByVal Value As Long) As Integer
Private Declare Function SQLGetConnectOption Lib "odbc32.dll" (ByVal ConnectionHandle As Long, ByVal Option_ As Integer, Value As Long) As Integer
Private Declare Function SQLError Lib "odbc32.dll" (ByVal EnvironmentHandle As Long, ByVal ConnectionHandle As Long, ByVal StatementHandle As Long, ByVal Sqlstate As String, NativeError As Long, ByVal MessageText As String, ByVal BufferLength As Integer, TextLength As Integer) As Integer
'--- ODBC 3.0
Private Declare Function SQLSetConnectAttr Lib "odbc32" Alias "SQLSetConnectAttrA" (ByVal ConnectionHandle As Long, ByVal Attrib As Long, Value As Any, ByVal StringLength As Long) As Integer
Private Declare Function SQLGetConnectAttr Lib "odbc32" Alias "SQLGetConnectAttrA" (ByVal ConnectionHandle As Long, ByVal Attrib As Long, Value As Any, ByVal BufferLength As Long, StringLength As Long) As Integer

Private Const STR_NO_USER_DBS           As String = "<No user databases>"

Public Sub EnumSqlServers()
    Const FUNC_NAME     As String = "EnumSqlServers"
    Const CONN_STR      As String = "DRIVER={SQL Server}"
    Const PREFIX        As String = "Server={"
    Const SUFFIX        As String = "}"
    
    On Error GoTo EH
    
    Dim Output() As String
    Dim i As Long
    Dim j As Long
    Dim arTemp() As String
    
    Output = pvBrowseConnect(CONN_STR, PREFIX, SUFFIX)
    
    ReDim Servers(UBound(Output))
    For i = LBound(Output) To UBound(Output)
        If InStr(Output(i), ";") > 0 Then
            arTemp = Split(Output(i), ";")
            For j = LBound(arTemp) To UBound(arTemp)
                If InStr(arTemp(j), ":") = 0 Then
                    Servers(i).Name = arTemp(j)
                Else
                    If Split(arTemp(j), ":")(0) = "Clustered" Then
                        Servers(i).Clustered = Split(arTemp(j), ":")(1)
                    ElseIf Split(arTemp(j), ":")(0) = "Version" Then
                        Servers(i).Version = Split(arTemp(j), ":")(1)
                    End If
                End If
            Next
        Else
            Servers(i).Name = Output(i)
        End If
    Next
    
    ServerCount = UBound(Servers) + 1
    
    Exit Sub
EH:
    
End Sub


Public Function EnumSqlDbs(sServer As String, Optional sUser As String, Optional sPass As String) As String()
    Const FUNC_NAME     As String = "EnumSqlDbs"
    Const CONN_STR      As String = "DRIVER={SQL Server};SERVER=%1;UID=%2;PWD=%3;"
    Const PREFIX        As String = "Database={"
    Const SUFFIX        As String = "}"
    Dim sConnStr        As String
    
    On Error GoTo EH
    EnumSqlDbs = pvBrowseConnect(Replace(Replace(Replace(CONN_STR, "%1", sServer), "%2", sUser), "%3", sPass), PREFIX, SUFFIX, Len(sUser) = 0)
    Exit Function
EH:
    
End Function


Private Function pvBrowseConnect(sConnStr As String, sPrefix As String, sSuffix As String, Optional ByVal bItegrated As Boolean) As String()
    
    Const FUNC_NAME     As String = "pvBrowseConnect"
    Dim rc              As Integer
    Dim hEnv            As Long
    Dim hDbc            As Long
    Dim sBuffer         As String
    Dim nReqBufSize     As Integer
    Dim lStart          As Long
    Dim lEnd            As Long
    Dim dwSec           As Long
    Dim lStrLen         As Long

    On Error GoTo EH
    '--- init environment
    rc = SQLAllocEnv(hEnv)
    rc = SQLSetEnvAttr(hEnv, SQL_ATTR_ODBC_VERSION, ByVal SQL_OV_ODBC3, SQL_IS_INTEGER)
    '--- init conn
    rc = SQLAllocConnect(hEnv, hDbc)
    '--- timeouts to ~5 secs
    rc = SQLSetConnectOption(hDbc, SQL_ATTR_CONNECTION_TIMEOUT, 1500)
    rc = SQLSetConnectOption(hDbc, SQL_ATTR_LOGIN_TIMEOUT, 1500)
    '--- integrated security
    If bItegrated Then
        rc = SQLSetConnectOption(hDbc, SQL_COPT_SS_INTEGRATED_SECURITY, SQL_IS_ON)
    End If
    rc = SQLSetConnectOption(hDbc, SQL_COPT_SS_INTEGRATED_SECURITY, SQL_IS_ON)
    '--- improve performance
    'rc = SQLSetConnectOption(hDbc, SQL_COPT_SS_BROWSE_CACHE_DATA, SQL_CACHE_DATA_YES)
    rc = SQLSetConnectOption(hDbc, SQL_COPT_SS_BROWSE_CONNECT, SQL_MORE_INFO_YES)
    
    '--- initial buffer size
    nReqBufSize = 4000
    '--- repeat getting info until buffer gets large enough
'    Do
'        sBuffer = String(nReqBufSize + 1, 0)
'        rc = SQLBrowseConnect(hDbc, sConnStr, Len(sConnStr), sBuffer, Len(sBuffer), nReqBufSize)
'    Loop While rc = SQL_NEED_DATA And nReqBufSize >= Len(sBuffer)
    
    Do
        sBuffer = String(nReqBufSize + 1, 0)
        rc = SQLBrowseConnect(hDbc, sConnStr, Len(sConnStr), sBuffer, Len(sBuffer), nReqBufSize)
    Loop While rc = SQL_NEED_DATA And nReqBufSize >= Len(sBuffer)
    
    '--- if ok -> parse buffer
    If rc = SQL_SUCCESS Or rc = SQL_NEED_DATA Then
        '--- find prefix
        lStart = InStr(1, sBuffer, sPrefix)
        If lStart > 0 Then
            lStart = lStart + Len(sPrefix)
            '--- find suffix
            lEnd = InStr(lStart, sBuffer, sSuffix)
            If lEnd > 0 Then
                lEnd = lEnd - Len(sSuffix) + 1
                '--- success
                pvBrowseConnect = Split(Mid(sBuffer, lStart, lEnd - lStart), ",")
            End If
        Else
            Err.Raise vbObjectError, "ODBC", pvGetError(rc, hEnv, hDbc, 0)
        End If
    End If
    '--- disconnect
    rc = SQLDisconnect(hDbc)
    '--- free handles
    rc = SQLFreeConnect(hDbc)
    rc = SQLFreeEnv(hEnv)
    '--- on failure -> return Array(0 To -1)
    If Not IsArray(pvBrowseConnect) Then
        pvBrowseConnect = Split("")
    End If
    Exit Function
EH:
    
End Function


Private Function pvGetError(ByVal rc As Long, ByVal hEnv As Long, ByVal hDbc As Long, ByVal hStm As Long) As String
    Const FUNC_NAME     As String = "pvGetError"
    Dim sSqlState       As String * 5
    Dim lNativeError    As Long
    Dim sMsg            As String * 512
    Dim nTextLength     As Integer
    
    On Error GoTo EH
    SQLError hEnv, hDbc, hStm, sSqlState, lNativeError, sMsg, Len(sMsg), nTextLength
    pvGetError = "ODBC Result: 0x" & Hex(rc) & vbCrLf & vbCrLf & Left(sMsg, nTextLength)
    Exit Function
EH:
    
End Function

Then, in a form, you can use it like this...

    Dim i As Long
    
    EnumSqlServers
    
    For i = LBound(Servers) To UBound(Servers)
        cboServers.AddItem Servers(i).Name
    Next

-George
Microsoft SQL Server MVP
My Blogs
SQLCop
twitter
"The great things about standards is that there are so many to choose from." - Fortune Cookie Wisdom

 

[Bluejay07]

Hi George,

Thank you so much for the information.
I think this will be so helpful in transitioning away from sqldmo.

Thanks again for taking the time to provide the code samples as well.



If at first you don't succeed, then sky diving wasn't meant for you!

 

[Bluejay07]

Hi George,

In the getRecordset code, you have a function called globalConnectionString.
Would you be able to provide the code for that?

I tried

DB.ConnectionString = "Provider=MSDASQL;DSN=" & cboServers.Text

and

DB.ConnectionString = "Server=" & cboServers.Text & vbNullChar & _
 "Trusted_Connection=Yes" & vbNullChar

However it send the following error:

Data source name not found and no default driver specified

I'm obviously missing something to complete the connection string.

Thank you.

If at first you don't succeed, then sky diving wasn't meant for you!

 

[Bluejay07]

I should also point out that I can make an ODBC connection using SQL Server Native Client 10.0.

I also tried:

DB.ConnectionString = "Driver={SQL Server Native Client 10.0};Server=" & cboServers.Text

and it errors with

Provider cannot be found. It may not be properly installed.

Keep in mind that I'll be connecting to SQL Server 2014 or 2016.

If at first you don't succeed, then sky diving wasn't meant for you!

 

[Bluejay07]

I was able to get it working by hard coding the sa user id and password.

DB.ConnectionString = "Provider=MSDASQL;Driver={SQL Server};Server=" & cboServers.Text & _
 ";UID=sa;PWD=123456"

It also worked by prompting for the user name and password

'   DB.Properties("Prompt") = adPromptAlways
'   DB.ConnectionString = "Provider=MSDASQL;Driver={SQL Server};Server=" & cboServers.Text

After prompting, is there any way to access the entered user name and password from the prompt form to save for future accesses?

Thanks.

If at first you don't succeed, then sky diving wasn't meant for you!

 

[gmmastros]

Sorry. I was on vacation last week. Here is the function I use to set the global connection string.

Public Sub SaveConnectionString(ByVal Server As String, ByVal DatabaseName As String, ByVal UserName As String, ByVal Password As String)

    Dim cConnectString As String
    
    cConnectString = "Provider=SQLOLEDB.1;"
    cConnectString = cConnectString & "Persist Security Info=False;"
    cConnectString = cConnectString & "Application Name=[!]YourProductNameHere[/!]-" & Environ("USERNAME") & ";"
    cConnectString = cConnectString & "User ID=" & UserName & ";"
    cConnectString = cConnectString & "Initial Catalog=" & DatabaseName & ";"
    cConnectString = cConnectString & "Data Source=" & Server & ";"
    cConnectString = cConnectString & "PWD=" & Password
    
    globalConnectionString = cConnectString
    
End Sub

Notice the part where I set the Application Name. This part is optional in your connection string, but it is extremely useful when you are using SQL Profiler, especially when you have multiple users and you are trying to capture the queries for a single user.

-George
Microsoft SQL Server MVP
My Blogs
SQLCop
twitter
"The great things about standards is that there are so many to choose from." - Fortune Cookie Wisdom

 

[Bluejay07]

Hi George,

I'm sure it was a well deserved vacation.
Thanks for the remaining code you provided.



If at first you don't succeed, then sky diving wasn't meant for you!