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

来源：https://stackoverflow.com/questions/22966209/vba-change-outlook-subject-line-on-receipt-of-email

标签

vba

outlook

ado