I want to generate an email with an MS Access form the user has filled out, as well as INSERT INTO during the same action to record the results into a table.
My table has 7 columns:
ID (autonumber)
Date Submitted (Date())
First_Name (Short Text)
Last_Name (Short Text)
Email (Short Text)
Priority (Short Text)
Error (Long Text)
The code:
Private Sub Submit_Ticket_Button_Click()
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim rs As Recordset
Dim CustomerEmail As String
' prevent 429 error, if outlook is not open
On Error Resume Next
Err.Clear
Set oOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.To = "alex.e.bristow2.ctr#mail.mil"
.Subject = "A Trouble Ticket Has Been Submitted"
.Body = DoCmd.SendObject
.Display
End With
Set oEmailItem = Nothing
Set oOutlook = Nothing
End Sub
Private Sub Submit_Ticket_Button_Click1()
Dim strinsert As String
strinsert = "INSERT INTO Trouble Tickets (First_Name,Last_Name,Email,Priority,Error)" & _
"values('" & FirstName.Value & "','" & LastName.Value & "','" & Email.Value & "','" & Priority.Value & "','" & Error.Value & "');"
DoCmd.RunSQL strinsert
End Sub
I get
"compile error, Expected function or variable"
in the first Sub.
This can't be right:
.Body = DoCmd.SendObject
Body expects a string holding your message body.
Related
I am trying to make email using Outlook to remind someone to update their CV information per 6 months (180 days).
I have 1 query and 1 table.
Duedate_7 query consists of employee information, which passed 180 days or more since the last update. Access would send email to those employees.
Highlights table consists of the ID of the employees (Number), date of the project (date) and content of the project (long text).
Option Compare Database
Option Explicit
Function Otomail()
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
Set rs1 = db.OpenRecordset("SELECT ID, NIK, Nama, email, datemailsend FROM DueDate_7")
Do Until rs1.EOF
emailTo = rs1.Fields("email")
emailSubject = "Update CV"
emailText = "Please send the newest project highlights informations of Mr/Mrs' " & rs1.Fields("Nama").Value & " to the inside sales department for updating your CV which is scheduled once per 6 months." & vbCr & _
"Your latest project highlights update was " & vbCr & _
"This email is auto generated from Task Database. Please Do Not Reply!"
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Display
rs1.Edit
rs1!datemailsend = Date
rs1.Update
rs1.MoveNext
Loop
rs1.Close
Set rs1 = Nothing
Set db = Nothing
Set outMail = Nothing
Set outApp = Nothing
End Function
I want to include each of the employee's 3 latest project highlights, stored in Highlights table, in each of the email I send.
What you need to do is to use a second recordset inside the loop that you have already got that selects the information required. Something like:
If Not (rs1.BOF And rs1.EOF) Then
Do
strProject = ""
strSQL = "SELECT TOP 3 ProjectName, ProjectDate " _
& " FROM Highlights " _
& " WHERE NameID=" & rs1!NameID _
& " ORDER BY ProjectDate DESC;"
Set rsProject = db.OpenRecordset(strSQL)
If Not (rsProject.BOF And rsProject.EOF) Then
Do
strProject = strProject & rsProject!ProjectDate & vbTab & rsProject!ProjectName & vbCrLf
rsProject.MoveNext
Loop Until rsProject.EOF
End If
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = rs1!email
outMail.Subject = "Update CV"
outMail.Body = emailText & strProject
outMail.Display
rs1.MoveNext
Loop Until rs1.EOF
End If
This is assuming that you have a field called NameID that identifies the person to be selected.
Regards,
I am using Access VBA code to automatically send emails through Outlook after a set amount of time.
I keep getting a run-time error 3085. I do not know what went wrong or what function it is referring to. Is it possibly a reference I am missing or did I mess up on my functions somewhere?
Option Compare Database
Sub SendMail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
strSQL = "SELECT DATE, COMPANY, CUSTOMER, EMAIL(DISTRIBUTOR), FUP" & _
" FROM Sample Query WHERE DATE = (Date())"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
emailTo = Trim(rs.Fields("COMPANY").Value & " " & _
rs.Fields("CUSTOMER").Value) & _
" <" & rs.Fields("EMAIL(DISTRIBUTOR)").Value & ">"
emailSubject = "Proposal Follow Up"
If IsNull(rs.Fields("COMPANY").Value) Then
emailSubject = emailSubject & " for " & _
rs.Fields("COMPANY").Value & " " & rs.Fields("CUSTOMER").Value
End If
emailText = Trim("Hello " & rs.Fields("COMPANY").Value) & "!" & vbCrLf
emailText = emailText & _
"We put an order on " & rs.Fields("DATE").Value & _
" for " & rs.Fields("COMPANY").Value & _
"A follow up would be good about now"
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Send
rs.Edit
rs("FUP") = Now()
rs.Update
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
EMAIL(DISTRIBUTOR) needs to be surrounded by brackets to be a valid.
strSQL = "SELECT DATE, COMPANY, CUSTOMER, [EMAIL(DISTRIBUTOR)]
I have tried adding brackets to my stated parameters to show that they are separate but I still get the error, I checked all the "&" but to no avail.
Here is the code. Thanks in advance.
Option Compare Database
Public Function SendMail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject("Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
strSQL = "SELECT DATE, COMPANY, CUSTOMER, EMAIL, FUP, [SAMPLES
REQUESTED]" & _
" FROM Sample Query WHERE DATE = Date()"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
emailTo = rs.Fields("EMAIL").Value
emailSubject = "Proposal Follow Up"
If IsNull(rs.Fields("COMPANY").Value) Then
emailSubject = emailSubject & " for " & _
rs.Fields("COMPANY").Value & " " &
rs.Fields("CUSTOMER").Value
End If
emailText = Trim("Hello " & rs.Fields("COMPANY").Value) & "!" & vbCrLf
emailText = emailText & _
"Hello, " & rs.Fields("Name").Value & _
rs.Fields("CUSTOMER").Value & " ordered " & rs.Fields("SAMPLES
REQUESTED").Value & _
" on " & rs.Fields("Date").Value & " its been about a month. A
follow up would be good about now."
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Send
rs.Edit
rs("FUP") = Now()
rs.Update
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Function
You miss brackets around the reserved word Date:
strSQL = "SELECT [DATE], COMPANY, CUSTOMER, EMAIL, FUP, [SAMPLES REQUESTED]" & _
" FROM [Sample Query] WHERE [DATE] = Date()"
Date is a protected word in Access. If you need to use that exact field name, put it in brackets like Gustav suggests. You can also rename the field, like TheDate or DateStart.
Here's a full list of protected words:
https://support.microsoft.com/en-us/help/286335/list-of-reserved-words-in-access-2002-and-in-later-versions-of-access
So I need assistance. I am running data in MS Access 2013 and I have a table with multiple rows and columns. What I am trying to do is take each row and taking only some of the columns and send the data to MS Outlook and paste it into the body.
The data constantly changes is size. One week I might have 3 rows of data and some weeks 50 rows. So what I am looking for from a data is this:
MS Access Table:
Account Number Date Time Cust Status Issue Corr Action
123 3/1/16 8A Open Customer Resolved
345 3/5/16 8:30P Close Cust. Called Confirmed
MS Outlook:
Account Number: 123
Cust Status: Open
Date: 3/1/16
Issue:
Customer
Corr Action:
Resolved
Account Number: 456
Cust Status: Closed
Date: 3/5/16
Issue:
Cust. Called
Corr Action:
Confirmed
Here is the code I have done so far:
Public Sub SendEmail()
Dim mailItem As Outlook.mailItem
Dim sMsgBody As String
Dim aBody() As String
Call AdoRecordset
InitOutlook
Set mailItem = outlookApp.CreateItem(olMailItem)
mailItem.To = ""
mailItem.CC = ""
mailItem.Subject = "Escalations for the week"
mailItem.Body = Issues
mailItem.Display
Set mailItem = Nothing
CleanUp
End Sub
Private Sub CleanUp()
Set outlookNamespace = Nothing
Set outlookApp = Nothing
End Sub
Function AdoRecordset()
Dim rs As New ADODB.Recordset
Dim strSql As String
strSql = "Select [Issue] From [Table];"
rs.Open strSql, CurrentProject.Connection
Do While Not rs.EOF
Debug.Print rs![Issue]
Issues = Issues & rs.Fields(0).Value & vbCrLf
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Function
You must pass the formatted text from AdoRecordset to the calling subroutine.
Public Sub SendEmail()
sMsgBody = AdoRecordset()
.
.
.
MailItem.Subject = sMsgBody
End Sub
Function AdoRecordset() as String
Dim rs As New ADODB.Recordset
Dim strSql As String
strSql = "Select [Account Number], [Date], [Cust Status], [Issue], [Corr Action] From [Table];"
rs.Open strSql, CurrentProject.Connection
Do While Not rs.EOF
For Each oFld In rs.Fields
Select Case oFld.Name
Case "Account Number", "Date"
sResult = sResult & oFld.Name & ":" & oFld.Value & vbCrLf
Case "Cust Status"
sResult = sResult & oFld.Name & ":" & oFld.Value & vbCrLf & vbCrLf
Case Else
sResult = sResult & oFld.Name & ":" & vbCrLf & oFld.Value & vbCrLf & vbCrLf
End Select
Next
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
AdoRecordset = sResult
End Function
*Option Compare Database
Option Explicit
Private outlookApp As Outlook.Application
Private outlookNamespace As Outlook.NameSpace
Dim Email As String
Dim Issues As String
Private Sub InitOutlook()
' Initialize a session in Outlook
Set outlookApp = New Outlook.Application
'Return a reference to the MAPI layer
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
'Let the user logon to Outlook with the
'Outlook Profile dialog box
'and then create a new session
outlookNamespace.Logon , , True, False
End Sub
Public Sub SendEmail()
Dim sMsgBody As String
Dim mailItem As Outlook.mailItem
Dim sResult As Variant
sMsgBody = AdoRecordset()
'mailItem.Subject = sMsgBody
InitOutlook
Set mailItem = outlookApp.CreateItem(olMailItem)
mailItem.To = ""
mailItem.Subject = "Escalations for the week"
mailItem.Body = sResult
mailItem.Display
Set mailItem = Nothing
CleanUp
End Sub
Private Sub CleanUp()
Set outlookNamespace = Nothing
Set outlookApp = Nothing
End Sub
Function AdoRecordset() As String
Dim rs As New ADODB.Recordset
Dim strSql As String
Dim oFld As Variant
Dim sResult As Variant
strSql = "Select [Account Number], [Dates], [Cust Status], [Issue], [Corr Action] From [Table];"
rs.Open strSql, CurrentProject.Connection
Do While Not rs.EOF
For Each oFld In rs.Fields
Select Case oFld.Name
Case "Incident#", "Date Escalted"
sResult = sResult & oFld.Name & ":" & oFld.Value & vbCrLf
Case "Customer Status"
sResult = sResult & oFld.Name & ":" & oFld.Value & vbCrLf & vbCrLf
Case Else
sResult = sResult & oFld.Name & ":" & vbCrLf & oFld.Value & vbCrLf & vbCrLf
End Select
Next
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
AdoRecordset = sResult
End Function*
Sorry, this is what I have. Can you fix it.
Option Compare Database
Option Explicit
Private outlookApp As Outlook.Application
Private outlookNamespace As Outlook.NameSpace
Dim Email As String
Dim Issues As String
Private Sub InitOutlook()
' Initialize a session in Outlook
Set outlookApp = New Outlook.Application
'Return a reference to the MAPI layer
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
'Let the user logon to Outlook with the
'Outlook Profile dialog box
'and then create a new session
outlookNamespace.Logon , , True, False
End Sub
Public Sub SendEmail()
Dim sMsgBody As String
Dim mailItem As Outlook.mailItem
Dim sResult As Variant
sMsgBody = AdoRecordset()
'mailItem.Subject = sMsgBody
InitOutlook
Set mailItem = outlookApp.CreateItem(olMailItem)
mailItem.To = ""
mailItem.Subject = "Escalations for the week"
mailItem.Body = sResult
mailItem.Display
Set mailItem = Nothing
CleanUp
End Sub
Private Sub CleanUp()
Set outlookNamespace = Nothing
Set outlookApp = Nothing
End Sub
Function AdoRecordset() As String
Dim rs As New ADODB.Recordset
Dim strSql As String
Dim oFld As Variant
Dim sResult As Variant
strSql = "Select [Account Number], [Dates], [Cust Status], [Issue], [Corr Action] From [Table];"
rs.Open strSql, CurrentProject.Connection
Do While Not rs.EOF
For Each oFld In rs.Fields
Select Case oFld.Name
Case "Account Number", "Dates"
sResult = sResult & oFld.Name & ":" & oFld.Value & vbCrLf
Case "Cust Status"
sResult = sResult & oFld.Name & ":" & oFld.Value & vbCrLf & vbCrLf
Case Else
sResult = sResult & oFld.Name & ":" & vbCrLf & oFld.Value & vbCrLf & vbCrLf
End Select
Next
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
AdoRecordset = sResult
End Function
I have a Userform which has 3 buttons on it and based on the click the respective text needs to be inserted in the body of the email, for this e-mail the To, CC, Subject, will be taken from Listview box in Sheet1 which inturn extracts the values stored in Sheet2 and paste it in To, CC, Subject of the email.
When i paste the code in the buttonclick () command the variables are not getting passed from the maincode to the userform code where it shows the To, CC and Subject as blanks.
Here's the code:
Sub Worksheet_Activate()
Dim rngCell As Range
ListView41.ListItems.Clear
For Each rngCell In Worksheets("MFRs Contacts").Range("A2:A400")
If Not rngCell = Empty Then
With ListView41.ListItems.Add(, , rngCell.Value)
.ListSubItems.Add , , rngCell.Offset(0, 1).Value
.ListSubItems.Add , , rngCell.Offset(0, 2).Value
End With
End If
Next rngCell
End Sub
Sub ListView41_DblClick()
Dim strName As String
Dim strEmail As String
Dim strEmail1 As String
Dim OutApp As Object
Dim OutMail As Object
Dim Singlepart As String
Dim SigString As String
Dim Signature As String
Dim strbody As String
Dim SigFilename
strName = ListView41.SelectedItem.Text
strEmail = ListView41.SelectedItem.ListSubItems(1).Text
strEmail1 = ListView41.SelectedItem.ListSubItems(2).Text
check = MsgBox("Send e-mail, To : " & strName & " - " & strEmail & "?" & vbNewLine & _
"CC : " & strEmail1, vbYesNo)
If check <> vbYes Then Exit Sub
Singlepart = MsgBox("For Single Part or Multiple Parts ? " & vbNewLine & vbNewLine & _
"Single Part = Yes" & vbNewLine & _
"Multiple Parts = No", vbYesNo)
If Singlepart = vbYes Then
' For Single Part Numbers
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"Ron's Excel Page" & _
"<br><br><B>Thank you</B>"
'Signature of User
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Rohith UTAS.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
Userform1.Show
'With Outlook
With OutMail
.Display
.To = strEmail
.CC = strEmail1
.BCC = ""
.Subject = strName & "_Request for Product Information"
.HTMLBody = strbody & vbNewLine & Signature
.Display 'or .Display if you want the user to view e-mail and send it manually
End With
Else
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you please help me on this.
Your variables you need to access on your form (I'm assuming strName, strEmail, and strEmail1) only have scope in Sub ListView41_DblClick(). If you need to use them in your form, you'll have to pass them as parameters (my preferred way to do it) or give them global scope.
A UserForm is a class, so you can give it properties like any other class - i.e. in UserForm1:
Private mEmail As String
Public Property Let Email(inputVal As String)
mEmail = inputVal
End Property
Public Property Get Email() As String
Email = mEmail
End Property
Then you would call it like any other object:
Dim nameless_form As UserForm1
Set nameless_form = New UserForm1
nameless_form.Email = strEmail
nameless_form.Show