Option Explicit
Dim cnAccess As ADODB.Connection
Dim rsAccess As ADODB.Recordset
Dim cnMSSQL As ADODB.Connection
Dim rsMSSQL As ADODB.Recordset
Dim a As Long
Dim strDataBaseName As String
Dim strDBCursorType As String
Dim strDBLockType As String
Dim strDBOptions As String
Dim strSQLAccess As String
Dim strSQLMSSQL As String
Private Sub Command1_Click()
Dim b As Long
Me.MousePointer = 11
strDBCursorType = adOpenDynamic
strDBLockType = adLockOptimistic
strDBOptions = adCmdText
Set cnAccess = New ADODB.Connection
Set cnMSSQL = New ADODB.Connection
cnAccess.Open ConnectString("Access")
cnMSSQL.Open ConnectString("MSSQL")
With cnAccess
.CommandTimeout = 0
.CursorLocation = adUseClient
End With
With cnMSSQL
.CommandTimeout = 0
.CursorLocation = adUseClient
End With
Set rsAccess = New ADODB.Recordset 'Creates record set
Set rsMSSQL = New ADODB.Recordset 'Creates record set
strSQLAccess = "SELECT * "
strSQLAccess = strSQLAccess & "FROM Table1 "
strSQLMSSQL = "SELECT * "
strSQLMSSQL = strSQLMSSQL & "FROM DBO.Table1 "
rsAccess.Open strSQLAccess, cnAccess, strDBCursorType, strDBLockType, strDBOptions
rsMSSQL.Open strSQLMSSQL, cnMSSQL, strDBCursorType, strDBLockType, strDBOptions
If rsAccess.EOF Or rsAccess.BOF Then
GoTo ExitSub
Else
For a = 1 To rsAccess.RecordCount
rsMSSQL.AddNew
For b = 0 To rsAccess.Fields.Count - 1
rsMSSQL.Fields(b).Value = rsAccess.Fields(b).Value
Next b
rsMSSQL.Update
rsAccess.MoveNext
Next a
End If
ExitSub:
Me.MousePointer = 0
rsAccess.Close
Set rsAccess = Nothing
cnAccess.Close
Set cnAccess = Nothing
rsMSSQL.Close
Set rsMSSQL = Nothing
cnMSSQL.Close
Set cnMSSQL = Nothing
End Sub
Private Function ConnectString(strDataBaseName As String) As String
Dim strDBName As String
Dim strUserID As String
Dim strPassword As String
Select Case strDataBaseName
Case "MSSQL" 'MS SQL DB
strDBName = "Database_Name"
strUserID = "User_Name"
strPassword = "Password"
ConnectString = "Provider=SQLOLEDB;DATA SOURCE=" & _
"192.168.xxx.xxx;" & _
"Initial Catalog=" & strDBName & _
";USER ID=" & strUserID & _
";Password=" & strPassword & ";"
Case "Access" 'Access Database
strDBName = "Path of Access Database" ' i.e. C:\Database\AccessDatabase.mdb
ConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPath & _
";Jet OLEDB:Engine Type=5;"
End Select
End Function