Impossible to move attachments in case of saving to wrong folder

' In case you run the macro with wrong destination folder, each saved message
' will contain a link to wrong folder, hence it's not enough to just move the 
attachment
' to the right folder, you must also fix the links in the messages.
' This functions makes it for you, just specify old and new folder:

Public Sub ChangeFolder_Explorer()
' Fix wrong links to folders.

    OLD_FOLDER = "C:\OutlookAttachments\2011\"
    NEW_FOLDER = "C:\OutlookAttachments\2012\"

    ' Internal Outlook name for outbox folder; to determine the name used on your system,
    ' select a message in the outbox and run macro ShowFolderName
    Const SENT_FOLDER_NAME = "inviata"

    Dim olns As Outlook.NameSpace
    Dim objMsg As Object
    Dim mo As MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objSelectedItems As Outlook.Selection

    Set olns = Application.GetNamespace("MAPI")
    Set objSelectedItems = olns.Application.ActiveExplorer.Selection
    '
    'Make sure base path exists
    'If Dir(RootFolder, vbDirectory) = "" Then
    '    MsgBox "Destination Folder Not Found!" & vbCrLf & _
    '    "Please create the following folder first: " & vbCrLf & RootFolder
    '    GoTo ExitSub
    'End If

    '

    Total = objSelectedItems.Count
    Partial = 0
    ProgressGauge = 0
    frmProgress.Show
    frmProgress.Caption = "Fixing attachments folder..."
    For Each objMsg In objSelectedItems
        If objMsg.Class = olMail Then

            Set mo = objMsg
            su = mo.Subject
            Partial = Partial + 1
            ProgressGauge = Int(100 * Partial / Total)
            frmProgress.lblMsgGauge.Width = ProgressGauge
            frmProgress.lblMsgPerc.Caption = Str$(ProgressGauge) & " %"
            frmProgress.lblMsgPerc.Left = ProgressGauge + 20
            ' Reset attachments gauge
            frmProgress.lblAttGauge.Width = 0
            frmProgress.lblAttPerc = ""
            frmProgress.lblAttPerc.Left = 10
            DoEvents ' Update form

            If InStr(UCase$(objMsg.HTMLBody), "FILE://" & UCase$(OLD_FOLDER)) > 0 Or _
                InStr(UCase$(objMsg.HTMLBody), "FILE:///" & UCase$(OLD_FOLDER)) > 0 Then
                mo.HTMLBody = Replace(mo.HTMLBody, "file://" & OLD_FOLDER, "file://" & NEW_FOLDER)
                mo.HTMLBody = Replace(mo.HTMLBody, "file:///" & OLD_FOLDER, "file://" & NEW_FOLDER)
                mo.Save
            End If
        End If
    Next
    frmProgress.hide
End Sub
Original issue reported on code.google.com by jumomar...@gmail.com on 2 Jul 2012 at 1:53
acamboy / lightlook

Impossible to move attachments in case of saving to wrong folder #6
