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

  • Thread starter Thread starter robboll
  • Start date Start date
R

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
 
Grrrrr! This doesn't work all the time!!! Have no idea why. Each itm is deleted according to the code!
 
Grrrrrr! Doesn't work every time. Is there a way to force a delete after
processing?
 
Programming questions should be posted to the programming groups. You might
try microsoft.public.outlook.program_vba.
 
Back
Top