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