Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 604
  • Last Modified:

Linked ODBC tables are read only when connecting using non-DSN through VBA code

Hi all,
I'm using some code to re-link in some SQL Server tables using an ODBC connection, without a DSN, into MS Access 2003 SP2.  It works fine, but the tables are re-linking as Read Only.  Any ideas on getting them to be Read/write???

Thanks,
Dave

FYI - I did not write the code.  So if it looks like crap, it's not my fault...  LOL

Public Sub Refresher(DbType As String, Optional confirmationMsg As Boolean)
 
    Dim Backend As DAO.Database, FrontEnd As DAO.Database, tdf As DAO.TableDef, strConnect As String, strServer As String
    Dim strDatabase As String, intCounter As Integer, dbOdbc As DAO.Database ' Fixed DAO
    Dim sql As String, rst As DAO.Recordset, wk As DAO.Workspace, Sourcepath As String
    Dim Idx As Index, fldIndex As Field, userName, userPass, strTable As String
    
    'display message
    DoCmd.OpenForm "Please_Wait", acNormal, , , , , "Please wait while linked server table connections are refreshed"
    DoEvents
    DoEvents
    DoEvents
    
    Sourcepath = Replace(Application.CurrentDb.Properties(0), "Front", "Back")
    
    'define connection with frontend.mdb (currentdb) and backend.mdb
    Set FrontEnd = CurrentDb
    'Set Backend = DBEngine.Workspaces(0).OpenDatabase(Sourcepath)
    
    'SQL login parameters
    userName = "rostersystem"
    userPass = "rosterSys"
    
    If DbType = "SQLServer" Then ' connect to SQL
 
        sql = "Select * from local_tblTableLinks where Server <> 'Microsoft Access'"
        Set rst = FrontEnd.OpenRecordset(sql, dbOpenDynaset)        
        
        Do While rst.EOF = False
            
            'loop through tablelinks dictionary to get connection parameters for each table
            strServer = rst.Fields("Server")
            strDatabase = rst.Fields("Database")
            strTable = rst.Fields("tableName")
            strConnect = "ODBC;DRIVER={SQL Server};SERVER=" & strServer & ";DATABASE=" & strDatabase & ";UID=" & userName & ";PWD=" & userPass & ";TABLE=" & strTable
 
            'update message
            On Error GoTo errShowForm
            Forms![please_wait]![subMessage].Caption = strTable
            DoEvents
            DoEvents
            DoEvents
            On Error GoTo 0
            
            On Error GoTo errConnection
            'establish connection
            Set tdf = FrontEnd.TableDefs(rst.Fields("link_table"))
            tdf.Connect = strConnect
            tdf.RefreshLink
            On Error GoTo 0
            
            'update table with refresh date
            rst.Edit
            rst.Fields("LastRefresh") = Now()
            rst.UPDATE
            rst.MoveNext
            CurrentDb.TableDefs.Refresh
    
        Loop
    
    Else   'refresh Access tables
 
        sql = "Select * from local_tblTableLinks where Server ='Microsoft Access'"
        
            
        Set rst = FrontEnd.OpenRecordset(sql, dbOpenDynaset)
        
        Do While rst.EOF = False
        
            'update message
            On Error GoTo errShowForm
            Forms![please_wait]![subMessage].Caption = strTable
            DoEvents
            DoEvents
            DoEvents
            On Error GoTo 0
        
            'establish connection
            Set tdf = FrontEnd.TableDefs(rst.Fields("link_table"))
            tdf.Connect = ";DATABASE=" & Sourcepath
            tdf.RefreshLink
            
            'update table with refresh date
            rst.Edit
            rst.Fields("LastRefresh") = Now()
            rst.UPDATE
            rst.MoveNext
        
            FrontEnd.TableDefs.Refresh
        
        Loop
 
    End If
    
    
            'update message
            On Error GoTo errShowForm
            Forms![please_wait]![subMessage].Caption = "Complete"
            DoEvents
            DoEvents
            DoEvents
            On Error GoTo 0
    
    
    
    If confirmationMsg = True Then
        'show confirmation
        MsgBox "Server table connections are refreshed", , "Server connections"
    End If
    
    GoTo exitSub
        
errShowForm:        'if message window is not already displayed then display it
    DoCmd.OpenForm "Please_Wait", acNormal, , , , , "Please wait while linked server table connections are refreshed"
    Resume Next
    
errConnection:      'error in odbc connection
 
    MsgBox "Error " & Err & " with " & strTable & ": " & Err.Description, , "Error"
    GoTo exitSub
        
exitSub:
    'refresh tables
    FrontEnd.TableDefs.Refresh
        
    'close message window
    On Error Resume Next
    DoCmd.Close acForm, "Please_Wait", acSaveNo
    On Error GoTo 0
    
    'close objects
    Set tdf = Nothing
    rst.Close
    Set rst = Nothing
    Set Backend = Nothing
    Set dbOdbc = Nothing
End Sub

Open in new window

0
Cristal638
Asked:
Cristal638
  • 2
  • 2
  • 2
2 Solutions
 
Jim P.Commented:
Do all tables have a primary key?

If not, when relinking you need to select the "index" fields that are unique.
0
 
MikeTooleCommented:
Not sure what your actual problem is, but the attached code has been working for some years in production.
jimpen is right about the Primary Keys - Access will automatically create a local index if it finds a PK, but you have to do it yourself for any table/view that hasn't got one. There are a couple of Views in the snippet where I do this.

The code uses a utility class CValueList,  which I've also included. It's an easy way to parse lists like connection strings and add/change/delete values in them. It's used here to compare the old value of Server to the value supplied in strServer to see if a refresh is needed.
   Dim vlConnect as New CValueList
     For Each tdf In db.TableDefs
        intTableIndex = intTableIndex + 1
        If (tdf.Attributes And dbAttachedODBC) <> 0 _
            And (Left(tdf.Name, 4) <> "~tmp") Then
            vlConnect.List = tdf.Connect
            If LCase(vlConnect.Item("Server")) <> LCase(strServer) Then
                 vlConnect.Item("Server") = strServer
                tdf.Connect = vlConnect.List
                tdf.RefreshLink
                Debug.Print tdf.Name
                ' Create pseudo indexes on views to make them updatable
                Select Case tdf.Name
                    Case "vwPAFTitle"
                        DoCmd.RunSQL "create unique index idxvwPAFTitle on vwPAFTitle(idPAFTitle);"
'                    Case "vwTitle"
'                        DoCmd.RunSQL "create unique index idxvwTitle on vwTitle(idPAFTitle, Promo_id);"
                    Case "vwTitleManager"
                        DoCmd.RunSQL "create unique index idxvwTitleManager on vwTitleManager(idPAFTitle);"
                End Select
                intLinksRefreshedCount = intLinksRefreshedCount + 1
            End If
        End If
    Next tdf
 
ValueList Class:
'local variable(s) to hold property value(s)
Private mList() As String
Private mSeparator As String 'local copy
Private mItems As Scripting.Dictionary
 
Public Property Let Separator(ByVal vData As String)
    ' Reset the list if the separator changes
    mListText = ""
    mSeparator = vData
    mSepLen = Len(mSeparator)
End Property
 
Public Property Get Separator() As String
    Separator = mSeparator
End Property
 
Public Property Let Item(ByVal Key As String, ByVal Value As String)
    Key = StrConv(Key, vbProperCase)
    If mItems.Exists(Key) Then
        mItems(Key) = Value
    Else
        mItems.Add Key, Value
    End If
End Property
 
Public Property Get Item(ByVal Key As String) As String
    Key = StrConv(Key, vbProperCase)
    Item = mItems(Key)
End Property
 
Public Property Let List(ByVal Value As String)
    Dim i As Integer, iPos As Integer, strItem As String, strName As String, strvalue As String
    Set mItems = New Scripting.Dictionary
    mList = Split(Value, mSeparator)
    For i = 0 To UBound(mList, 1)
        strItem = mList(i)
        iPos = InStr(strItem, "=")
        If iPos = 0 Then
            strName = StrConv(Trim(strItem), vbProperCase)
            strvalue = ""
        Else
            strName = StrConv(Trim(Left(strItem, iPos - 1)), vbProperCase)
            strvalue = Mid(strItem, iPos + 1)
        End If
        mItems.Add strName, strvalue
    Next i
End Property
 
Public Property Get List() As String
    Dim strList As String, obj As Object, i As Integer
    For i = 0 To mItems.Count - 1
        strList = strList & mSeparator & mItems.Keys(i)
        If Len(mItems.Items(i)) > 0 Then
            strList = strList & "=" & mItems.Items(i)
        End If
    Next i
    List = Mid(strList, 2)
End Property
 
Public Sub DeleteItem(ByVal Key As String)
    Key = StrConv(Key, vbProperCase)
    mItems.Remove Key
 
End Sub
 
Private Sub Class_Initialize()
    mSeparator = ";"
End Sub

Open in new window

0
 
Cristal638Author Commented:
Sorry for the delay...  I was on a business trip.  

Anyway, the solution that I finally went with was to add a field called "PrimaryKey" to the table that contains the relinking information.  After the table has been relinked I create the index using the values in the "PrimaryKey" field.

strPKey = rst.Fields("PrimaryKey")            'the PrimaryKey field contains comma seperated values (ie.  BusinessUnit_Id, Division_Id)

CurrentDb.Execute "CREATE INDEX PK" & tdf.Name & " ON " & tdf.Name & " (" & Trim(strPKey) & ") WITH PRIMARY"
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
MikeTooleCommented:
The solution adopted was that advised in both responses to the question. Jimpen pointed out that if there was no PK a unique index needs to be created, I supplied a code sample that did just that:
<jimpen is right about the Primary Keys - Access will automatically create a local index if it finds a PK, but you have to do it yourself for any table/view that hasn't got one. There are a couple of Views in the snippet where I do this.
...
                ' Create pseudo indexes on views to make them updatable
                Select Case tdf.Name
                    Case "vwPAFTitle"
                        DoCmd.RunSQL "create unique index idxvwPAFTitle on vwPAFTitle(idPAFTitle);"
... >
The last SQL statement does effectively the same thing as the questioner's solution:

<CurrentDb.Execute "CREATE INDEX PK" & tdf.Name & " ON " & tdf.Name & " (" & Trim(strPKey) & ") WITH PRIMARY">
0
 
Jim P.Commented:
While mine wasn't the nice solution that Mike had, it was a step in that direction.
0
 
Cristal638Author Commented:
I have no issue splitting the points as a thank you for taking the time to actually look into it.  I just didn't want to miss lead any future users as to what my actual solution was.  I'll be happy to do whatever the moderater suggests.
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 2
  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now