Save outlook attachments and delete from inbox

[Tempest]

Morning all - relatively new to VBA and very new to outlook vba

I ripped off some code and slightly modified (size >1.5mb and any attachment type) from this site already from Charlize

But it falls over at myItem.Save with run time error "The function cannot be performed because the message has been changed."

Is this incurable? I've seem similar posts on the web wrt blackberry's with copy and paste which defeats the purpose of managing large attachments

Cheers, Tempest

[JP2112]

Post your code so we can debug it.

[Tempest]

Fair call...

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'************************************************************************** *
'Paste in ThisOutlookSession
'************************************************************************** *
SaveAttachmentRule Application.Session.GetItemFromID(EntryIDCollection)


End Sub


Public Sub TestAttachmentRule()
Const lngNoAttchmt_c As Long = 0
Dim ns As NameSpace
Dim mFldr As MAPIFolder
Dim itm As Object
Dim mlItm As MailItem
Set ns = Outlook.Application.Session
Set mFldr = ns.GetDefaultFolder(olFolderInbox)
For Each itm In mFldr.Items
If itm.Class = olMail Then
Set mlItm = itm
If mlItm.Attachments.Count <> lngNoAttchmt_c Then
SaveAttachmentRule mlItm, ".doc", ".xls"
End If
End If
Next
MsgBox "Doc and Xls files are extracted from" & vbCrLf & _
"the emails in inbox folder.", vbInformation
End Sub

Public Sub SaveAttachmentRule(myItem As MailItem, ParamArray PreferredFileExts() As Variant)


'Place to save the attachments
Const strRootFolder_c As String = "C:\attachments\"
Const strStockMsg_c As String = "The file was saved to: "
Const strHTMLPTag_c As String = "<p>"
Const lngPFLwrBnd As Long = 0
Const lngIncrement_c As Long = 1

Dim att As Attachment

Dim lngIneligibleFiles As Long
Dim lngPFUprBnd As Long
Dim lngPFIndex As Long
Dim lngAttchmnetCnt As Long
Dim lngItmAtt As Long 'index of attachment in mailmessage

Dim strFilePath As String
Dim strFileName As String


If myItem.Size < 1500000 Then
Exit Sub
End If

' lngPFUprBnd = UBound(PreferredFileExts)


lngAttchmnetCnt = CountFiles(strRootFolder_c)
'Loop through each attachment:
lngItmAtt = lngIncrement_c 'start with number one

Do Until myItem.Attachments.Count = 0 'lngIneligibleFiles
Set att = myItem.Attachments(lngItmAtt)
'Check if file is preferred, if it is, extract file from message and
'save and write extra info to message.
strFileName = att.FileName

'For lngPFIndex = lngPFLwrBnd To lngPFUprBnd
' If LCase$(PreferredFileExts(lngPFIndex)) = LCase$(VBA.Right$(strFileName, VBA.Len(PreferredFileExts(lngPFIndex)))) Then
' Exit For
' End If
'Next

If lngPFIndex <= lngPFUprBnd Then

'Increment Attachment Count:
lngAttchmnetCnt = lngAttchmnetCnt + lngIncrement_c

'Build file-name for "to be saved" attachment:
strFilePath = strRootFolder_c & BuildFileName(lngAttchmnetCnt, _
myItem, att)

'Save attachment to pre-determined folder using standard naming
'convention.
att.SaveAsFile strFilePath
'Check for html mail or not:


If myItem.BodyFormat = olFormatHTML Then
myItem.HTMLBody = myItem.HTMLBody & strHTMLPTag_c & _
strStockMsg_c & strFilePath & strHTMLPTag_c
Else
myItem.Body = myItem.Body & vbCrLf & strStockMsg_c & _
strFilePath & vbNewLine
End If

att.Delete

Else
lngIneligibleFiles = lngIneligibleFiles + lngIncrement_c
lngItmAtt = lngItmAtt + lngIncrement_c
End If
Loop
If Not myItem.Saved Then

myItem.Save

End If
End Sub

Private Function CountFiles(strPath As String) As Integer
'Counts the no of files in a directory
Dim FSO As Object
Dim fldr As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fldr = FSO.GetFolder(strPath)
CountFiles = fldr.Files.Count
Set fldr = Nothing
Set FSO = Nothing
End Function

Private Function BuildFileName(ByRef number As Long, ByRef mlItem As MailItem, ByRef att As Attachment, _
Optional dateFormat As String = "m_d_yyyy-H-MM-SS") As String
'Builds file name to preferred format. Can be changed to personal
'prefernce.
Const strInfoDlmtr_c As String = " - "
Const lngMxFlNmLen_c As Long = 255
BuildFileName = VBA.Left$(number & strInfoDlmtr_c & _
Format$(mlItem.ReceivedTime, dateFormat) & strInfoDlmtr_c & _
mlItem.SenderName & strInfoDlmtr_c & att.FileName, lngMxFlNmLen_c)
End Function

[JP2112]

This worked for me. Note that I'm using the ItemAdd Event, rather than NewMailEx. It will fire whenever new items are added to the Inbox, either as new incoming mail, or a message you drag and drop into the folder.

The only issue I had was with the HTMLBody property, this is a protected property and I wasn't able to work around the object model guard. I even tried deriving the mailitem from the Application object using its Entry ID (per http://www.outlookcode.com/archive0/d/sec.htm).

Private WithEvents Items As Outlook.Items 
Private Sub Application_Startup() 
    Dim objns As Outlook.NameSpace 
    Set objns = GetNamespace("MAPI") 
    Set Items = objns.GetDefaultFolder(olFolderInbox).Items 
End Sub 
Private Sub Items_ItemAdd(ByVal item As Object) 
    On Error Goto ErrorHandler 
    Const folder As String = "C:\attachments\" 
    Const fileExtensions As String = "doc,xls" 
    Dim fileExts As Variant 
    Dim Msg As Outlook.MailItem 
    Dim atts As Outlook.Attachments 
    Dim att As Outlook.Attachment 
    Dim i As Long, j As Long 
    Dim strFilePath As String 
     ' parse file extensions
    fileExts = Split(fileExtensions, ",") 
     ' only act on mail items
    If TypeName(item) <> "MailItem" Then Goto ProgramExit 
    Set Msg = item 
     ' exit if message is too small or no attachments
    If (Msg.Size < 1500000) And (Msg.Attachments.Count = 0) Then Goto ProgramExit 
    Set atts = Msg.Attachments 
     ' loop through attachments, if the file extension matches one of the
     ' specified file types, save it to the given folder
    With atts 
        For i = .Count To 1 Step -1 
            If UBound(Filter(fileExts, GetFileType(.item(i).fileName))) > -1 Then 
                strFilePath = folder & BuildFileName(.Count, Msg, .item(i)) 
                With .item(i) 
                    .SaveAsFile strFilePath 
                    .Delete 
                End With 
                If Msg.BodyFormat = olFormatHTML Then 
                    Msg.HTMLBody = Msg.HTMLBody & "<p>" & _ 
                    "The file was saved to: " & strFilePath & "</p>" 
                Else 
                    Msg.Body = Msg.Body & vbCrLf & "The file was saved to: " & strFilePath & vbCrLf 
                End If 
            End If 
        Next i 
    End With 
    Msg.Save 
    MsgBox "Doc and Xls files are extracted from" & vbCrLf & _ 
    "the emails in inbox folder.", vbInformation 
ProgramExit: 
    Exit Sub 
ErrorHandler: 
    MsgBox Err.number & " - " & Err.Description 
    Resume ProgramExit 
End Sub 
Function GetFileType(ByVal fileName As String) As String 
     ' get file extension
    GetFileType = Mid$(fileName, InStrRev(fileName, ".") + 1, Len(fileName)) 
End Function 
Private Function BuildFileName(ByRef number As Long, ByRef mlItem As Outlook.MailItem, ByRef att As Outlook.Attachment, _ 
    Optional dateFormat As String = "m_d_yyyy-H-MM-SS") As String 
     'Builds file name to preferred format. Can be changed to personal
     'preference.
    Const strInfoDlmtr_c As String = " - " 
    Const lngMxFlNmLen_c As Long = 255 
    BuildFileName = VBA.Left$(number & strInfoDlmtr_c & _ 
    Format$(mlItem.ReceivedTime, dateFormat) & strInfoDlmtr_c & _ 
    mlItem.senderName & strInfoDlmtr_c & att.fileName, lngMxFlNmLen_c) 
End Function 

VBA tags courtesy of www.thecodenet.com

[Tempest]

Ok this works! I changed it again and then use rules to run a script when I receive an "email with an attachment". Works like a treat.

Thanks JP2112


Sub Application_Startup()

Dim objns As Outlook.NameSpace
Set objns = GetNamespace("MAPI")
Set Items = objns.GetDefaultFolder(olFolderInbox).Items
End Sub


Sub Items_ItemAdd(item As MailItem)
On Error GoTo ErrorHandler
Const folder As String = "C:\attachments\"
Const fileExtensions As String = "doc,xls"
Dim fileExts As Variant
Dim Msg As Outlook.MailItem
Dim atts As Outlook.Attachments
Dim att As Outlook.Attachment
Dim i As Long, j As Long
Dim strFilePath As String
' parse file extensions
fileExts = Split(fileExtensions, ",")
' only act on mail items
' If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
' exit if message is too small or no attachments
If (Msg.Size < 1500000) And (Msg.Attachments.Count = 0) Then GoTo ProgramExit
Set atts = Msg.Attachments
' loop through attachments, if the file extension matches one of the
' specified file types, save it to the given folder
With atts
For i = .Count To 1 Step -1
If UBound(Filter(fileExts, GetFileType(.item(i).fileName))) > -1 Then
strFilePath = folder & BuildFileName(.Count, Msg, .item(i))
With .item(i)
.SaveAsFile strFilePath
.Delete
End With
If Msg.BodyFormat = olFormatHTML Then
Msg.HTMLBody = Msg.HTMLBody & "<p>" & _
"The file was saved to: " & strFilePath & "</p>"
Else
Msg.Body = Msg.Body & vbCrLf & "The file was saved to: " & strFilePath & vbCrLf
End If
End If
Next i
End With
Msg.Save
' MsgBox "Doc and Xls files are extracted from" & vbCrLf & _
'"the emails in inbox folder.", vbInformation
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetFileType(ByVal fileName As String) As String
' get file extension
GetFileType = Mid$(fileName, InStrRev(fileName, ".") + 1, Len(fileName))
End Function
Private Function BuildFileName(ByRef number As Long, ByRef mlItem As Outlook.MailItem, ByRef att As Outlook.Attachment, _
Optional dateFormat As String = "m_d_yyyy-H-MM-SS") As String
'Builds file name to preferred format. Can be changed to personal
'preference.
Const strInfoDlmtr_c As String = " - "
Const lngMxFlNmLen_c As Long = 255
BuildFileName = VBA.Left$(number & strInfoDlmtr_c & _
Format$(mlItem.ReceivedTime, dateFormat) & strInfoDlmtr_c & _
mlItem.SenderName & strInfoDlmtr_c & att.fileName, lngMxFlNmLen_c)
End Function

[JP2112]

Glad to hear it!

[Tempest]

Does anyone have any thoughts on turning the file path into a hyerlink?