Solved: Outlook attachement stripper

[Sean]

Hello,

I am attempting to create an attachment stripper to grab an attachment of a specific type (csv) when it comes into the inbox and then move it to a server location.

I grabbed and hacked at the below code from couple of websites (both exerpts of Sue Mosher's books) however it does not specifically meet my needs as it grabs all the previous email attachments yet does not grab the incoming email attachment which triggered the event. (I want this to be performed as a rule: which has an attachment do this script)

Please review and let me know where the issue is:

Sub Application_NewMail(Item As Outlook.MailItem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Path where documents will be stored
strFolderpath = "server-location"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
'MsgBox strFolderpath
' Check each selected item for attachments.
' If attachments exist, save them to the Temp
' folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

'MsgBox objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for
' removing items from a collection. Otherwise,
' the loop counter gets confused and only every
' other item is removed.
For i = lngCount To 1 Step -1
'We need to check attachemnt extension to grab only the desired file type.
'to change the type of files grabbed to another file type change the
'"csv" to the apprpriate extention
'if it is desire to catch all the attachments just comment out
'the below if statement and related end if statement
If Right( objAttachments.Item(i).FileName, 3) = "csv" Then
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
End If
'MsgBox strDeletedFiles
Next i

' End If
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = objMsg.Body & vbCrLf & _
"The file(s) were saved to " & strDeletedFiles
Else
objMsg.HTMLBody = objMsg.HTMLBody & "<p>" & _
"The file(s) were saved to " & strDeletedFiles
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Thank You

[Sean]

please ignore the spelling of attachment in subject line :ack:

[Charlize]

Maybe take a look at this thread to get an idea for saving attachments : http://www.vbaexpress.com/forum/showthread.php?t=12901&highlight=new+mail

[Charlize]

Take a look at this try out from me. You still have to deal with the security message from outlook (2003). The code has to be run by using a rule. Every new message with attachment and then perform this script. Hope you like it.Option Explicit
Option Compare Text
Sub SaveAttachmentRule(Item As Outlook.MailItem)
Dim att As Outlook.Attachment
Dim strPath As String
Dim i As Long
'Place to save the attachments
strPath = "C:\Data\Bijlagen\"
i = CountFiles(strPath)
' loop through each attachment
For Each att In Item.Attachments
'Check if file is doc or xls
'if it is, extract file from message and save
'and write extra info to message.
If UCase(Right(att.FileName, 3)) = "DOC" Or _
UCase(Right(att.FileName, 3)) = "XLS" Then
i = i + 1
att.SaveAsFile Left(strPath & i & " - " & _
ArrangedDate(Item.ReceivedTime) & _
" - " & Item.SenderName & " - " & att.FileName, 255)
'check for html mail or not
If Item.BodyFormat <> olFormatHTML Then
Item.Body = Item.Body & vbCrLf & _
"The file was saved to : " & Left(strPath & i & " - " & _
ArrangedDate(Item.ReceivedTime) & _
" - " & Item.SenderName & " - " & att.FileName, 255) & vbCrLf
Else
Item.HTMLBody = Item.HTMLBody & "<p>" & _
"The file was saved to : " & Left(strPath & i & " - " & _
ArrangedDate(Item.ReceivedTime) & _
" - " & Item.SenderName & " - " & att.FileName, 255) & "<p>"
End If
End If
Next att
recheck:
For Each att In Item.Attachments
If UCase(Right(att.FileName, 3)) = "DOC" Or _
UCase(Right(att.FileName, 3)) = "XLS" Then
att.Delete
'Normally I don't prefer goto but I have to start
'over with the checking of the attachments when
'I remove one from the message. Otherwise the process
'of removing doesn't work like expected.
GoTo recheck
End If
Next att
Item.Save
End Sub
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
Function ArrangedDate(StrDateInput)
'format the date to the desired format
Dim RegX As Object
Dim avDate() As String
Dim avTime() As String
Dim vDate As String
Dim StrDateTime As String

Set RegX = CreateObject("vbscript.regexp")

ReDim Preserve avDate(3)
ReDim Preserve avTime(2)

avDate = Split(StrDateInput, "/")
avTime = Split(StrDateInput, " ")

StrDateTime = avDate(0) & "_" & avDate(1) & "_" & _
Left(avDate(2), 4) & "-" & avTime(1)
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:

Set RegX = Nothing
End Function

[Charlize]

A new version that deals with the security issue. You have to install the freeware utility ExpressClick Yes. This utility initially starts in the suspend mode (leave it that way). The status of this utility is changed in the coding so messages can be processed. If another program want's to do something, you still get that security warning (difference is that this time it will not be clicked away). Let me know if this suits your needs.Option Explicit
Option Compare Text
' Declare Windows' API functions
' To be used with ExpressClick Yes
Private Declare Function RegisterWindowMessage _
Lib "user32" Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
'These are used by the utility ClickYes Freeware
Public wnd As Long
Public uClickYes As Long
Public Res As Long
Sub SaveAttachmentRule(myItem As Outlook.MailItem)
Dim att As Outlook.Attachment
Dim strPath As String
Dim i As Long
' This is for the ClickYes utility
'Dim wnd As Long -> public to be used in other modules
'Dim uClickYes As Long -> public to be used in other modules
'Dim Res As Long -> public to be used in other modules
'*** Made two seperated subs for preparing the click routine
'*** and actually perform the click and to set the utility
'*** back in suspend mode so other malware can't do something
' Register a message to send
'uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
' Find ClickYes Window by classname
'wnd = FindWindow("EXCLICKYES_WND", 0&)
' Send the message to Resume ClickYes
'Res = SendMessage(wnd, uClickYes, 1, 0)
'Place to save the attachments
strPath = "C:\Data\Bijlagen\"
i = CountFiles(strPath)
' loop through each attachment
For Each att In myItem.Attachments
'Check if file is doc or xls
'if it is, extract file from message and save
'and write extra info to message.
If UCase(Right(att.FileName, 3)) = "DOC" Or _
UCase(Right(att.FileName, 3)) = "XLS" Then
Call PrepareClickYes
i = i + 1
att.SaveAsFile Left(strPath & i & " - " & _
ArrangedDate(myItem.ReceivedTime) & _
" - " & myItem.SenderName & " - " & att.FileName, 255)
Call PerformClickYes
'check for html mail or not
Call PrepareClickYes
If myItem.BodyFormat <> olFormatHTML Then
myItem.Body = myItem.Body & vbCrLf & _
"The file was saved to : " & Left(strPath & i & " - " & _
ArrangedDate(myItem.ReceivedTime) & _
" - " & myItem.SenderName & " - " & att.FileName, 255) & vbCrLf
Else
myItem.HTMLBody = myItem.HTMLBody & "<p>" & _
"The file was saved to : " & Left(strPath & i & " - " & _
ArrangedDate(myItem.ReceivedTime) & _
" - " & myItem.SenderName & " - " & att.FileName, 255) & "<p>"
End If
Call PerformClickYes
End If
Next att
recheck:
For Each att In myItem.Attachments
If UCase(Right(att.FileName, 3)) = "DOC" Or _
UCase(Right(att.FileName, 3)) = "XLS" Then
Call PrepareClickYes
att.Delete
'Normally I don't prefer goto but I have to start
'over with the checking of the attachments when
'I remove one from the message. Otherwise the process
'of removing doesn't work like expected.
Call PerformClickYes
GoTo recheck
End If
Next att
myItem.Save
End Sub
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
Function ArrangedDate(StrDateInput)
'format the date to the desired format
Dim RegX As Object
Dim avDate() As String
Dim avTime() As String
Dim vDate As String
Dim StrDateTime As String

Set RegX = CreateObject("vbscript.regexp")

ReDim Preserve avDate(3)
ReDim Preserve avTime(2)

avDate = Split(StrDateInput, "/")
avTime = Split(StrDateInput, " ")

StrDateTime = avDate(0) & "_" & avDate(1) & "_" & _
Left(avDate(2), 4) & "-" & avTime(1)
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:

Set RegX = Nothing
End Function
Sub PrepareClickYes()
'called before attempting to manipulate a message
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 1, 0)
End Sub
Sub PerformClickYes()
'called directly after the code that manipulates
'a message. Clicks the yes and places the ClickYes utility
'back in suspend mode. When some other routine (that's not
'controlled by you) wants to do something with your
'messages, you still get that warning.
Res = SendMessage(wnd, uClickYes, 0, 0)
End Sub

[Charlize]

Update for the ExpressClick Yes thing. There is no need for multiple calls. When you do the first PrepareClickYes ... some code ... PerformClickYes it is most likely sufficent to process the incoming message (1 minute - I think) (unless there are a lot of attachments of course).

I have tested this on a win xp with outlook 2003 and it works fine.

[slhannah]

I am trying to use the script below, in Outlook 2007, SP1, to copy csv attachments from a specified mailbox subfolder
mailbox...inbox....temp
to
H:\TCIM\reports\temp\

Option Explicit
Option Compare Text
'Created by : Charlize
'Revised by : Oorang
' Rewrote a call and jump loop to a Do Until Loop
' Instead of the original if's for the
' attachments, he came up with an array
' of file extensions (pretty slick)
'Rerevised by : Charlize
'Submitted by : Charlize
'Date : 2007-10-11 (11 oct 2007)
'Purpose : strip doc and xls attachments from
' mails to reduce mailbox size
' Save them to a specified folder and
' put a notification in the mail where
' the file was saved to.

Public Sub TestAttachmentRule()
Const lngNoAttchmt_c As Long = 0
Dim ns As Outlook.NameSpace
Dim mFldr As Outlook.MAPIFolder
Dim itm As Object
Dim mlItm As Outlook.MailItem
Set ns = Outlook.Application.Session
Set mFldr = ns.GetDefaultFolder(olFolderTemp)
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 temp folder.", vbInformation
End Sub

Public Sub SaveAttachmentRule(myItem As Outlook.MailItem, ParamArray _
PreferredFileExts() As Variant)
'Place to save the attachments
Const strRootFolder_c As String = "H:\TCIM\Reports\Temp\"
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 lngIneligibleFiles As Long
Dim att As Outlook.Attachment
Dim lngAttchmnetCnt As Long
Dim strFilePath As String
Dim lngPFUprBnd As Long
Dim lngPFIndex As Long
Dim strFileName As String
'index of attachment in mailmessage
Dim lngItmAtt As Long
lngPFUprBnd = UBound(PreferredFileExts)
lngAttchmnetCnt = CountFiles(strRootFolder_c)
'Loop through each attachment:
lngItmAtt = lngIncrement_c 'start with number one
Do Until myItem.Attachments.Count = 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 _
Outlook.MailItem, ByRef attchmnt 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
'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 & attchmnt.FileName, lngMxFlNmLen_c)
End Function

Getting the followin error:

Varible not found in Public Sub TestAttachmentRule ()

set mFldr = ns.GetDefaultFolder(olFolderTemp)

Help?

[Charlize]

Is that the original coding from us ? I think not. When using the variable 'getdefaultfolder' you have to specify the folders that come with outlook (ie. inbox, contacts, tasks, ...).

If foldertemp is a subfolder of the defaultfolder inbox you need to dim another mapifolder and use this variable.

Dim ns As Outlook.NameSpace
Dim mFldr As Outlook.MAPIFolder
Dim itm As Object
Dim mlItm As Outlook.MailItem
Dim myfolder as Outlook.MAPIfolder
Set ns = Outlook.Application.Session
Set mFldr = ns.GetDefaultFolder(olInboxFolder)
'or Set mFldr = ns.GetDefaultFolder(olFolderInbox)
'haven't got outlook at the moment for checking on the exact code info
'your folder has the name 'olFolderTemp' ? or just 'Temp' ?
Set myfolder = mFldr.Folders("olFolderTemp")
For Each itm In myfolder.Items
and this line SaveAttachmentRule mlItm, ".doc", ".xls"
needs to be changed inSaveAttachmentRule mlItm, ".csv"
if you want to check on csv files.

Charlize

[slhannah]

I have looked at so many scripts today through this site, I may have gotten them mixed up... I think I may also be using a script that is for 2003, and not Office 2007... I am very new at VB so bear with me...
I have an app that sends emails that are being moved to a folder...
each email contains one or more csv attachments...
would like to copy this attachments off to hard drive, so others can view..any help appreciated...
didn't you do a script to do this??