-
May 11th, 2017, 11:53 AM
#1
Thread Starter
New Member
[RESOLVED] [Outlook 2007] Macro not working with IPM.POST
Good Afternoon,
I am using a macro on a public folder for a department at my company. The macro is intended to strip the attachments from a message, save the attachments in a specific location, and provide a link to the location inside the body of the message. I am having a few issues that I cannot resolve on my own. I've scoured the internet before posting here, so I'm hoping that my request is even possible.
1) I cannot figure out how to separate the links when the link is posted into the body of the message. When a mail item has one attachment, the link works fine. However when the mail item has multiple attachments, all the folder locations are entered into the message as one long path (Example: The file(s) were saved to I:\Parts Dept\Email Retention\OLAttachments\Bill George.2017-05-08 13-36-46.0471843-DM.pdfI:\Parts Dept\Email Retention\OLAttachments\Bill George.2017-05-08 13-36-46.0471843.pdfI:\Parts Dept\Email Retention\OLAttachments\Bill George.2017-05-08 13-36-46.image001.jpg).
2) As I stated, I am using this in a public folder. This macro is working when used on regular messages in the public folder, however the majority of the items in the folder are actually postings (IPM.Post). The macro fails when being ran on any of the posts. This is the only reason I can find for why the macro is not working, but I'm not sure how to fix it and internet searches have been unsuccessful.
3) This macro was working successfully on mail messages, but when I tried running it about an hour or so later, it gave a "Compile Error: Variable not defined." for the "invalidChars" in the macro. I'm not sure why this suddenly stopped working.
Any assistance with this would be greatly appreciated! I have posted the macro below. (FYI - This was not originally created by me. I have limited exposure to VBA (mostly excel) so I have only made a few changes such as folder path.)
Code:
Public Sub StripAttachments_Explorer()
'This VBA Macro removes attachments from whatever emails are selected
'in the Outlook explorer window and stores them on the hard drive. Links
'to the stored files are added to the email. Note that RTF and PlainText
'messages are converted to HTML. The hooks are still below if you want to
'uncomment those line and handle text messages separately.
'Tested with Outlook 2003 only.
'v1.3, Carl C, 22-Feb-09
'http://manage-this.com
'
On Error GoTo ErrorHandler
'
'Edit this path to point to the root for your archive. This
'folder must already exist before for you start using this tool.
'Choose a root folder that is easy to remember for restoring
'message attachments later since the message bodies will be
'written with hard links to this location.
Const RootFolder = "I:\Service\Dan Emanuelson\Email Retention\2017\"
'
'Threshold message size (in kilobytes) - Messages smaller than this get skipped.
Const THRESH As Long = 50 'kb
'
Dim olns As Outlook.NameSpace
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelectedItems As Outlook.Selection
Dim i, J, Counter As Integer
Dim msgFormat As Long
Dim Header, FileList, Footer As String
Dim attPath, attFileName, msgFolder, msgSender, msgSubject, yearFolder, temp As String
Dim oleFound, dropSubject As Boolean
'
Set olns = Application.GetNamespace("MAPI")
'
Set objSelectedItems = olns.Application.ActiveExplorer.Selection
'
'Make sure base path exists
If Dir(RootFolder, vbDirectory) = "" Then
MsgBox "Root Folder Not Found!" & vbCrLf & _
"Please create the following folder first: " & vbCrLf & RootFolder
GoTo ExitSub
End If
'
For Each objMsg In objSelectedItems
'
' Skip anything that's not a mail message (calendar items, tasks, etc.)
If objMsg.Class = olMail Then
'
Set objAttachments = objMsg.Attachments
Counter = objAttachments.Count
'
'Only execute if there is at least one attachment in the message
If Counter > 0 Then
'
'Check if the attachments have already been removed - if so, don't do it again
If objAttachments.Item(1).Type <> olOLE Then
If (objAttachments.Item(1).FileName = "Attachments Removed") _
And (Counter = 1) Then
GoTo TheNextMessage
End If
End If
'
'If the current message is fairly small, then skip it. It likely containts only
'tiny pics in the signature or a background image. No point in stripping those.
'Note - It would be better to check the size of each attachment, but there is no
'clean way to do this in Outlook 2003. Would require PR_ATTACH_SIZE (0x0E200003)
'property of the attachment... See http://www.cdolive.com/cdo10.htm
If (objMsg.Size < (1024 * THRESH)) Then
GoTo TheNextMessage
End If
'
'Check to see if any of the attachments are OLE format. If so, skip the
'entire message since stripping these is messy
oleFound = False
For i = objAttachments.Count To 1 Step -1
If objAttachments.Item(i).Type = olOLE Then
oleFound = True
Exit For
End If
Next i
If oleFound Then GoTo TheNextMessage
'
'Note - I disabled the year folder since it had to be checked for every
'message. Added it to the Root Path definition instead.
'
'Create the year folder if it doesn't already exist
'yearFolder = RootFolder & Strings.Format(objMsg.ReceivedTime, "yyyy") & "\\"
'If Dir(yearFolder, vbDirectory) = "" Then
' MkDir (yearFolder)
'End If
'
'Some of the dual-byte (DBCS) chars cause problems since the subject line is
'used in the file path name. If the message format does not belong to one of
'the formats below, then don't use the subject line in the path or file name.
dropSubject = False
msgFormat = objMsg.InternetCodepage
If ((msgFormat = 28592) Or (msgFormat = 1250) Or (msgFormat = 20127) _
Or (msgFormat = 28591) Or (msgFormat = 1252)) Then
msgSubject = objMsg.Subject
Else
msgSubject = "message"
dropSubject = True
End If
'
'Strip illegal chars from msgSubject
invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "…")
For J = LBound(invalidChars) To UBound(invalidChars)
temp = Replace(msgSubject, invalidChars(J), " ")
msgSubject = temp
temp = Replace(msgSubject, invalidChars(J), " ")
msgSubject = temp
Next J
msgSubject = Replace(msgSubject, "RE ", "")
msgSubject = Replace(msgSubject, "FW ", "")
msgSubject = Trim(msgSubject)
If objMsg.Subject = "" Then msgSubject = "no subject"
'
'Derive a short form of the Sender Name...
'If your company adds text to your display names then modify
'these lines to clean it out when creating the folder names
msgSender = Replace(objMsg.SenderName, " (YourCompanyName, consultant)", "")
msgSender = Replace(msgSender, " (YourCompanyName)", "")
'
'Create the Folder/Path name for the attachments
If (dropSubject) Then
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") & msgSender
Else
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") _
& msgSender & " - [" & msgSubject & "]"
End If
'msgFolder = yearFolder & msgFolder & "\\"
msgFolder = RootFolder & msgFolder & "\\"
'
'Create the message folder for the individual email attachments
If Dir(msgFolder, vbDirectory) = "" Then
MkDir (msgFolder)
End If
'
'Save text of message to the attachment folder for reference
objMsg.SaveAs msgFolder & msgSubject & ".txt", olTXT
'
'If objMsg.BodyFormat = olFormatPlain Then
' Header = "============================================================" _
' & vbCrLf & "Attachments Archived: " & "<file://" _
' & Replace(msgFolder, "\\", "\") & ">"
'Else
Header = "<font face=""Courier New"" size=2 color=#736F6E>" _
& "============================================================" _
& "<br><a HREF=""file://" & Replace(msgFolder, "\\", "\") _
& Chr(34) & ">Attachments Archived:</a>"
'End If
'
FileList = ""
'
'Walk through the attachment collection archiving each one
For i = objAttachments.Count To 1 Step -1
'
attFileName = objAttachments.Item(i).FileName
attPath = msgFolder & "\\" & attFileName
'
' Save the attachment to disk then remove it from the email
objAttachments.Item(i).SaveAsFile attPath
objAttachments.Item(i).Delete
'
' Build up list of links to stored files in FileList string
'If objMsg.BodyFormat = olFormatPlain Then
' FileList = vbCrLf & "[" & i & "] " & "<file://" _
' & Replace(attPath, "\\", "\") & ">" & FileList
'Else
FileList = "<br>" & "[" & i & "] " & "<a REL=ATT_LNK " _
& "HREF=""file://" & Replace(attPath, "\\", "\") _
& Chr(34) & ">" & attFileName & "</a>" & FileList
'Note - the REL=ATT_LNK is for a future enhancement to
'parse forwarded or re-sent messages and re-attach the files
'End If
'
Next i
'
' display log/links in the message body
'If objMsg.BodyFormat = olFormatPlain Then
' Footer = vbCrLf & _
' "============================================================" _
' & vbCrLf & vbCrLf
' objMsg.Body = Header & FileList & Footer & objMsg.Body
'Else
Footer = "<br>" & _
"============================================================" _
& "<br><br></font>"
objMsg.HTMLBody = Header & FileList & Footer & objMsg.HTMLBody
'End If
'
'Attach an empty file to trigger Outlook paperclip icon
'Note - you need to create this ahead of time and place it in a folder
'named "config" inside your root message folder. The file name must be
'as shown below with no .txt suffix
temp = RootFolder & "\\config\\Attachments Removed"
objAttachments.Add temp, olByValue, , "Attachments Removed"
'
objMsg.Save
'
End If 'If Counter > 0 Then
End If 'If objMsg.Class = olMail
'
TheNextMessage:
Next objMsg
'
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelectedItems = Nothing
Set olns = Nothing
Exit Sub
'
ErrorHandler:
MsgBox "RemoveAttachments( ) Subroutine" & vbCrLf & vbCrLf _
& "Error Code: " & Err.Number & vbCrLf & Err.Description
Err.Clear
GoTo ExitSub
End Sub
-
May 11th, 2017, 12:33 PM
#2
Re: [Outlook 2007] Macro not working with IPM.POST
For item #1, you need to add a vbCrLf between the file path/names for messages that have more than one attachment.
For item #2, you need to check on the Outlook item type, and have the macro process only those items with the correct type:
https://msdn.microsoft.com/en-us/lib.../ff861573.aspx
http://www.vbforums.com/showthread.p...tem-in-Mailbox
For item #3, you should add an 'Option Explicit' line to the beginning of your VBA code. That will catch all instances of variables that are not defined with 'Dim' statements.
Last edited by jdc2000; May 11th, 2017 at 01:09 PM.
-
May 11th, 2017, 04:35 PM
#3
Re: [Outlook 2007] Macro not working with IPM.POST
For item #3, you should add an 'Option Explicit' line to the beginning of your VBA code.
i guess it already is to generate the error, just add a line dim invalidchars as string, or add to the end of an existing dim line
note: where you have multiple variable dimensioned on the same line each must be typed separately
Dim Header, FileList, Footer As String
in this line only Footer is of type string, all others are variant, this may make no difference to the running of this code, but in some instances it will cause wrong results or error
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
May 19th, 2017, 11:09 AM
#4
Thread Starter
New Member
Re: [Outlook 2007] Macro not working with IPM.POST
Thank you for all the feedback. Using your suggestions I was able to correct 2 of the 3 issues I was having (issue #1 and issue #3). I am still having problems running this for IMP.Post messages though (issue #2). Here is what the code looks like now that I have updated it.
Code:
Option Explicit
Public Sub Strip_Attachments_Service_Department()
On Error GoTo ErrorHandler
'
'
'CHANGE THIS TO THE FOLDER YOU WANT TO SAVE THE FILES IN.
Const RootFolder = "I:\Service\Outlook Templates\Email Retention\2017\"
'
'
'MESSAGES BELOW THIS SIZE WILL BE SKIPPED.
Const THRESH As Long = 50 'kb
'
'
'DIM SETTINGS
Dim olns As Outlook.NameSpace
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelectedItems As Outlook.Selection
Dim i As Integer
Dim J As Integer
Dim Counter As Integer
Dim msgFormat As Long
Dim Header As String
Dim FileList As String
Dim Footer As String
Dim attPath As String
Dim attFileName As String
Dim msgFolder As String
Dim msgSender As String
Dim msgSubject As String
Dim yearFolder As String
Dim temp As String
Dim oleFound As Boolean
Dim dropSubject As Boolean
Dim invalidchars As Variant
'
'
'SET SETTINGS
Set olns = Application.GetNamespace("MAPI")
Set objSelectedItems = olns.Application.ActiveExplorer.Selection
'
'
'DOUBLE-CHECK FOLDER LOCATION
If Dir(RootFolder, vbDirectory) = "" Then
MsgBox "Root Folder Not Found!" & vbCrLf & _
"Please create the following folder first: " & vbCrLf & RootFolder
GoTo ExitSub
End If
'
'
'BEGIN SCRIPT
For Each objMsg In objSelectedItems
'
'
'SKIP ANYTHING THATS NOT A MAIL MESSAGE.
If objMsg.Class = olMail Then
'
'
'SKIP MESSAGES WITHOUT ATTACHMENTS.
Set objAttachments = objMsg.Attachments
Counter = objAttachments.Count
If Counter > 0 Then
'
'
'SKIP MESSAGES WITH ATTACHMENTS REMOVED ATTACHMENT.
If objAttachments.Item(1).Type <> olOLE Then
If (objAttachments.Item(1).FileName = "Attachments Removed") _
And (Counter = 1) Then
GoTo TheNextMessage
End If
End If
'
'
'SKIP ATTACHMENTS THAT ARE VERY SMALL.
If (objMsg.Size < (1024 * THRESH)) Then
GoTo TheNextMessage
End If
'
'
'SKIPS OLE FORMAT ATTACHMENTS.
oleFound = False
For i = objAttachments.Count To 1 Step -1
If objAttachments.Item(i).Type = olOLE Then
oleFound = True
Exit For
End If
Next i
If oleFound Then GoTo TheNextMessage
'
'
'DONT USE SUBJECT LINE AS FILE NAME IF IT IS DUAL-BYTE CHARS.
dropSubject = False
msgFormat = objMsg.InternetCodepage
If ((msgFormat = 28592) Or (msgFormat = 1250) Or (msgFormat = 20127) _
Or (msgFormat = 28591) Or (msgFormat = 1252)) Then
msgSubject = objMsg.Subject
Else
msgSubject = "message"
dropSubject = True
End If
'
'
'REMOVE CHARS THAT CANNOT BE USED IN FILE NAME.
invalidchars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "…")
For J = LBound(invalidchars) To UBound(invalidchars)
temp = Replace(msgSubject, invalidchars(J), " ")
msgSubject = temp
Next J
msgSubject = Replace(msgSubject, "RE ", "")
msgSubject = Replace(msgSubject, "FW ", "")
msgSubject = Trim(msgSubject)
If objMsg.Subject = "" Then msgSubject = "no subject"
'
'SHORTEN SENDER NAME
msgSender = Replace(objMsg.SenderName, " (YourCompanyName, consultant)", "")
msgSender = Replace(msgSender, " (YourCompanyName)", "")
'
'
'CREATE FOLDER PATH NAME FOR ATTACHMENTS
If (dropSubject) Then
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") & msgSender
Else
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") _
& msgSender & " - [" & msgSubject & "]"
End If
msgFolder = RootFolder & msgFolder & "\\"
'
'
'CREATE FOLDER FOR ATTACHMENTS
If Dir(msgFolder, vbDirectory) = "" Then
MkDir (msgFolder)
End If
'
'
'SAVE TEXT OF MESSAGE TO ATTACHMENT FOLDER FOR REFERENCE
objMsg.SaveAs msgFolder & msgSubject & ".txt", olTXT
Header = "<font face=""Courier New"" size=2 color=#736F6E>" _
& "============================================================" _
& "<br><a HREF=""file://" & Replace(msgFolder, "\\", "\") _
& Chr(34) & ">Attachments Archived:</a>"
FileList = ""
'
'
'ARCHIVE EACH ATTACHMENT
For i = objAttachments.Count To 1 Step -1
attFileName = objAttachments.Item(i).FileName
attPath = msgFolder & "\\" & attFileName
'
'
'SAVE ATTACHEMENTS TO FOLDER THEN REMOVE FROM EMAIL
objAttachments.Item(i).SaveAsFile attPath
objAttachments.Item(i).Delete
'
'
'CREATE LIST OF STORED FILES
FileList = "<br>" & "[" & i & "] " & "<a REL=ATT_LNK " _
& "HREF=""file://" & Replace(attPath, "\\", "\") _
& Chr(34) & ">" & attFileName & "</a>" & FileList
Next i
Footer = "<br>" & _
"============================================================" _
& "<br><br></font>"
objMsg.HTMLBody = Header & FileList & Footer & objMsg.HTMLBody
'End If
'
'
'ATTACH EMPTY FILE SO MESSAGE SHOWS THAT IT HAD ATTACHEMENTS
'CONFIG FOLDER MUST BE PLACED IN YOUR MAIN FOLDER
'MUST BE NAMES "Attachments Removed" AND HAVE NO SUFFIX (.txt, .pdf, etc)
temp = RootFolder & "\\config\\Attachments Removed"
objAttachments.Add temp, olByValue, , "Attachments Removed"
'
'
'SAVE MESSAGE WITH ATTACHMENT
objMsg.Save
'
'
'END SCRIPT
End If 'If Counter > 0 Then
End If 'If objMsg.Class = olMail
'
'
'CHECK NEXT MESSAGE
TheNextMessage:
Next objMsg
'
'
'EXIT SCRIPT
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelectedItems = Nothing
Set olns = Nothing
Exit Sub
'
'
'ERROR HANDLER
ErrorHandler:
MsgBox "RemoveAttachments( ) Subroutine" & vbCrLf & vbCrLf _
& "Error Code: " & Err.Number & vbCrLf & Err.Description
Err.Clear
GoTo ExitSub
End Sub
I think the issue is with the line:
Code:
'SKIP ANYTHING THATS NOT A MAIL MESSAGE.
If objMsg.Class = olMail Then
I reviewed the information in the links that jdc2000 provided, but am unsure how to edit the code to include IMP.Post. Any assistance with this would be greatly appreciated!
-
May 19th, 2017, 11:32 AM
#5
Thread Starter
New Member
Re: [Outlook 2007] Macro not working with IPM.POST
Thank you for the assistance! Issue #1 and #3 have been resolved. Issue #2 I am still having problems with. I used the links that jdc2000 provided but I am unsure how to edit my code to be used with IMP.Post message class. I have copied my updated code below.
Code:
Option Explicit
Public Sub Strip_Attachments_Service_Department()
On Error GoTo ErrorHandler
'
'
'CHANGE THIS TO THE FOLDER YOU WANT TO SAVE THE FILES IN.
Const RootFolder = "I:\Service\Outlook Templates\Email Retention\2017\"
'
'
'MESSAGES BELOW THIS SIZE WILL BE SKIPPED.
Const THRESH As Long = 50 'kb
'
'
'DIM SETTINGS
Dim olns As Outlook.NameSpace
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelectedItems As Outlook.Selection
Dim i As Integer
Dim J As Integer
Dim Counter As Integer
Dim msgFormat As Long
Dim Header As String
Dim FileList As String
Dim Footer As String
Dim attPath As String
Dim attFileName As String
Dim msgFolder As String
Dim msgSender As String
Dim msgSubject As String
Dim yearFolder As String
Dim temp As String
Dim oleFound As Boolean
Dim dropSubject As Boolean
Dim invalidchars As Variant
'
'
'SET SETTINGS
Set olns = Application.GetNamespace("MAPI")
Set objSelectedItems = olns.Application.ActiveExplorer.Selection
'
'
'DOUBLE-CHECK FOLDER LOCATION
If Dir(RootFolder, vbDirectory) = "" Then
MsgBox "Root Folder Not Found!" & vbCrLf & _
"Please create the following folder first: " & vbCrLf & RootFolder
GoTo ExitSub
End If
'
'
'BEGIN SCRIPT
For Each objMsg In objSelectedItems
'
'
'SKIP ANYTHING THATS NOT A MAIL MESSAGE.
If objMsg.Class = olMail Then
'
'
'SKIP MESSAGES WITHOUT ATTACHMENTS.
Set objAttachments = objMsg.Attachments
Counter = objAttachments.Count
If Counter > 0 Then
'
'
'SKIP MESSAGES WITH ATTACHMENTS REMOVED ATTACHMENT.
If objAttachments.Item(1).Type <> olOLE Then
If (objAttachments.Item(1).FileName = "Attachments Removed") _
And (Counter = 1) Then
GoTo TheNextMessage
End If
End If
'
'
'SKIP ATTACHMENTS THAT ARE VERY SMALL.
If (objMsg.Size < (1024 * THRESH)) Then
GoTo TheNextMessage
End If
'
'
'SKIPS OLE FORMAT ATTACHMENTS.
oleFound = False
For i = objAttachments.Count To 1 Step -1
If objAttachments.Item(i).Type = olOLE Then
oleFound = True
Exit For
End If
Next i
If oleFound Then GoTo TheNextMessage
'
'
'DONT USE SUBJECT LINE AS FILE NAME IF IT IS DUAL-BYTE CHARS.
dropSubject = False
msgFormat = objMsg.InternetCodepage
If ((msgFormat = 28592) Or (msgFormat = 1250) Or (msgFormat = 20127) _
Or (msgFormat = 28591) Or (msgFormat = 1252)) Then
msgSubject = objMsg.Subject
Else
msgSubject = "message"
dropSubject = True
End If
'
'
'REMOVE CHARS THAT CANNOT BE USED IN FILE NAME.
invalidchars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "…")
For J = LBound(invalidchars) To UBound(invalidchars)
temp = Replace(msgSubject, invalidchars(J), " ")
msgSubject = temp
Next J
msgSubject = Replace(msgSubject, "RE ", "")
msgSubject = Replace(msgSubject, "FW ", "")
msgSubject = Trim(msgSubject)
If objMsg.Subject = "" Then msgSubject = "no subject"
'
'SHORTEN SENDER NAME
msgSender = Replace(objMsg.SenderName, " (YourCompanyName, consultant)", "")
msgSender = Replace(msgSender, " (YourCompanyName)", "")
'
'
'CREATE FOLDER PATH NAME FOR ATTACHMENTS
If (dropSubject) Then
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") & msgSender
Else
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") _
& msgSender & " - [" & msgSubject & "]"
End If
msgFolder = RootFolder & msgFolder & "\\"
'
'
'CREATE FOLDER FOR ATTACHMENTS
If Dir(msgFolder, vbDirectory) = "" Then
MkDir (msgFolder)
End If
'
'
'SAVE TEXT OF MESSAGE TO ATTACHMENT FOLDER FOR REFERENCE
objMsg.SaveAs msgFolder & msgSubject & ".txt", olTXT
Header = "<font face=""Courier New"" size=2 color=#736F6E>" _
& "============================================================" _
& "<br><a HREF=""file://" & Replace(msgFolder, "\\", "\") _
& Chr(34) & ">Attachments Archived:</a>"
FileList = ""
'
'
'ARCHIVE EACH ATTACHMENT
For i = objAttachments.Count To 1 Step -1
attFileName = objAttachments.Item(i).FileName
attPath = msgFolder & "\\" & attFileName
'
'
'SAVE ATTACHEMENTS TO FOLDER THEN REMOVE FROM EMAIL
objAttachments.Item(i).SaveAsFile attPath
objAttachments.Item(i).Delete
'
'
'CREATE LIST OF STORED FILES
FileList = "<br>" & "[" & i & "] " & "<a REL=ATT_LNK " _
& "HREF=""file://" & Replace(attPath, "\\", "\") _
& Chr(34) & ">" & attFileName & "</a>" & FileList
Next i
Footer = "<br>" & _
"============================================================" _
& "<br><br></font>"
objMsg.HTMLBody = Header & FileList & Footer & objMsg.HTMLBody
'End If
'
'
'ATTACH EMPTY FILE SO MESSAGE SHOWS THAT IT HAD ATTACHEMENTS
'CONFIG FOLDER MUST BE PLACED IN YOUR MAIN FOLDER
'MUST BE NAMES "Attachments Removed" AND HAVE NO SUFFIX (.txt, .pdf, etc)
temp = RootFolder & "\\config\\Attachments Removed"
objAttachments.Add temp, olByValue, , "Attachments Removed"
'
'
'SAVE MESSAGE WITH ATTACHMENT
objMsg.Save
'
'
'END SCRIPT
End If 'If Counter > 0 Then
End If 'If objMsg.Class = olMail
'
'
'CHECK NEXT MESSAGE
TheNextMessage:
Next objMsg
'
'
'EXIT SCRIPT
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelectedItems = Nothing
Set olns = Nothing
Exit Sub
'
'
'ERROR HANDLER
ErrorHandler:
MsgBox "RemoveAttachments( ) Subroutine" & vbCrLf & vbCrLf _
& "Error Code: " & Err.Number & vbCrLf & Err.Description
Err.Clear
GoTo ExitSub
End Sub
-
May 19th, 2017, 11:34 AM
#6
Thread Starter
New Member
Re: [Outlook 2007] Macro not working with IPM.POST
I believe the issue is this line of code:
Code:
'SKIP ANYTHING THATS NOT A MAIL MESSAGE.
If objMsg.Class = olMail Then
I do not know how to do edit this to include IMP.Post message class though. Any assistance with this would be greatly appreciated!
-
May 19th, 2017, 11:39 AM
#7
Thread Starter
New Member
Re: [Outlook 2007] Macro not working with IPM.POST
Somehow I got it to work! All I ended up doing to resolve the issue was remove that line of code, and also removed a line further down in the code that referenced that previous line. It appears to be working for my purposes now . I would like to update this code to only process messages (IMP.Note) or posts (IMP.Post), but I don't know how to do that. Can anyone assist with that?
Thank you again.
Here's the final code that I have (I didn't remove the 2 lines I mentioned, I just added a ' to it so it wouldn't be ran with the code).
Code:
Option Explicit
Public Sub Strip_Attachments_Service_Department()
On Error GoTo ErrorHandler
'
'
'CHANGE THIS TO THE FOLDER YOU WANT TO SAVE THE FILES IN.
Const RootFolder = "I:\Service\Outlook Templates\Email Retention\2017\"
'
'
'MESSAGES BELOW THIS SIZE WILL BE SKIPPED.
Const THRESH As Long = 50 'kb
'
'
'DIM SETTINGS
Dim olns As Outlook.NameSpace
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelectedItems As Outlook.Selection
Dim i As Integer
Dim J As Integer
Dim Counter As Integer
Dim msgFormat As Long
Dim Header As String
Dim FileList As String
Dim Footer As String
Dim attPath As String
Dim attFileName As String
Dim msgFolder As String
Dim msgSender As String
Dim msgSubject As String
Dim yearFolder As String
Dim temp As String
Dim oleFound As Boolean
Dim dropSubject As Boolean
Dim invalidchars As Variant
'
'
'SET SETTINGS
Set olns = Application.GetNamespace("MAPI")
Set objSelectedItems = olns.Application.ActiveExplorer.Selection
'
'
'DOUBLE-CHECK FOLDER LOCATION
If Dir(RootFolder, vbDirectory) = "" Then
MsgBox "Root Folder Not Found!" & vbCrLf & _
"Please create the following folder first: " & vbCrLf & RootFolder
GoTo ExitSub
End If
'
'
'BEGIN SCRIPT
For Each objMsg In objSelectedItems
'
'
'SKIP ANYTHING THATS NOT A MAIL MESSAGE.
'If objMsg.Class = olMail Then
'
'
'SKIP MESSAGES WITHOUT ATTACHMENTS.
Set objAttachments = objMsg.Attachments
Counter = objAttachments.Count
If Counter > 0 Then
'
'
'SKIP MESSAGES WITH ATTACHMENTS REMOVED ATTACHMENT.
If objAttachments.Item(1).Type <> olOLE Then
If (objAttachments.Item(1).FileName = "Attachments Removed") _
And (Counter = 1) Then
GoTo TheNextMessage
End If
End If
'
'
'SKIP ATTACHMENTS THAT ARE VERY SMALL.
If (objMsg.Size < (1024 * THRESH)) Then
GoTo TheNextMessage
End If
'
'
'SKIPS OLE FORMAT ATTACHMENTS.
oleFound = False
For i = objAttachments.Count To 1 Step -1
If objAttachments.Item(i).Type = olOLE Then
oleFound = True
Exit For
End If
Next i
If oleFound Then GoTo TheNextMessage
'
'
'DONT USE SUBJECT LINE AS FILE NAME IF IT IS DUAL-BYTE CHARS.
dropSubject = False
msgFormat = objMsg.InternetCodepage
If ((msgFormat = 28592) Or (msgFormat = 1250) Or (msgFormat = 20127) _
Or (msgFormat = 28591) Or (msgFormat = 1252)) Then
msgSubject = objMsg.Subject
Else
msgSubject = "message"
dropSubject = True
End If
'
'
'REMOVE CHARS THAT CANNOT BE USED IN FILE NAME.
invalidchars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "…")
For J = LBound(invalidchars) To UBound(invalidchars)
temp = Replace(msgSubject, invalidchars(J), " ")
msgSubject = temp
Next J
msgSubject = Replace(msgSubject, "RE ", "")
msgSubject = Replace(msgSubject, "FW ", "")
msgSubject = Trim(msgSubject)
If objMsg.Subject = "" Then msgSubject = "no subject"
'
'SHORTEN SENDER NAME
msgSender = Replace(objMsg.SenderName, " (YourCompanyName, consultant)", "")
msgSender = Replace(msgSender, " (YourCompanyName)", "")
'
'
'CREATE FOLDER PATH NAME FOR ATTACHMENTS
If (dropSubject) Then
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") & msgSender
Else
msgFolder = Strings.Format(objMsg.ReceivedTime, "yyyy.mm.dd.hhnn - ") _
& msgSender & " - [" & msgSubject & "]"
End If
msgFolder = RootFolder & msgFolder & "\\"
'
'
'CREATE FOLDER FOR ATTACHMENTS
If Dir(msgFolder, vbDirectory) = "" Then
MkDir (msgFolder)
End If
'
'
'SAVE TEXT OF MESSAGE TO ATTACHMENT FOLDER FOR REFERENCE
objMsg.SaveAs msgFolder & msgSubject & ".txt", olTXT
Header = "<font face=""Courier New"" size=2 color=#736F6E>" _
& "============================================================" _
& "<br><a HREF=""file://" & Replace(msgFolder, "\\", "\") _
& Chr(34) & ">Attachments Archived:</a>"
FileList = ""
'
'
'ARCHIVE EACH ATTACHMENT
For i = objAttachments.Count To 1 Step -1
attFileName = objAttachments.Item(i).FileName
attPath = msgFolder & "\\" & attFileName
'
'
'SAVE ATTACHEMENTS TO FOLDER THEN REMOVE FROM EMAIL
objAttachments.Item(i).SaveAsFile attPath
objAttachments.Item(i).Delete
'
'
'CREATE LIST OF STORED FILES
FileList = "<br>" & "[" & i & "] " & "<a REL=ATT_LNK " _
& "HREF=""file://" & Replace(attPath, "\\", "\") _
& Chr(34) & ">" & attFileName & "</a>" & FileList
Next i
Footer = "<br>" & _
"============================================================" _
& "<br><br></font>"
objMsg.HTMLBody = Header & FileList & Footer & objMsg.HTMLBody
'End If
'
'
'ATTACH EMPTY FILE SO MESSAGE SHOWS THAT IT HAD ATTACHEMENTS
'CONFIG FOLDER MUST BE PLACED IN YOUR MAIN FOLDER
'MUST BE NAMES "Attachments Removed" AND HAVE NO SUFFIX (.txt, .pdf, etc)
temp = RootFolder & "\\config\\Attachments Removed"
objAttachments.Add temp, olByValue, , "Attachments Removed"
'
'
'SAVE MESSAGE WITH ATTACHMENT
objMsg.Save
'
'
'END SCRIPT
End If 'If Counter > 0 Then
'End If 'If objMsg.Class = olMail
'
'
'CHECK NEXT MESSAGE
TheNextMessage:
Next objMsg
'
'
'EXIT SCRIPT
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelectedItems = Nothing
Set olns = Nothing
Exit Sub
'
'
'ERROR HANDLER
ErrorHandler:
MsgBox "RemoveAttachments( ) Subroutine" & vbCrLf & vbCrLf _
& "Error Code: " & Err.Number & vbCrLf & Err.Description
Err.Clear
GoTo ExitSub
End Sub
-
May 19th, 2017, 12:09 PM
#8
Thread Starter
New Member
Re: [Outlook 2007] Macro not working with IPM.POST
YAY!!!! I finally got it figured out... basically I did not know how to use IF statements correctly. I changed the code in these two spots and now this works for only mail messages or posts. Thank you everyone for your help.
Code:
'SKIP ANYTHING THATS NOT A MAIL MESSAGE OR POST.
If (objMsg.Class = olMail Or objMsg.Class = olPost) Then
Code:
'END SCRIPT
End If 'If Counter > 0 Then
End If 'If (objMsg.Class = olMail OR objMsg.Class = olPost)
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|