VBA in ItemSend causes duplicate emails

[travisdh]

Hi All,

I have a three part question, the first is that I am using the code below to look for CV, or CN in the subject, and where it detects it, it will extract the first eight characters (including the CV or CN) and create a folder in public folders with that code, the idea is that all emails both sent and received are put into that folder to keep a per project history going.

I am having a few issues though, the first is that when the code is run it creates a copy of the email and moves it, which is fine but there is always one spare email left in the outbox even after the email is sent. How can i go about moving this or deleting this spare email so there is one in the normal sent, and another in the public folder project folder.

The second question is, with the below the emails tend to be put into the project folder, but are marked as not sent. Is there any way i can have them be sent first, then moved so they are accurate in that they are marked as being sent?

The final question, which i hope is an easy one, is the structure of the code I am looking for is generally CV (or CN) then YY then MM then ID all in numbers, is there a way i can use a regex string to get the CVxxxxxx where xxxxxx are all numbers? this would be more accurate as at the moment if ever CV or CN is detected it will extract eight characters, however it would be nice to only work if CV or CNxxxxxx is detected, then only extract that to have better error handling.

Thanks!



Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Subject As String
Dim openingParen As String
Dim closingParen As String
Dim enclosedValue As String
Dim profolder As Outlook.folder
Dim itm As Object
Set ObjCopy = Item.Copy
Subject = Item.Subject

If InStr(1, Item.Subject, "CV", vbTextCompare) > 0 Then
Prefix = "CV"
MoveEmail "CV", Subject

ElseIf InStr(1, Item.Subject, "CN", vbTextCompare) > 0 Then
Prefix = "CN"
MoveEmail "CN", Subject

Else
Cancel = False

End If



End Sub


Private Sub MoveEmail(Prefix As String, Subject As String)
openingParen = InStr(Subject, Prefix)
closingParen = InStr(Subject, "]")
enclosedValue = Mid(Subject, openingParen, 8)
TestGetFolder (enclosedValue)
Set folder = GetFolder("\\Public Folders\All Public Folders\Projects\" & enclosedValue)
ObjCopy.Move folder

End Sub

[travisdh]

These are the missing functions:

Function GetFolder(ByVal FolderPath As String) As Outlook.folder
Dim TestFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolder_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TestFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TestFolder.Folders
Set TestFolder = SubFolders.Item(FoldersArray(i))
If TestFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TestFolder
Set GetFolder = TestFolder
Exit Function

GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function

Sub TestGetFolder(ByVal ProjectFolder As String)
Dim folder As Outlook.folder
Set folder = GetFolder("\\Public Folders\All Public Folders\Projects\" & ProjectFolder)
If Not (folder Is Nothing) Then
ElseIf (folder Is Nothing) Then
Set folder = GetFolder("\\Public Folders\All Public Folders\Projects")
folder.Folders.Add (ProjectFolder)
End If
End Sub

[Crocus Crow]

Using SaveSentMessageFolder instead of Copy and Move should fix the first two problems.

For the regex, have a look at my code in this thread (which is very similar to your request) - http://www.vbaexpress.com/forum/showthread.php?t=43312. It contains a function which returns the matching part of a text string. Just change the pattern argument in the caller to "((?:CN|CV)\d{6})".