[RESOLVED] [Outlook 2007] Macro not working with IPM.POST-VBForums
Results 1 to 8 of 8

Thread: [RESOLVED] [Outlook 2007] Macro not working with IPM.POST

  1. #1

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    6

    Resolved [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

  2. #2
    Fanatic Member
    Join Date
    Oct 2001
    Location
    Idaho Falls, Idaho USA
    Posts
    819

    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.

  3. #3
    PowerPoster
    Join Date
    Dec 2004
    Posts
    22,625

    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

  4. #4

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    6

    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!

  5. #5

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    6

    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

  6. #6

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    6

    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!

  7. #7

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    6

    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

  8. #8

    Thread Starter
    New Member
    Join Date
    May 2017
    Posts
    6

    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
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.