VBA Code to Delete an Email After it is Processed by VBA

[robboll]

The following code is a hybrid from several internet sources. Mostly
from this forum.

I have an application that starts an email thread and assigns a Task
ID like: TID(123) This is the Subject

When an email is received with "TID(###)" somewhere in the subject, a
native rule then copies it to a subfolder under the CurrentFolder
called 'TID'.

The following code works to copy the email in msg format to its
associated network directory, but the email remains in the
subfolders.

What I am trying to accomplish is to automatically delete the email
after it is processed by VBA.
Is there a simple method of doing this?


Sub CopyEmailToProjectFolder()
Dim OL As Application
Dim NmeSpace As NameSpace
Dim strConnection
Dim mTID

Set OL = CreateObject("Outlook.Application")
Set NmeSpace = OL.GetNamespace("MAPI")
Set Inbx = NmeSpace.GetDefaultFolder(6)
Set fldr = Application.ActiveExplorer.CurrentFolder.Folders("TID")
For Each itm In fldr.Items
subtxt = Trim(itm.Subject)

'SubTxt = CleanString(SubTxt) 'removes characters that cannot be
part of filename
subtxt = Replace(subtxt, "_", "")
subtxt = Replace(subtxt, "??", "'")
subtxt = Replace(subtxt, "`", "'")
subtxt = Replace(subtxt, "{", "(")
subtxt = Replace(subtxt, "[", "(")
subtxt = Replace(subtxt, "]", ")")
subtxt = Replace(subtxt, "}", ")")
subtxt = Replace(subtxt, "/", "-")
subtxt = Replace(subtxt, "\", "-")
subtxt = Replace(subtxt, ":", "")
subtxt = Replace(subtxt, ",", "")
'Cut out invalid signs.
subtxt = Replace(subtxt, "*", "'")
subtxt = Replace(subtxt, "?", "")
subtxt = Replace(subtxt, """", "'")
subtxt = Replace(subtxt, "<", "")
subtxt = Replace(subtxt, ">", "")
subtxt = Replace(subtxt, "|", "")
mTID = Mid(Mid(subtxt, InStr(1, subtxt, "TID(") + 4, 8), 1, InStr
(1, Mid(subtxt, InStr(1, subtxt, "TID(") + 4, 8), ")") - 1)

'====== SQL Connection String to Get full Directory Path from the
TID ============
Dim Connection
Dim ConnString
Dim Recordset
Dim SQL
Dim mTopic
Dim mPath

ConnString = "DRIVER={SQL
Server};Server=MyServer;Database=MyReport;Trusted_Connection=True;"

SQL = "SELECT [TopicID],[Path] FROM [MyReport].[dbo].[uvw_TIDPath]
WHERE rtrim([TopicID]) = " & mTID

Set Connection = CreateObject("ADODB.Connection")
Set Recordset = CreateObject("ADODB.Recordset")

Connection.Open ConnString
Recordset.Open SQL, Connection

If Recordset.EOF Then
Response.Write ("No records returned.")
Else
'if there are records then loop through the fields
Do While Not Recordset.EOF
mTopic = Recordset("TopicID")
mPath = Recordset("Path") & "\"
Recordset.MoveNext
Loop
End If

'close the connection and recordset objects to free up resources
Recordset.Close
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing

dirname = mPath

' fnme = DirName & subtxt & ".msg"
If itm.Class = olMail Then
itm.SaveAs fnme, olMSG
End If

'Save attachments if they exist in the item
If itm.Attachments.Count > 0 Then
For Each Attmt In itm.Attachments
fnme = dirname & Attmt.DisplayName
On Error Resume Next
x = Dir(fnme) 'Check if file exists
If x = "" Then
Attmt.SaveAsFile fnme
End If
Next
End If

Next
End Sub

 

[Bob Bollinger]

Found my own solution:
simply put: itm.Delete after the last End If

Cheers!

 

[Bob Bollinger]

Grrrrr! This doesn't work all the time!!! Have no idea why. Each itm is deleted according to the code!

 

[ROBBOLL]

Grrrrrr! Doesn't work every time. Is there a way to force a delete after
processing?

 

[Ken Slovak - [MVP - Outlook]]

Programming questions should be posted to the programming groups. You might
try microsoft.public.outlook.program_vba.