VBA Moving MailItem after Subject Line Change - vba

I have a query below, I am trying to amend the Subject Line of an incoming email and then move it to a Folder within the Mailbox (Not the Inbox).
I need to do this because an external program watches this folder and files the emails accordingly.
I can find plenty on how to move an Item systematically externally, or moving an object within an Inbox Sub Folder but not a folder under the main 'Mailbox'.
Can anyone shed any light for me please, bear in mind this runs as a 'Run As Script' when the mail comes in.
Sub AmendSubject(myItem As Outlook.MailItem)
Dim strBranch As String
Dim strPolRef As String
Dim strTo As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rsSQL As String
Dim objNS As Outlook.NameSpace
'Set objNS = Application.GetNamespace("MAPI")
'Set myInbox = objNS.GetDefaultFolder(olFolderInbox)
Dim strSubject As String
Set cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
'Places the Customer Email Address in a string
strTo = myItem.To
strTo = Replace(strTo, "'", "")
cnn.Open "Provider=SQLOLEDB;Data Source=xxx;Initial Catalog=xxxx;User ID=xxxxx;Password=xxx;"
'SQL Statement
rsSQL = "SELECT TOP 1 [c].[B#] AS [Branch], p.[PolRef#] AS [Ref] FROM [dbo].[ic_yyclient] AS c" & _
" INNER JOIN [dbo].[ic_brpolicy] AS p ON [c].[B#] = [p].[B#] AND [c].[Ref#] = [p].[Ref#]" & _
" LEFT OUTER JOIN [dbo].[ic_BD_ATS1] AS ats1 ON [p].[B#] = [ats1].[B#] AND [p].[PolRef#] = [ats1].[PolRef#]" & _
" WHERE [Ptype] IN ('PC','TW') AND (c.[Email] = '" & strTo & "' OR ats1.[Email] = '" & strTo & "' OR ats1.[p_email] = '" & strTo & "') AND [Term_code] IS NULL" & _
" ORDER BY [ats1].[PolRef#] desc"
Debug.Print rsSQL
rs.Open rsSQL, cnn, adOpenForwardOnly
With rs
While Not .EOF
strBranch = !Branch
strPolRef = !Ref
.MoveNext
Wend
End With
strSubject = "REF: 0" & strBranch & "-" & strPolRef & "-C<Email To Client>NB Documentation Email"
'myItem.Display
myItem.Subject = strSubject
myItem.Save
rs.Close
'myItem.Move fldrOAtt
Set rs = Nothing
Set cnn = Nothing
End Sub

If the folder is on the same level as the Inbox, retrieve its parent, then go down one level:
set subfolder = myInbox.Parent.Folders.Item("the folder name")

Related

Microsoft Access VBA code to send email to recipients with attachment based on results of query filtered on check date

I've commented out the section to add the attachment because I know it works, but the files currently aren't present to be attached. I'm new to VBA and am missing something. My data is simply employee number, check date (send_checkdt), check number, name, etc. The query has no parameters, which is why I'm doing the select based on the form date defined in strSQL.
When I run it I immediately get an over and it exits. Previously I was only able to send the email to the first person in the query and the record didn't advance. The email part is working correctly, I'm just not processing the data correctly.as
What am I missing?
Private Sub Command1_Click()
Dim Msg As String
Dim F_attach As String
Dim O As Outlook.Application
Dim M As Outlook.MailItem
Dim DT As String
DT = Forms!Form1!frmCheckDt
Dim strSQL As String
strSQL = "SELECT * FROM qryMailList Where send_checkdt=" & DT
Dim dbs As DAO.Database
Dim Mlist As DAO.Recordset
'Dim Mfiltered As DAO.Recordset
Set dbs = CurrentDb
Set Mlist = dbs.OpenRecordset(strSQL, dbOpenDynaset)
Set O = New Outlook.Application
Set M = O.CreateItem(olMailItem)
Mlist.MoveFirst
Do Until Mlist.EOF
Msg = "Dear " & Mail_FullName & "," & vbCrLf & vbCrLf & _
"Your payroll check number " & Send_CheckNo & " was deposited on " & _
send_checkdt & " for " & Format(Send_NetPay, "Currency") & "." & vbCrLf & vbCrLf & _
"Sincerely," & vbCrLf & Send_CoName
F_attach = "f:\archives\CK" & Mail_emp & "_" & Send_CheckNo & ".pdf"
With M
.BodyFormat = olFormatPlain
.Body = Msg
.To = Mail_Email
.Subject = "Direct Deposit " & send_checkdt
' .Attachments.Add F_attach
.Display
End With
Mlist.MoveNext
Loop
DoCmd.Close
Set M = Nothing
Set O = Nothing
Set Mlist = Nothing
Set dbs = Nothing
Set qdf = Nothing
Set Mfiltered = Nothing
End Sub
I moved
set O=New Outlook.Application and
set M=O.CreateItem(olMailItem)
to be below
Do Until Mlist.EOF and it works correctly.
I also had to further identify my data fields by adding Mlist! to each. Without identifying Mlist it prodcued the correct number of emails but no data was filled in. Thank you to everyone that offered comments.

"RUN-TIME error '3085' Undefined Function 'EMAIL' in expression"

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 keep getting error 3061 Too few parameters. Expected 1

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

Send multiple records from MS Access to MS Outlook body

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

VBA - Change Outlook Subject Line on Receipt Of Email

I have written a script that's intended behaviour is supposed to change the Subject Line of a received email.
This is because a Third Party Program monitors an Outlook Folder and posts it to a Virtual Cabinet based on the Subject line being a certain fashion.
I have written the code below that all changes out OK however the Subject Line does not get changed - can anyone shed any light on this at all?
Sub AmendSubject(myItem As Outlook.MailItem)
Dim strBranch As String
Dim strPolRef As String
Dim strTo As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rsSQL As String
Dim strSubject As String
Set cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
'Places the Customer Email Address in a string
strTo = myItem.To
strTo = Replace(strTo, "'", "")
cnn.Open "Provider=SQLOLEDB;Data Source=my-srv;Initial Catalog=DB;User ID=xxxx;Password=xyz;"
'SQL Statement
rsSQL = "SELECT TOP 1 [c].[B#] AS [Branch], p.[PolRef#] AS [Ref] FROM [dbo].[ic_yyclient] AS c" & _
" INNER JOIN [dbo].[ic_brpolicy] AS p ON [c].[B#] = [p].[B#] AND [c].[Ref#] = [p].[Ref#]" & _
" LEFT OUTER JOIN [dbo].[ic_BD_ATS1] AS ats1 ON [p].[B#] = [ats1].[B#] AND [p].[PolRef#] = [ats1].[PolRef#]" & _
" WHERE [Ptype] IN ('PC','TW') AND (c.[Email] = '" & strTo & "' OR ats1.[Email] = '" & strTo & "' OR ats1.[Parents_email] = '" & strTo & "') AND [Term_code] IS NULL" & _
" ORDER BY [ats1].[PolRef#] desc"
Debug.Print rsSQL
rs.Open rsSQL, cnn, adOpenForwardOnly
With rs
While Not .EOF
strBranch = !Branch
strPolRef = !Ref
.MoveNext
Wend
End With
strSubject = "REF: 0" & strBranch & "-" & strPolRef & "-C<Email To Client>NB Documentation Email"
myItem.Subject = strSubject
myItem.Save
rs.Close
Set rs = Nothing
Set cnn = Nothing
End Sub