phendrena
05-05-2009, 02:17 AM
Hi,
I currently use the following code to transfer data from an excel userform into access :
Private Sub ADOCanxData()
' the Microsoft ActiveX Data Objects 2.x Library
Dim DBFullName As String
Dim Cnct As String, Src As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim col As Integer, row As Integer, s As String
On Error GoTo ErrHandler
' Database information - *** Set MDB path and name here
DBFullName = "C:\Database.mdb"
' Open the connection
Set Connection = New ADODB.Connection
Cnct = "Provider=Microsoft.Jet.OLEDB.4.0; "
Cnct = Cnct & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Cnct
' Create RecordSet
Set Recordset = New ADODB.Recordset
' Next lines critical to work in QPro properly.
' It does hurt to use them in Excel though.
Recordset.CursorType = adOpenKeyset
Recordset.LockType = adLockOptimistic
With Recordset
' Filter - *** And sets table name
Src = "SELECT * FROM CancellationData "
'Src = Src & "and CategoryID = 30"
Recordset.Open Source:=Src, ActiveConnection:=Connection
' Cells.Clear 'Used in Excel to clear a sheet
' Write the field names
'For Col = 0 To .Fields.Count - 1
'Range("A1").Offset(0, Col).Value = Recordset.Fields(Col).Name 'Excel method
'Next
'If .RecordCount < 1 Then GoTo EndNow 'Query found no matching records
' Write the recordset by Excel method
'Range("A1").Offset(1, 0).CopyFromRecordset Recordset
'Add a new record (not pushed to the database until Update)
'MsgBox CStr(.RecordCount), vbInformation, "#Records"
' Adding a new record
.AddNew
.Fields("Date_of_Call") = Date 'Use most current date
Recordset("Time_of_Call") = Time 'Use the most current time
Recordset("Team_Leader").Value = cboTLName.Value
Recordset("Customer_Manager") = txtCMName.Value
Recordset("Cancellation_Type") = cboCanxType.Value
Recordset("Eligible") = txtEligible10.Value
Recordset("Saved") = txtSaved10.Value
Recordset("Original_Premium") = txtOPrem.Value
Recordset("Discount_Given") = txtDiscount.Value
Recordset("Cancellation_Type") = cboCanxType.Value
Recordset("Issued_Premium") = txtIPrem.Value
Recordset("Empowerment") = cboEmpower.Value
Recordset("Scheme") = cboScheme.Value
Recordset("Policy_Number") = txtPolNo.Value
Recordset("Competitor") = cboComp.Value
Recordset("Reason_For_Not_Saving") = cboReason.Value
Recordset("Additional_Comments") = txtComments.Value
Recordset("Migrated_Policy") = txtMig10.Value
Recordset("Migration_Previous_Premium") = txtPreviousPrem.Value
Recordset("Migration_Adjusted_Premium") = txtAdjPremium.Value
Recordset("Migration_AIS_Original") = txtAISPrem.Value
Recordset("Migration_AIS_Issued") = txtAISIssPrem.Value
' Push the new record to the Access Database. Until now, the data was disconnected.
.Update
' MsgBox CStr(.RecordCount), vbInformation, "#Records"
End With
ErrorExit:
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
Exit Sub
ErrHandler:
Dim errmsg As String
Call errTrap
errmsg = "An error has occured." & vbNewLine
errmsg = errmsg & "A report has automatically been submitted to the program administrator." & vbNewLine
errmsg = errmsg & "Due to this error the data will not have been recorded."
MsgBox errmsg
End SubI now need to password protect the database. How do I modify the above to include password/logon details when using a database password?
Thanks,
I currently use the following code to transfer data from an excel userform into access :
Private Sub ADOCanxData()
' the Microsoft ActiveX Data Objects 2.x Library
Dim DBFullName As String
Dim Cnct As String, Src As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim col As Integer, row As Integer, s As String
On Error GoTo ErrHandler
' Database information - *** Set MDB path and name here
DBFullName = "C:\Database.mdb"
' Open the connection
Set Connection = New ADODB.Connection
Cnct = "Provider=Microsoft.Jet.OLEDB.4.0; "
Cnct = Cnct & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Cnct
' Create RecordSet
Set Recordset = New ADODB.Recordset
' Next lines critical to work in QPro properly.
' It does hurt to use them in Excel though.
Recordset.CursorType = adOpenKeyset
Recordset.LockType = adLockOptimistic
With Recordset
' Filter - *** And sets table name
Src = "SELECT * FROM CancellationData "
'Src = Src & "and CategoryID = 30"
Recordset.Open Source:=Src, ActiveConnection:=Connection
' Cells.Clear 'Used in Excel to clear a sheet
' Write the field names
'For Col = 0 To .Fields.Count - 1
'Range("A1").Offset(0, Col).Value = Recordset.Fields(Col).Name 'Excel method
'Next
'If .RecordCount < 1 Then GoTo EndNow 'Query found no matching records
' Write the recordset by Excel method
'Range("A1").Offset(1, 0).CopyFromRecordset Recordset
'Add a new record (not pushed to the database until Update)
'MsgBox CStr(.RecordCount), vbInformation, "#Records"
' Adding a new record
.AddNew
.Fields("Date_of_Call") = Date 'Use most current date
Recordset("Time_of_Call") = Time 'Use the most current time
Recordset("Team_Leader").Value = cboTLName.Value
Recordset("Customer_Manager") = txtCMName.Value
Recordset("Cancellation_Type") = cboCanxType.Value
Recordset("Eligible") = txtEligible10.Value
Recordset("Saved") = txtSaved10.Value
Recordset("Original_Premium") = txtOPrem.Value
Recordset("Discount_Given") = txtDiscount.Value
Recordset("Cancellation_Type") = cboCanxType.Value
Recordset("Issued_Premium") = txtIPrem.Value
Recordset("Empowerment") = cboEmpower.Value
Recordset("Scheme") = cboScheme.Value
Recordset("Policy_Number") = txtPolNo.Value
Recordset("Competitor") = cboComp.Value
Recordset("Reason_For_Not_Saving") = cboReason.Value
Recordset("Additional_Comments") = txtComments.Value
Recordset("Migrated_Policy") = txtMig10.Value
Recordset("Migration_Previous_Premium") = txtPreviousPrem.Value
Recordset("Migration_Adjusted_Premium") = txtAdjPremium.Value
Recordset("Migration_AIS_Original") = txtAISPrem.Value
Recordset("Migration_AIS_Issued") = txtAISIssPrem.Value
' Push the new record to the Access Database. Until now, the data was disconnected.
.Update
' MsgBox CStr(.RecordCount), vbInformation, "#Records"
End With
ErrorExit:
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
Exit Sub
ErrHandler:
Dim errmsg As String
Call errTrap
errmsg = "An error has occured." & vbNewLine
errmsg = errmsg & "A report has automatically been submitted to the program administrator." & vbNewLine
errmsg = errmsg & "Due to this error the data will not have been recorded."
MsgBox errmsg
End SubI now need to password protect the database. How do I modify the above to include password/logon details when using a database password?
Thanks,