ordendelfai
Technical User
I am using the below code to automatically connect to SQL 2000 server with Access 97, and it works great. However, my IS department is telling me that my I keep having multiple sessions open on the SQL server. I thought when I close Access, my SQL session closes too. They told me to deallocate the resources, and close the connection with VBA.
I am a novice with VBA, and the below code was lots of borrowing, tweaking, and trial and error. Unfortunately my IS department will not give me any code to accomplish what they are asking.
Is there some code I should add when the database is closed? Would really appreciate if you could help
Thx!
*******CODE*******
Public Function LinkTables()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim RST As DAO.Recordset
Dim strServer As String
Dim strDB As String
Dim strTable As String
Dim strConnect As String
Dim strMsg As String
Const acbSwitchboard = "frmSWITCHBOARD"
On Error GoTo HandleErr
'Build base Authentication strings.
strConnect = "ODBC;Driver={SQL Server};Server=WH-SQLDEVVS01;Database=SPContact;Trusted_Connection=Yes"
'Create a recordset to obtain server object names
Set db = CurrentDb()
Set RST = db.OpenRecordset("tblSQLTables", dbOpenSnapshot)
If RST.EOF Then
strMsg = "There are no tables listed to link to."
MsgBox strMsg, , "No tables"
GoTo ExitHere
End If
Forms.frmSPLASH.[LblFunction].Caption = "Relinking:"
Do Until RST.EOF
strServer = RST!SQLServer
strDB = RST!SQLDatabase
strTable = RST!SQLTable
Forms.frmSPLASH.[lblLoading].Caption = strTable
DoCmd.RepaintObject acForm, "frmSPLASH"
' Create a new TableDef object.
Set tdf = db.CreateTableDef(strTable)
' Set the Connect property to establish the link
tdf.Connect = strConnect & "Server=" & strServer & ";Database=" & strDB & ";"
tdf.SourceTableName = strTable
' Append to the database's TableDefs colelction.
db.TableDefs.Append tdf
RST.MoveNext
Loop
RST.Close
Set RST = Nothing
Set tdf = Nothing
Set db = Nothing
ExitHere:
Exit Function
HandleErr:
Select Case Err
Case Else
strMsg = Err & ": " & Err.Description
Exit Function
End Select
End Function
I am a novice with VBA, and the below code was lots of borrowing, tweaking, and trial and error. Unfortunately my IS department will not give me any code to accomplish what they are asking.
Is there some code I should add when the database is closed? Would really appreciate if you could help
Thx!
*******CODE*******
Public Function LinkTables()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim RST As DAO.Recordset
Dim strServer As String
Dim strDB As String
Dim strTable As String
Dim strConnect As String
Dim strMsg As String
Const acbSwitchboard = "frmSWITCHBOARD"
On Error GoTo HandleErr
'Build base Authentication strings.
strConnect = "ODBC;Driver={SQL Server};Server=WH-SQLDEVVS01;Database=SPContact;Trusted_Connection=Yes"
'Create a recordset to obtain server object names
Set db = CurrentDb()
Set RST = db.OpenRecordset("tblSQLTables", dbOpenSnapshot)
If RST.EOF Then
strMsg = "There are no tables listed to link to."
MsgBox strMsg, , "No tables"
GoTo ExitHere
End If
Forms.frmSPLASH.[LblFunction].Caption = "Relinking:"
Do Until RST.EOF
strServer = RST!SQLServer
strDB = RST!SQLDatabase
strTable = RST!SQLTable
Forms.frmSPLASH.[lblLoading].Caption = strTable
DoCmd.RepaintObject acForm, "frmSPLASH"
' Create a new TableDef object.
Set tdf = db.CreateTableDef(strTable)
' Set the Connect property to establish the link
tdf.Connect = strConnect & "Server=" & strServer & ";Database=" & strDB & ";"
tdf.SourceTableName = strTable
' Append to the database's TableDefs colelction.
db.TableDefs.Append tdf
RST.MoveNext
Loop
RST.Close
Set RST = Nothing
Set tdf = Nothing
Set db = Nothing
ExitHere:
Exit Function
HandleErr:
Select Case Err
Case Else
strMsg = Err & ": " & Err.Description
Exit Function
End Select
End Function
