Here is my updated code per #Parfait suggestion. It still isn't working, getting the following error:
Run-time error '3421'
Data type conversion error
On the following line: Set rec = qdef.OpenRecordset(strQry)
Option Compare Database
Private Sub Command0_Click()
Dim db As DAO.Database
Dim qdef As DAO.QueryDef
Dim rec As DAO.Recordset
Dim olApp As Object
Dim olItem As Variant
Dim strQry As String
Dim aHead(1 To 4) As String
Dim aRow(1 To 4) As String
Dim aBody() As String
Dim lCnt As Long
'Prepared Statement No Data
strQry = "PARAMETERS cboParam TEXT(255);" _
& " SELECT [Loan ID], [Prior Loan ID], [SRP Rate], [SRP Amount] " _
& " FROM emailtable " _
& " WHERE [Seller Name:Refer to As] = [cboParam]"
Set db = CurrentDb
Set qdef = db.CreateQueryDef("", strQry)
' BIND PARAMETER
qdef!cboParam = Me.Combo296
' OPEN RECORDSET
Set rec = qdef.OpenRecordset(strQry)
'Create the header row
aHead(1) = "Loan ID"
aHead(2) = "Prior Loan ID"
aHead(3) = "SRP Rate"
aHead(4) = "SRP Amount"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("[Loan ID]")
aRow(2) = rec("[Prior Loan ID]")
aRow(3) = rec("[SRP Rate]")
aRow(4) = rec("[SRP Amount]")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.Display 'To display message
.To = Me.Combo88
.cc = Me.Combo282
.Subject = "*SECURE* " & Me.Combo296 & " Refund Request (" & Me.Combo212 & " " & Me.Combo284 & ")"
.HTMLBody = "<p><font face=""calibri"" style=""font-size:11pt;"">Greetings,</p>" _
& "<p>We recently acquired loans from " & Me.Combo296 & ", some of which have paid in full and meet the criteria for early prepayment defined in the governing documents. We are requesting a refund of the SRP amount detailed on the attached list.</p>" _
& "<p>Please wire funds to the following instructions:</p>" _
& "<ul>Bank Name: My Bank</ul>" _
& "<ul>ABA: 1111111</ul>" _
& "<ul>Credit To: ABC Mortgage</ul>" _
& "<ul>Acct: 11111111111</ul>" _
& "<ul>Description: " & Combo296 & " EPO SRP Refund</ul>" _
& "<p>Thank you for the opportunity to service loans from " & Me.Combo296 & "! We appreciate your partnership.</p>" _
& "<p>If you have any questions, please contact your Relationship Manager, " & Me.Combo336 & " (Cc'd).</p>" _
& "<p><br>Sincerely,</br>" _
& "<br>Acquisitions</br>" _
& "<br>acquisitions#us.com</br></p>"
End With
rec.Close
Set rec = Nothing: Set qdef = Nothing: Set db = Nothing
End Sub
Any help would be greatly appreciated.
Avoid concatenating VBA data to SQL even HTML strings. Instead, consider the industry standard of SQL parameterization.
Dim db DAO.Database, qdef As DAO.QueryDef, rec AS DAO.Recordset
' PREPARED STATEMENT (NO DATA)
strQry = "PARAMETERS cboParam TEXT(255);" _
& " SELECT [Loan ID], [Prior Loan ID], [SRP Rate], [SRP Amount] " _
& " FROM emailtable " _
& " WHERE [Seller Name:Refer to As] = [cboParam]"
Set db = CurrentDb
Set qdef = db.CreateQueryDef("", strQry)
' BIND PARAMETER
qdef!cboParam = Me.Combo296
' OPEN RECORDSET
Set rec = qdef.OpenRecordset()
... ' REST OF CODE USING rec
rec.Close
Set rec = Nothing: Set qdef = Nothing: Set db = Nothing
Also, consider saving the email message HTML markup as a text in the table or as text box on form with placeholders to be replaced with combo box values:
.HTMLBody = Replace(Replace(Me.EmailMessage, "placeholder1", Me.Combo296),
"placeholder2", Me.Combo336)
I'm guessing (from your photo) that the data type of your [Seller Name:Refer to as] column is supposed to be string? In which case, your query is missing quotes to denote the string value in your comparison:
'Create each body row
strQry = "Select * from emailtable where [Seller Name:Refer to As] = """ & Me.Combo296 & """"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
Related
VBA Email Generator - Send Notice to Employee with Overdue Tickets
Trying to generate emails to notify user that their ticket is overdue. The program runs and generates the email, however if a employee has multiple tickets overdue, it sends them multiple emails as opposed to one with all overdue items.
Your help is really appreciated!!!!
Option Compare Database
Option Explicit
Public Sub SendSerialEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Do Until rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("ID")
aRow(2) = rec("title")
aRow(3) = rec("name")
aRow(4) = rec("created")
aRow(5) = rec("workdaysopen")
aRow(6) = rec("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
If outStarted Then
outApp.Quit
End If
Do Until rs.EOF
emailTo = rs.Fields("email").Value
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<BODY style=font-size:11pt;font-family:Segoe UI>" & "Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<BODY style=font-size:14pt;font-family:Segoe UI>" & "<b><span style=""color:#B22222"">Overdue Termination Tickets</b>" & _
Join(aBody, vbNewLine) & _
"<br>" & _
"<BODY style=font-size:11pt;font-family:Segoe UI>" & "<b><i><span style=""color:#000000"">**Please note that tickets are overdue.</i></b>"
outMail.Display
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
I'll invite your to test the following code, I've made a test of this code.
The idea is to check if an email address has already been used, in order to send a single email per user.
Send all tickets to all users with 1-single email per user
Public Function IsEmailInArray(strEmail As String, arr() As String, lUbound As Long) As Boolean
Dim i
For i = 1 To lUbound
If arr(i) = strEmail Then
IsEmailInArray = True
Exit Function
End If
Next
IsEmailInArray = False
End Function
Public Sub so66016960SendSerialEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
Dim strTable As String
'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
'
' get listing table of all overdue tickets:
'
Do Until rs.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rs("ID")
aRow(2) = rs("title")
aRow(3) = rs("name")
aRow(4) = rs("created")
aRow(5) = rs("workdaysopen")
aRow(6) = rs("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rs.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table>"
'
strTable = Join(aBody, vbNewLine)
'
'If outStarted Then
' outApp.Quit
'End If
'
'
' rewind:
'
rs.MoveFirst
'
' now we reuse aBody() array as temporay array to used email addresses:
'
lCnt = 0
'
Do Until rs.EOF
emailTo = rs.Fields("email").Value
'
' if email is not yet used:
'
If (Not IsEmailInArray(emailTo, aBody, lCnt)) Then
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
'
' memory the email address just sent:
'
lCnt = lCnt + 1
aBody(lCnt) = emailTo
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
To send email with only her/his own information, we ORDER BY email, like this:
Public Function send1Mail(ByVal outApp, ByVal strEmail2Use, ByVal nameemployee, ByVal emailSubject, ByVal emailText, ByVal strTable)
Dim outMail As Outlook.MailItem
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = strEmail2Use
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
Set outMail = Nothing
send1Mail = 1
End Function
Public Sub SendSerialEmail2Each()
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
'Dim strQry As String
'Dim aHead(1 To 6) As String
'Dim aRow(1 To 6) As String
'Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
'Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
'
' nRows: number of rows in the table
' strTable: html table
' strTableHeader: html table header
' strEmail2Use: email address to send message
'
Dim nRows As Long
Dim strTable As String, strTableHeader As String, strEmail2Use As String
'Create the header row
' aHead(1) = "Ticket#"
' aHead(2) = "Summary"
' aHead(3) = "Ticket Status"
' aHead(4) = "Date Created"
' aHead(5) = "# Business Days Open"
' aHead(6) = "Assigned To"
' lCnt = 1
' ReDim aBody(1 To lCnt)
' strTableHeader = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'
strTableHeader = "<table border='2'>" & _
"<tr>" & _
"<th>Ticket#</th>" & _
"<th>Title</th>" & _
"<th>Name</th>" & _
"<th>Date Create</th>" & _
"<th># Business Days Open</th>" & _
"<th>Assigned To</th>" & _
"</tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
'
' ORDRER BY email is important here:
'
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets ORDER BY email;")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
nRows = rs.RecordCount
'
' initialize:
'
lCnt = 0
strEmail2Use = ""
strTable = ""
'
Do Until rs.EOF
lCnt = lCnt + 1
'
' get email of the current record:
'
emailTo = rs.Fields("email").Value
'
' if first record: save email address and name.
'
If (lCnt = 1) Then
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
'
' send the email if address changes:
'
ElseIf (strEmail2Use <> emailTo) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
strTable = ""
End If
'
' aggregate all records per user for tr's:
'
strTable = strTable & _
"<tr>" & _
"<td>" & rs("ID") & "</td>" & _
"<td>" & rs("title") & "</td>" & _
"<td>" & rs("name") & "</td>" & _
"<td>" & rs("created") & "</td>" & _
"<td>" & rs("workdaysopen") & "</td>" & _
"<td>" & rs("full_name") & "</td>" & _
"</tr>"
'
' also send email at the last row of recordset:
'
If (lCnt = nRows) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
'
End If
'
' move next:
'
rs.MoveNext
Loop
'
' do this to save RAM:
'
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outApp = Nothing
End Sub
Tested data Screenshot:
Generating the following Outlook email Windows to click and send.
I would like to send an e-mail with outlook based on the query results from my table but with table formatting (in the body). For some reason the code is only outputting the last record in the table to the e-mail body, instead of looping and adding all 3 records.
Any suggestions, or a better way to code this?
Public Sub NewEmail()
'On Error GoTo Errorhandler
Dim olApp As Object
Dim olItem As Variant
Dim olatt As String
Dim olMailTem As Variant
Dim strSendTo As String
Dim strMsg As String
Dim strTo As String
Dim strcc As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim fld As Field
Dim varItem As Variant
Dim strtable As String
Dim rec As DAO.Recordset
Dim strqry As String
strqry = "SELECT * From Email_Query"
strSendTo = "test#email.com"
strTo = ""
strcc = ""
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(olMailTem)
olItem.Display
olItem.To = strTo
olItem.CC = strcc
olItem.Body = ""
olItem.Subject = "Test E-mail"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strqry)
If Not (rec.BOF And rec.EOF) Then
rec.MoveLast
rec.MoveFirst
intCount = rec.RecordCount
For intLoop = 1 To intCount
olItem.HTMLBody = "<HTML><body>" & _
"<table border='2'>" & _
"<tr>" & _
"<th> Request Type </th>" & _
"<th> ID </th>" & _
"<th> Title </th>" & _
"<th> Requestor Name </th>" & _
"<th> Intended Audience </th>" & _
"<th> Date of Request</th>" & _
"<th> Date Needed </th>" & _
"</tr>" & _
"<tr>" & _
"<td>" & rec("Test1") & "</td>" & _
"<td>" & rec("Test2") & "</td>" & _
"<td>" & rec("Test3") & "</td>" & _
"<td>" & rec("Test4") & "</td>" & _
"<td>" & rec("Test5") & "</td>" & _
"<td>" & rec("Test6") & "</td>" & _
"<td>" & rec("Test7") & "</td>" & _
"</tr>" & _
"<body><HTML>"
rec.MoveNext
Next intLoop
End If
MsgBox "E-mail Sent"
Set olApp = Nothing
Set olItem = Nothing
Exit_Command21_Click:
Exit Sub
ErrorHandler:
MsgBox Err.Description, , Err.Number
Resume Exit_Command21_Click
End Sub
You're changing the HTMLBody every loop rather than adding to it. You should set your header row above the loop, then set each row inside the loop. I like to fill up arrays and use the Join function - it's more visually pleasing to me.
Public Sub NewEmail()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 7) As String
Dim aRow(1 To 7) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Request Type"
aHead(2) = "ID"
aHead(3) = "Title"
aHead(4) = "Requestor Name"
aHead(5) = "Intended Audience"
aHead(6) = "Date of Request"
aHead(7) = "Date Needed"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From Email_Query"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Test1")
aRow(2) = rec("Test2")
aRow(3) = rec("Test3")
aRow(4) = rec("Test4")
aRow(5) = rec("Test5")
aRow(6) = rec("Test6")
aRow(7) = rec("Test7")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.display
olItem.To = "example#example.com"
olItem.Subject = "Test E-mail"
olItem.htmlbody = Join(aBody, vbNewLine)
olItem.display
End Sub
Within the following code
Dim sqlStr As String
Dim OrgID As Long
Dim wrk As DAO.Workspace
Dim db As DAO.Database
Dim orgRS As DAO.Recordset
Dim staffRS As DAO.Recordset
Set wrk = DBEngine.Workspaces(0)
Set db = CurrentDb
On Error GoTo trans_Err
InsertOrganizationIntoTemp
'if staff fields are not blank Insert Staff into Temp
If (addStaffClickCheck = True) Then
staffNumber = staffNumber + 1
InsertStaffIntoTemp staffNumber
End If
wrk.BeginTrans
sqlStr = "INSERT INTO tblOrganization(OrganizationName, Affiliate, " _
& " UnionCouncil, DateJoined, OrganizationPhoneNumber, OrganizationFaxNumber, " _
& " MembershipGroup, TradeGroup, URL) " _
& " SELECT OrganizationName, Affiliate, CouncilUnion, DateJoined, OrganizationPhone, " _
& " OrganizationFax, MemberGroup, Trade, OrganizationWebsite " _
& " FROM tblTempOrganization;"
db.Execute sqlStr
OrgID = db.OpenRecordset("SELECT ##IDENTITY")(0)
sqlStr = "INSERT INTO tblAddresses(StreetName, CityName, StateName, " _
& " ZipCode, LocationID, OrganizationID) " _
& " SELECT OrganizationAddress, OrganizationCity, OrganizationState, " _
& " OrganizationZIP, OrganizationLocationType, '" & OrgID & "' " _
& " FROM tblTempOrganization;"
db.Execute sqlStr
'pull all staff and phones into two recordsets
'loop through staff and for each staff member add associated phone information
'Recordsets for temporary staff tables
Dim staffTempInfoRS As DAO.Recordset
Dim phoneTempInfoRS As DAO.Recordset
Set staffTempInfoRS = db.OpenRecordset("SELECT * FROM tblTempStaff", dbOpenDynaset)
'Recordsets for permanant staff tables
Dim StaffAddressID As Long
Dim StaffID As Long
'Check to see if the recordset actually contains rows
If Not (staffTempInfoRS.EOF And staffTempInfoRS.BOF) Then
staffTempInfoRS.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until staffTempInfoRS.EOF = True
'address information
Dim staffAddressDBRS As DAO.Recordset
Set staffAddressDBRS = db.OpenRecordset("tblStaffAddresses", dbOpenDynaset)
With staffAddressDBRS
.AddNew
.Fields("StaffStreet") = staffTempInfoRS.Fields("StaffStreet")
.Fields("StaffCity") = staffTempInfoRS.Fields("StaffCity")
.Fields("StaffState") = staffTempInfoRS.Fields("StaffState")
.Fields("StaffZip") = staffTempInfoRS.Fields("StaffZip")
.Update
End With
StaffAddressID = staffAddressDBRS.LastModified
staffAddressDBRS.Close
Set staffAddressDBRS = Nothing
'staff information
Dim staffInfoDBRS As DAO.Recordset
Set staffInfoDBRS = db.OpenRecordset("tblStaff", dbOpenDynaset)
With staffInfoDBRS
.AddNew
.Fields("StaffFirstName") = staffTempInfoRS.Fields("StaffFirstName")
.Fields("StaffLastName") = staffTempInfoRS.Fields("StaffLastName")
.Fields("Email") = staffTempInfoRS.Fields("Email")
.Fields("StaffAddressID") = StaffAddressID
.Fields("OrganizationID") = OrgID
.Fields("Position") = staffTempInfoRS.Fields("StaffPosition")
.Update
End With
Dim currPos As Long
currPos = staffTempInfoRS.Fields("StaffNumber")
StaffID = staffInfoDBRS.LastModified
staffInfoDBRS.Close
Set staffInfoDBRS = Nothing
'staff phone information
Set phoneTempInfoRS = db.OpenRecordset("SELECT * FROM tblTempPhones WHERE StaffNumber = " & currPos & ";")
If Not (phoneTempInfoRS.EOF And phoneTempInfoRS.BOF) Then
phoneTempInfoRS.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until phoneTempInfoRS.EOF = True
Dim phoneInfoDBRS As DAO.Recordset
Set phoneInfoDBRS = db.OpenRecordset("tblStaffPhoneNumbers", dbOpenDynaset)
With phoneInfoDBRS
.AddNew
.Fields("PhoneNumber") = phoneTempInfoRS.Fields("StaffPhoneNumber")
.Fields("PhoneTypeID") = phoneTempInfoRS.Fields("PhoneType")
.Fields("StaffID") = StaffID
.Update
End With
phoneTempInfoRS.MoveNext
Loop
Else
Resume Next
End If
MsgBox "Finished looping through phone records."
phoneTempInfoRS.Close
Set phoneTempInfoRS = Nothing
'Move to the next record. Don't ever forget to do this.
staffTempInfoRS.MoveNext
Loop
Else
MsgBox "There are no records in the staff recordset."
End If
MsgBox "Finished looping through staff records."
staffTempInfoRS.Close 'Close the recordset
Set staffTempInfoRS = Nothing 'Clean up
wrk.CommitTrans
trans_Exit:
'Clean up
wrk.Close
Set db = Nothing
Set wrk = Nothing
Exit Function
trans_Err:
'Roll back the transaction
MsgBox "Whoops! We got errors"
wrk.Rollback
Resume trans_Exit
When I step through this I get an error in this line:
.Fields("StaffStreet") = staffTempInfoRS.Fields("StaffStreet")
That says:
Item not found in collection.
However, this is the exact field name that is in the table that the recordset is set to open.
30 hours later it seems I suffered a rookie mistake and in-spite of repeated checking missed that the field names were indeed misspelled.
I also set the recordsets outside of the loops and I unset them all in the exit snippet...
Please reference code below...
Private Sub Save_Click()
On Error GoTo err_I9_menu
Dim dba As Database
Dim dba2 As Database
Dim rst As Recordset
Dim rst1 As Recordset
Dim rst2 As Recordset
Dim rst3 As Recordset
Dim SQL As String
Dim dateandtime As String
Dim FileSuffix As String
Dim folder As String
Dim strpathname As String
Dim X As Integer
X = InStrRev(Me!ListContents, "\")
Call myprocess(True)
folder = DLookup("[Folder]", "Locaton", "[LOC_ID] = '" & Forms!frmUtility![Site].Value & "'")
strpathname = "\\Reman\PlantReports\" & folder & "\HR\Paperless\"
dateandtime = getdatetime()
If Nz(ListContents, "") <> "" Then
Set dba = CurrentDb
FileSuffix = Mid(Me!ListContents, InStrRev(Me!ListContents, "."), 4)
SQL = "SELECT Extension FROM tbl_Forms WHERE Type = 'I-9'"
SQL = SQL & " AND Action = 'Submit'"
Set rst1 = dba.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)
If Not rst1.EOF Then
newname = Me!DivisionNumber & "-" & Right(Me!SSN, 4) & "-" & LastName & dateandtime & rst1.Fields("Extension") & FileSuffix
Else
newname = Me!DivisionNumber & "-" & Right(Me!SSN, 4) & "-" & LastName & dateandtime & FileSuffix
End If
Set moveit = CreateObject("Scripting.FileSystemObject")
copyto = strpathname & newname
moveit.MoveFile Me.ListContents, copyto
Set rst = Nothing
Set dba = Nothing
End If
If Nz(ListContentsHQ, "") <> "" Then
Set dba2 = CurrentDb
FileSuffix = Mid(Me.ListContentsHQ, InStrRev(Me.ListContentsHQ, "."), 4)
SQL = "SELECT Extension FROM tbl_Forms WHERE Type = 'HealthQuestionnaire'"
SQL = SQL & " AND Action = 'Submit'"
Set rst3 = dba2.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)
If Not rst3.EOF Then
newname = Me!DivisionNumber & "-" & Right(Me!SSN, 4) & "-" & LastName & dateandtime & rst3.Fields("Extension") & FileSuffix
Else
newname = Me!DivisionNumber & "-" & Right(Me!SSN, 4) & "-" & LastName & dateandtime & FileSuffix
End If
Set moveit = CreateObject("Scripting.FileSystemObject")
copyto = strpathname & newname
moveit.MoveFile Me.ListContentsHQ, copyto
Set rst2 = Nothing
Set dba2 = Nothing
End If
Set dba = CurrentDb
Set rst = dba.OpenRecordset("dbo_tbl_EmploymentLog", dbOpenDynaset, dbSeeChanges)
rst.AddNew
rst.Fields("TransactionDate") = Date
rst.Fields("EmployeeName") = Me.LastName
rst.Fields("EmployeeSSN") = Me.SSN
rst.Fields("EmployeeDOB") = Me.EmployeeDOB
rst.Fields("I9Pathname") = strpathname
rst.Fields("I9FileSent") = newname
rst.Fields("Site") = DLookup("Folder", "Locaton", "Loc_ID='" & Forms!frmUtility!Site & "'")
rst.Fields("UserID") = Forms!frmUtility!user_id
rst.Fields("HqPathname") = strpathname
rst.Fields("HqFileSent") = newname2
rst.Update
Set dba = Nothing
Set rst = Nothing
exit_I9_menu:
Call myprocess(False)
DivisionNumber = ""
LastName = ""
SSN = ""
ListContents = ""
ListContentsHQ = ""
Exit Sub
err_I9_menu:
Call myprocess(False)
MsgBox Err.Number & " " & Err.Description
'MsgBox "The program has encountered an error and the data was NOT saved."
Exit Sub
End Sub
I keep getting an ODBC call error. The permissions are all correct and the previous piece of code worked where there were separate tables for the I9 and Hq logs. The routine is called when someone submits a set of files with specific information.
Just a guess here, but I'm thinking you've got a typo that's resulting in assigning a Null to a required field.
Change "Locaton":
rst.Fields("Site") = DLookup("Folder", "Locaton", "Loc_ID='" & Forms!frmUtility!Site & "'")
To "Location":
rst.Fields("Site") = DLookup("Folder", "Location", "Loc_ID='" & Forms!frmUtility!Site & "'")
Some general advice for troubleshooting 3146 ODBC Errors: DAO has an Errors collection which usually contains more specific information for ODBC errors. The following is a quick and dirty way to see what's in there. I have a more refined version of this in a standard error handling module that I include in all of my programs:
Dim i As Long
For i = 0 To Errors.Count - 1
Debug.Print Errors(i).Number, Errors(i).Description
Next i
I solved this by recreating the table in SQL instead of up-sizing it out of Access.
My 3146 error was caused by the lack of primary key on my sql server table. It was resolved by defining a primary key and then refreshing the connection through Linked Table Manager.
I created an Access database which I want to distribute to a small group. While I can always export the tables in excel and merge them/append data there, is there a way to sync the databases, maybe by using VBA?
To expound further, in one form in the database application, a sync button may exist, and onclick, a dialog box may open to look for the accdb to sync with. What ensues is that the VBA will "sync" the table (which of course is of the same structure) in question between the two accdbs.
Is this possible? Insights will be good. Thank you!
Yes, it is perfectly possible. Here are some notes on comparing two DBs and logging changes.
The procedure requires the following at the top of the module:
Dim strFileNew As String
Dim strFileOld As String
Dim strLog As String
Dim dbOld As Database
The variables might contain:
strLog = "log.txt"
strFileNew = "z:\docs\dbNew.mdb"
strFileOld = "z:\docs\dbOld.mdb"
Set dbOld = OpenDatabase(strFileOld)
Then the comparison:
Sub LogCompareDB(db As Database)
''References : Windows Script Host Object Model
'' This is set by default for a number of versions
'' : Microsoft DAO x.x Object Library
'' For 2010, the DAO library is called
'' :Microsoft Office 12.0 Access Database Engine Object Library
Dim tdf As TableDef
Dim rs0 As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim fld As DAO.Field
Dim idx As Index
Dim idxPrimary As Index
Dim strIndexList As String
Dim strIndex As String
Dim strID As String
Dim strSQL As String
Dim strChanged As String
Dim blnNew As Boolean
Dim fs As New FileSystemObject
Dim ts As TextStream
Set ts = fs.CreateTextFile(strLog, True)
''For each table in the old database
''(It would probably be a good idea to check the
''new database for added tables)
For Each tdf In db.TableDefs
'' Skip system tables
If Left(tdf.Name, 4) <> "MSys" Then
strIndex = vbNullString
Set idxPrimary = Nothing
strIndexList = vbNullString
''Get the primary index and index fields
For Each idx In tdf.Indexes
If idx.Primary = True Then
Set idxPrimary = idx
For Each fld In idx.Fields
strIndex = strIndex & " AND t0.[" & fld.Name _
& "] = t1.[" & fld.Name & "]"
strIndexList = strIndexList & "," & fld.Name
Next
strIndex = Mid(strIndex, 5)
End If
Next
''There is no basis for comparison if there is no index.
''A unique index would also be a possibility, but hey, let's
''not go over the top :)
If strIndex > vbNullString Then
''Select all records from the table for both databases
strSQL = "SELECT * FROM [;DATABASE=" & strFileNew & "].[" _
& tdf.Name & "] As t0 LEFT JOIN [" _
& tdf.Name & "] As t1 ON " & strIndex
Set rs0 = db.OpenRecordset(strSQL)
''A convenient list of fields from the old database
''It would probably be a good idea to check the
''new database for added fields.
strSQL = "SELECT * FROM [;DATABASE=" & strFileOld & "].[" _
& tdf.Name & "] As t0 WHERE 1=2"
Set rs1 = db.OpenRecordset(strSQL)
Do While Not rs0.EOF
strID = vbNullString
blnNew = False
''If the index fields are null, then it is a new record
For Each fld In idxPrimary.Fields
strID = strID & fld.Name & ": " & rs0("[t0." & fld.Name & "]") & vbCrLf
If IsNull(rs0("[t1." & fld.Name & "]")) Then
blnNew = True
End If
Next
If blnNew Then
''Write to log
ts.WriteLine "NEW RECORD " & strID & vbCrLf
Else
''Not a new record, so is it a changed record?
strChanged = vbNullString
For Each fld In rs1.Fields
''No need to check index fields, because they are equal
If InStr(strIndexList, fld.Name) = 0 Then
''Add null string for purposes of comparison ''trailing
If "" & rs0("[t0." & fld.Name & "]") <> "" & rs0("[t1." & fld.Name & "]") Then
strChanged = strChanged & vbCrLf _
& fld.Name & " Is: " & Trim(rs0("[t0." & fld.Name & "]")) _
& " Was: " & Trim(rs0("[t1." & fld.Name & "]"))
End If
End If
Next
If strChanged <> vbNullString Then
''Write to log
ts.WriteLine "CHANGED RECORD " & strID
ts.WriteLine strChanged & vbCrLf
End If
End If
rs0.MoveNext
Loop
Else
ts.WriteLine "NO PRIMARY INDEX " & tdf.Name & vbCrLf
End If
End If
Next
ts.Close
FollowHyperlink strLog
End Sub
Option Compare Database
Private Sub Command4_Click()
Dim tablename1, tablename2 As String
tablename1 = Text0.Value
tablename2 = Text2.Value
'On Error GoTo Err_cmdValidateGeneralInfo_Click
Dim F As DAO.Field
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set curDB = CurrentDb()
'If Me.DateModified = Date Then
'Adds new employees to the TT_GeneralInfo table in the FTEI_PhoneBook.mdb - which is used thru out the AP databases.
' DoCmd.OpenQuery "qryEmpData_TT_General"
strsql = "Select * from " & tablename1
Set rs = curDB.OpenRecordset(strsql)
strsql1 = "Select * from " & tablename2
DoCmd.CopyObject , "Unmatched_records", acTable, tablename1
curDB.Execute "DELETE FROM Unmatched_records"
Set rs1 = curDB.OpenRecordset(strsql1)
Do Until rs.EOF
For Each F In rs.Fields
If rs.Fields(F.Name) <> rs1.Fields(F.Name) Then
'rs.Edit
strsql = "Select * into test from " & tablename1 & " where " & F.Name & " = """ & rs.Fields(F.Name) & """"
DoCmd.RunSQL strsql
If DCount(F.Name, "test") <> 0 Then
GoTo append_unmatch
'appending unmacthed records
append_unmatch:
strsql2 = "insert into Unmatched_records Select * from test"
DoCmd.RunSQL strsql2
'if record doesnt match move to next one
GoTo Nextrecord
End If
' rs.Fields(F.Name) = rs1.Fields(F.Name)
' rs.Update
End If
Next F
Nextrecord:
rs.MoveNext
rs1.MoveNext
Loop
If DCount("test", F.Name) <> 0 Then
MsgBox ("The two tables didnt match. Check table test for unmatching reocrds.")
Else
MsgBox ("Tables match!")
End If
End Sub