New form for creating travel time appointments in Outlook

Posted on September 7, 2017 by Scott — 2 Comments ↓

Articles in the "Outlook Travel Time Appointments" series

Add travel time appointments in Outlook
New form for creating travel time appointments in Outlook [This article]

I still use my code to create travel time appointments in Outlook. I updated it a little while ago, though, to streamline it. It now uses a VBA form to ask for the travel from and travel to times in one dialog:

The travel time form now lets you create both appointments from one dialog.

This saves a little real estate in the ribbon because now you only need one button:

The custom button runs the macro for launching the form and creating the appointments.

It also saves time because you can have it create both appointments in one go. If you don’t need the to or from appointment created, leave its field blank. You can download the two form files below, extract them anywhere, then in the VBA editor you can click File->Import File… and select the .frm file.

TravelTimeForm.zip (1.6 KiB)

You can copy the updated macros below and paste them into ThisOutlookSession in the VBA editor (and delete the macros from the old version). The OpenOutlookFolder macro hasn’t changed, but is included for convenience. The CreateTravelAppointment macro is now called CreateAppointment and the only change is that it sets the appointment’s category to Travel. The CreateTravelToAppointment and CreateTravelFromAppointment macros are now combined into one called CreateTravelAppointment. This is the macro you want your ribbon button to execute.

Function OpenOutlookFolder(ByVal strPath As String) As Object
    Dim objSession As NameSpace
    Dim arrFolders As Variant, varFolder As Variant, bolBeyondRoot As Boolean
    
    Set objSession = Outlook.Application.GetNamespace("MAPI")

    On Error Resume Next
    Do While Left(strPath, 1) = "\"
        strPath = Right(strPath, Len(strPath) - 1)
    Loop
    arrFolders = Split(strPath, "\")
    For Each varFolder In arrFolders
        Select Case bolBeyondRoot
            Case False
                Set OpenOutlookFolder = objSession.Folders(varFolder)
                bolBeyondRoot = True
            Case True
                Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
        End Select
        If Err.Number <> 0 Then
            Set OpenOutlookFolder = Nothing
            Exit For
        End If
    Next
    On Error GoTo 0
    
    Set objSession = Nothing
    
End Function
Sub CreateAppointment(path, subject, starttime, duration, setreminder)
    Dim objCalFolder As Outlook.Folder
    Dim objCalItem As Outlook.AppointmentItem
    
    'Get folder object for given path
    Set objCalFolder = OpenOutlookFolder(path)
    'Create appointment item and set properties
    Set objCalItem = objCalFolder.Items.Add
    objCalItem.subject = subject
    objCalItem.Start = starttime
    objCalItem.duration = duration
    objCalItem.BusyStatus = olOutOfOffice
    objCalItem.Categories = "Travel"
    'Don't set reminder for return travel time
    If setreminder = False Then
        objCalItem.ReminderSet = False
    End If
    objCalItem.Save
    
    Set objCalItem = Nothing
    Set objCalFolder = Nothing
End Sub
Sub CreateTravelAppointment()
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objSelectedAppointment As Outlook.AppointmentItem
    Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String
    Dim TravelTimeTo As Integer, TravelTimeFrom As Integer
    
    'Get currently selected appointment item and the calendar it is in
    Set objExplorer = Outlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    'Get path to current calendar folder (allows for working with non-default and additional calendars)
    strFolderPath = objExplorer.CurrentFolder.folderPath
    
    If objSelection.Count <> 1 Then
        noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")
    Else
        Set objSelectedAppointment = objSelection.Item(1)
        'Display form to get travel time durations
        TravelTimeForm.Show
        TravelTimeTo = TravelTimeForm.TravelToTextBox.Value
        TravelTimeFrom = TravelTimeForm.TravelFromTextBox.Value
        'Create travel time appointments only if value provided
        If TravelTimeTo >= 0 Then
            dtStartTime = objSelectedAppointment.Start - TimeSerial(0, TravelTimeTo, 0)
            strSubject = "Travel to " & objSelectedAppointment.subject
            Call CreateAppointment(strFolderPath, strSubject, dtStartTime, TravelTimeTo, True)
            'Disable reminder because travel appointment has one
            objSelectedAppointment.ReminderSet = False
            objSelectedAppointment.Save
        End If
        If TravelTimeFrom >= 0 Then
            dtStartTime = objSelectedAppointment.End
            strSubject = "Travel from " & objSelectedAppointment.subject
            Call CreateAppointment(strFolderPath, strSubject, dtStartTime, TravelTimeFrom, False)
        End If
        Unload TravelTimeForm
    End If
    
    Set objSelectAppointment = Nothing
    Set objSelection = Nothing
    Set objExplorer = Nothing
        
End Sub

Function OpenOutlookFolder(ByVal strPath As String) As Object

Dim objSession As NameSpace

Dim arrFolders As Variant, varFolder As Variant, bolBeyondRoot As Boolean

Set objSession = Outlook.Application.GetNamespace("MAPI")

On Error Resume Next

Do While Left(strPath, 1) = "\"

strPath = Right(strPath, Len(strPath) - 1)

Loop

arrFolders = Split(strPath, "\")

For Each varFolder In arrFolders

Select Case bolBeyondRoot

Case False

Set OpenOutlookFolder = objSession.Folders(varFolder)

bolBeyondRoot = True

Case True

Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)

End Select

If Err.Number <> 0 Then

Set OpenOutlookFolder = Nothing

Exit For

End If

On Error GoTo 0

Set objSession = Nothing

End Function

Sub CreateAppointment(path, subject, starttime, duration, setreminder)

Dim objCalFolder As Outlook.Folder

Dim objCalItem As Outlook.AppointmentItem

'Get folder object for given path

Set objCalFolder = OpenOutlookFolder(path)

'Create appointment item and set properties

Set objCalItem = objCalFolder.Items.Add

objCalItem.subject = subject

objCalItem.Start = starttime

objCalItem.duration = duration

objCalItem.BusyStatus = olOutOfOffice

objCalItem.Categories = "Travel"

'Don't set reminder for return travel time

If setreminder = False Then

objCalItem.ReminderSet = False

End If

objCalItem.Save

Set objCalItem = Nothing

Set objCalFolder = Nothing

End Sub

Sub CreateTravelAppointment()

Dim objExplorer As Outlook.Explorer

Dim objSelection As Outlook.Selection

Dim objSelectedAppointment As Outlook.AppointmentItem

Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String

Dim TravelTimeTo As Integer, TravelTimeFrom As Integer

'Get currently selected appointment item and the calendar it is in

Set objExplorer = Outlook.ActiveExplorer

Set objSelection = objExplorer.Selection

'Get path to current calendar folder (allows for working with non-default and additional calendars)

strFolderPath = objExplorer.CurrentFolder.folderPath

If objSelection.Count <> 1 Then

noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")

Else

Set objSelectedAppointment = objSelection.Item(1)

'Display form to get travel time durations

TravelTimeForm.Show

TravelTimeTo = TravelTimeForm.TravelToTextBox.Value

TravelTimeFrom = TravelTimeForm.TravelFromTextBox.Value

'Create travel time appointments only if value provided

If TravelTimeTo >= 0 Then

dtStartTime = objSelectedAppointment.Start - TimeSerial(0, TravelTimeTo, 0)

strSubject = "Travel to " & objSelectedAppointment.subject

Call CreateAppointment(strFolderPath, strSubject, dtStartTime, TravelTimeTo, True)

'Disable reminder because travel appointment has one

objSelectedAppointment.ReminderSet = False

objSelectedAppointment.Save

End If

If TravelTimeFrom >= 0 Then

dtStartTime = objSelectedAppointment.End

strSubject = "Travel from " & objSelectedAppointment.subject

Call CreateAppointment(strFolderPath, strSubject, dtStartTime, TravelTimeFrom, False)

End If

Unload TravelTimeForm

End If

Set objSelectAppointment = Nothing

Set objSelection = Nothing

Set objExplorer = Nothing

End Sub

Previous in series |

Outlook macro to assign retention policy when item is deleted

Posted on September 29, 2016 by Scott — 2 Comments ↓

I described in another post how I need to assign a retention policy tag to items in my Deleted Items folder because there isn’t a retention policy tag set on the folder. I also set a different tag to items in my Sent Items folder. While I run the script in that post every week or so, because of the large volume of mail I receive and subsequently delete, the script will sometimes need to process over a thousand items. Updating that many items with EWS is not the fastest process, so I looked into how Outlook can do it for me at the time a message is put in its respective folder.

Applying a personal tag to sent items is easy because a rule can be created to assign the tag when items are sent:
To have a tag assigned when items are moved to the Deleted Items folder, I needed to create a macro that runs when the items are moved. This can be done with an event that is registered when Outlook starts. Paste the following code into ThisOutlookSession and restart Outlook. (You will want to change the two constants to be the GUID and number of days for your tag.)

Public WithEvents deletedItems As Outlook.Items

Public Sub Application_Startup()
    Set deletedItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems).Items
End Sub

Public Sub deletedItems_ItemAdd(ByVal Item As Object)
    Const retPolicy As String = "03DACE3336054C428ECAE839E0BC5945" '30 Day tag GUID
    Const retPeriod As Long = 30 'Number of days the tag is set to expire items
    Set pa = Item.PropertyAccessor
    p = Empty
    On Error Resume Next
    p = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30190102") 'Get policy tag
    On Error GoTo 0
    If IsEmpty(p) Then
        IsEqual = False
    ElseIf pa.BinaryToString(p) &lt;&gt; retPolicy Then
        IsEqual = False
    Else
        IsEqual = True
    End If
    If Not IsEqual Then
        msgDate = Empty
        On Error Resume Next
        msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E060040") 'Get delivery date
        On Error GoTo 0
        If IsEmpty(msgDate) Then
            msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040") 'Get creation date
        End If
    pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30190102", pa.StringToBinary(retPolicy) 'Set poliy tag
    pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301A0003", retPeriod 'Set retention period days
    pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301C0040", msgDate + retPeriod 'Set date of expiration
    Item.Save
    End If
End Sub

Public WithEvents deletedItems As Outlook.Items

Public Sub Application_Startup()

Set deletedItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems).Items

End Sub

Public Sub deletedItems_ItemAdd(ByVal Item As Object)

Const retPolicy As String = "03DACE3336054C428ECAE839E0BC5945" '30 Day tag GUID

Const retPeriod As Long = 30 'Number of days the tag is set to expire items

Set pa = Item.PropertyAccessor

p = Empty

On Error Resume Next

p = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30190102") 'Get policy tag

On Error GoTo 0

If IsEmpty(p) Then

IsEqual = False

ElseIf pa.BinaryToString(p) <> retPolicy Then

IsEqual = False

Else

IsEqual = True

End If

If Not IsEqual Then

msgDate = Empty

On Error Resume Next

msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E060040") 'Get delivery date

On Error GoTo 0

If IsEmpty(msgDate) Then

msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040") 'Get creation date

End If

pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30190102", pa.StringToBinary(retPolicy) 'Set poliy tag

pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301A0003", retPeriod 'Set retention period days

pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301C0040", msgDate + retPeriod 'Set date of expiration

Item.Save

End If

End Sub

Both the rule and the macro only run when Outlook is the client doing the operation, so any messages sent or deleted from a mobile device (or OWA) won’t have the respective tag assigned. This means I still have a need to run the script, but it will need update far fewer items and, therefore, complete in much less time.

Add travel time appointments in Outlook

Posted on May 27, 2015 by Scott — 2 Comments ↓

Articles in the "Outlook Travel Time Appointments" series

Add travel time appointments in Outlook [This article]
New form for creating travel time appointments in Outlook

I like having travel time appointments in my calendar so that my free/busy accurately reflects that I am unavailable, but also so that I am reminded with enough time that I need to leave. I used to use an add-in from Instyler (no link since the site is no longer active) that allowed me to add travel to and/or from appointments to a selected calendar item, but it doesn’t work with Outlook 2013. So I chose to write a macro several years ago to do it. Like my attachment rename macro, when someone asked about using it in a newsletter, it gave me an opportunity to fix the main limitation in my use case: multiple accounts.

The original code leveraged the Applicaton.CreateItem() method, which creates the item in the default folder of the respective item type (olAppointmentItem, in this case). But I have long had two Exchange accounts in my profile, work and personal. I couldn’t get it to create the appointment item in the selected calendar. So I figured out how to open a particular calendar based on the folder path of the selected calendar.

The macro works against single-occurrence appointments and meetings. (Working with recurrences is messy.) There are actually three subroutines and one function. Two of the subs are for indicating which type of travel appointment to create, to or from. The third sub is for actually creating the appointment item, and the function is for opening the target calendar. I modified the ribbon for appointment items to add a button for creating a “travel to” appointment and a button for creating a “travel from” appointment. Each will prompt for how long the travel time should be, defaulting to 30 minutes. The travel to appointment sets a reminder, but the return travel appointment does not. It also uses the subject of the selected item to construct the subject of the travel time appointment. Paste these four code blocks into the VBA editor and then you can assign your added buttons to the CreateTravelToAppointment and CreateTravelFromAppointment subroutines.

Sub CreateTravelToAppointment()
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objSelectedAppointment As Outlook.AppointmentItem
    Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String
    
    'Get currently selected appointment item and the calendar it is in
    Set objExplorer = Outlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    'Get path to current calendar folder (allows for working with non-default and additional calendars)
    strFolderPath = objExplorer.CurrentFolder.folderPath
    
    If objSelection.Count <> 1 Then
        noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")
    Else
        Set objSelectedAppointment = objSelection.Item(1)
        'Get travel time duration to calculate start time
        intMinutes = InputBox("How many minutes for the travel time?", "Enter travel minutes", 30)
        dtStartTime = objSelectedAppointment.Start - TimeSerial(0, intMinutes, 0)
        strSubject = "Travel to " & objSelectedAppointment.subject
        Call CreateTravelAppointment(strFolderPath, strSubject, dtStartTime, intMinutes, True)
    End If
    
    Set objSelectAppointment = Nothing
    Set objSelection = Nothing
    Set objExplorer = Nothing
        
End Sub

Sub CreateTravelToAppointment()

Dim objExplorer As Outlook.Explorer

Dim objSelection As Outlook.Selection

Dim objSelectedAppointment As Outlook.AppointmentItem

Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String

'Get currently selected appointment item and the calendar it is in

Set objExplorer = Outlook.ActiveExplorer

Set objSelection = objExplorer.Selection

'Get path to current calendar folder (allows for working with non-default and additional calendars)

strFolderPath = objExplorer.CurrentFolder.folderPath

If objSelection.Count <> 1 Then

noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")

Else

Set objSelectedAppointment = objSelection.Item(1)

'Get travel time duration to calculate start time

intMinutes = InputBox("How many minutes for the travel time?", "Enter travel minutes", 30)

dtStartTime = objSelectedAppointment.Start - TimeSerial(0, intMinutes, 0)

strSubject = "Travel to " & objSelectedAppointment.subject

Call CreateTravelAppointment(strFolderPath, strSubject, dtStartTime, intMinutes, True)

End If

Set objSelectAppointment = Nothing

Set objSelection = Nothing

Set objExplorer = Nothing

End Sub

Sub CreateTravelFromAppointment()
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objSelectedAppointment As Outlook.AppointmentItem
    Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String
    
    'Get currently selected appointment item and the calendar it is in
    Set objExplorer = Outlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    'Get path to current calendar folder (allows for working with non-default and additional calendars)
    strFolderPath = objExplorer.CurrentFolder.folderPath
       
    If objSelection.Count <> 1 Then
        noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")
    Else
        Set objSelectedAppointment = objSelection.Item(1)
        'Get travel time duration to calculate start time
        intMinutes = InputBox("How many minutes for the return travel time?", "Enter travel minutes", 30)
        dtStartTime = objSelectedAppointment.End
        strSubject = "Travel from " & objSelectedAppointment.subject
        Call CreateTravelAppointment(strFolderPath, strSubject, dtStartTime, intMinutes, False)
    End If
        
    Set objSelectAppointment = Nothing
    Set objSelection = Nothing
    Set objExplorer = Nothing
    
End Sub

Sub CreateTravelFromAppointment()

Dim objExplorer As Outlook.Explorer

Dim objSelection As Outlook.Selection

Dim objSelectedAppointment As Outlook.AppointmentItem

Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String

'Get currently selected appointment item and the calendar it is in

Set objExplorer = Outlook.ActiveExplorer

Set objSelection = objExplorer.Selection

'Get path to current calendar folder (allows for working with non-default and additional calendars)

strFolderPath = objExplorer.CurrentFolder.folderPath

If objSelection.Count <> 1 Then

noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")

Else

Set objSelectedAppointment = objSelection.Item(1)

'Get travel time duration to calculate start time

intMinutes = InputBox("How many minutes for the return travel time?", "Enter travel minutes", 30)

dtStartTime = objSelectedAppointment.End

strSubject = "Travel from " & objSelectedAppointment.subject

Call CreateTravelAppointment(strFolderPath, strSubject, dtStartTime, intMinutes, False)

End If

Set objSelectAppointment = Nothing

Set objSelection = Nothing

Set objExplorer = Nothing

End Sub

Sub CreateTravelAppointment(path, subject, starttime, duration, setreminder)
    Dim objCalFolder As Outlook.Folder
    Dim objCalItem As Outlook.AppointmentItem
    
    'Get folder object for given path
    Set objCalFolder = OpenOutlookFolder(path)
    'Create appointment item and set properties
    Set objCalItem = objCalFolder.Items.Add
    objCalItem.subject = subject
    objCalItem.Start = starttime
    objCalItem.duration = duration
    objCalItem.BusyStatus = olOutOfOffice
    'Don't set reminder for return travel time
    If setreminder = False Then
        objCalItem.ReminderSet = False
    End If
    objCalItem.Save
    
    Set objCalItem = Nothing
    Set objCalFolder = Nothing
End Sub

Sub CreateTravelAppointment(path, subject, starttime, duration, setreminder)

Dim objCalFolder As Outlook.Folder

Dim objCalItem As Outlook.AppointmentItem

'Get folder object for given path

Set objCalFolder = OpenOutlookFolder(path)

'Create appointment item and set properties

Set objCalItem = objCalFolder.Items.Add

objCalItem.subject = subject

objCalItem.Start = starttime

objCalItem.duration = duration

objCalItem.BusyStatus = olOutOfOffice

'Don't set reminder for return travel time

If setreminder = False Then

objCalItem.ReminderSet = False

End If

objCalItem.Save

Set objCalItem = Nothing

Set objCalFolder = Nothing

End Sub

Function OpenOutlookFolder(ByVal strPath As String) As Object
    Dim objSession As NameSpace
    Dim arrFolders As Variant, varFolder As Variant, bolBeyondRoot As Boolean
    
    Set objSession = Outlook.Application.GetNamespace("MAPI")

    On Error Resume Next
    Do While Left(strPath, 1) = "\"
        strPath = Right(strPath, Len(strPath) - 1)
    Loop
    arrFolders = Split(strPath, "\")
    For Each varFolder In arrFolders
        Select Case bolBeyondRoot
            Case False
                Set OpenOutlookFolder = objSession.Folders(varFolder)
                bolBeyondRoot = True
            Case True
                Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
        End Select
        If Err.Number <> 0 Then
            Set OpenOutlookFolder = Nothing
            Exit For
        End If
    Next
    On Error GoTo 0
    
    Set objSession = Nothing
    
End Function

Function OpenOutlookFolder(ByVal strPath As String) As Object

Dim objSession As NameSpace

Dim arrFolders As Variant, varFolder As Variant, bolBeyondRoot As Boolean

Set objSession = Outlook.Application.GetNamespace("MAPI")

On Error Resume Next

Do While Left(strPath, 1) = "\"

strPath = Right(strPath, Len(strPath) - 1)

Loop

arrFolders = Split(strPath, "\")

For Each varFolder In arrFolders

Select Case bolBeyondRoot

Case False

Set OpenOutlookFolder = objSession.Folders(varFolder)

bolBeyondRoot = True

Case True

Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)

End Select

If Err.Number <> 0 Then

Set OpenOutlookFolder = Nothing

Exit For

End If

On Error GoTo 0

Set objSession = Nothing

End Function

| Next in series

Rename Outlook attachments before you send them

Posted on May 21, 2015 by Scott — 9 Comments ↓

Edit (June 29,2017): I have made a couple minor changes to the code. One resolves the issue with to-be-renamed attachments being removed from the well when you don’t rename all attachments. The other may resolve the issue with the “path does not exist” error that some have gotten. I can’t be sure because I am unable to reproduce the error.

I often send PowerShell scripts via email. But because .ps1 is a Level 1 attachment, the recipient, if using Outlook, won’t be able to access it (by default). This means I need to rename the file before attaching it to the message. I don’t like doing that, however, because then I have to rename it back after attaching it. I can also compress (zip) the file or make a copy and rename that, but I still have extra files that I then have to delete. I would much rather deal with the file in the context I am sending it: Outlook.

I wrote a VBA macro several years ago that allows me to rename attachments after adding them to the message. Recently, I had an opportunity to share it with somebody so I took the time to update it to accommodate additional scenarios. For example, I discovered that when replying/forwarding a message that has inline images, those are included in the attachment collection, so I had to find a way to exclude those. The same is true when an embedded message is attached. Since the macro was being shared with others, I also added some additional error detection logic to deal with scenarios that normally wouldn’t apply to me or I could deal with one-off.

To use the macro, paste it into ThisOutlookSession in the VBA editor and save it. I modified the ribbon of the new message form (just using the built-in ribbon designer) to add a button that I labeled Rename Attachments and used one of the available icons (there aren’t a lot to choose from), clicking the button runs the macro. (You have to change the default macro security settings in the Trust Center because it isn’t digitally signed.)

Sub RenameAttachmentsWithPrompt()
    Dim olkItem As Outlook.MailItem
    Dim olkAttachment As Outlook.Attachment, olkAttachments As Outlook.Attachments
    Dim objFSO As Object, strFolder As String, strFilename As String
    Dim olkPA As PropertyAccessor
    Dim arrRenamedAttachments() As String
    Dim bValidAttachment, bRenamedAttachment As Boolean
    
    If Application.ActiveInspector Is Nothing Then
        Set olkItem = Application.ActiveExplorer.Selection.Item(1)
    Else
        Set olkItem = Application.ActiveInspector.CurrentItem
    End If
 
    i = 1
    bValidAttachment = False
    If olkItem.Attachments.Count > 0 Then
        If MsgBox("Do you want to rename any of the attachments?", vbYesNo, "Rename any attachments?") = vbYes Then
            Set olkAttachments = olkItem.Attachments
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            'Bind to the system temp folder
            strFolder = objFSO.GetSpecialFolder(2)
            'Loop through attachments in reverse to account for
            'collection size changing when deleting an attachment
            For j = olkAttachments.Count To 1 Step -1
                Set olkAttachment = olkAttachments.Item(j)
                Set olkPA = olkAttachment.PropertyAccessor
                Dim bHidden As Boolean
                'Visible attachments usually don't have hidden property set so ignore error
                On Error Resume Next
                bHidden = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7FFE000B")
                On Error GoTo 0
                'Skip embedded messages and hidden attachments
                If olkAttachment.Type <> olEmbeddeditem And (Not bHidden Or IsNull(bHidden)) Then
                    bValidAttachment = True
                    strFilename = ""
                    strFilename = InputBox("What do you want to name the attachment?" & _
                        vbNewLine & vbNewLine & "(To leave it as is, click OK or Cancel.)", _
                        "Rename Attachment", olkAttachment.FileName)
                    If strFilename <> olkAttachment.FileName And strFilename <> "" Then
                        'Attachment file names are read-only, so save renamed attachment to disk
                        'and delete original from message
                        ReDim Preserve arrRenamedAttachments(i - 1)
                        olkAttachment.SaveAsFile strFolder & "\" & strFilename
                        olkAttachment.Delete
                        arrRenamedAttachments(i - 1) = strFolder & "\" & strFilename
                        bRenamedAttachment = True
                        i = i + 1
                    End If
                End If
            Next
            If Not bValidAttachment Then
                noValid = MsgBox("There are no attachments that can be renamed." & vbNewLine & vbNewLine & _
                    "(Only embedded messages or hidden attachments are in the message.)", vbOKOnly)
            End If
            'Add renamed attachment(s) to message and delete from temp folder
            If bRenamedAttachment Then
                For Each strFilePath In arrRenamedAttachments
                    olkItem.Attachments.Add strFilePath
                    objFSO.DeleteFile strFilePath
                Next
            End If
        End If
    Else
        noAttach = MsgBox("There are no attachments in the message.", vbOKOnly)
    End If
    
    Set olkItem = Nothing
    Set olkAttachment = Nothing
    Set olkPA = Nothing
    Set objFSO = Nothing

End Sub

Sub RenameAttachmentsWithPrompt()

Dim olkItem As Outlook.MailItem

Dim olkAttachment As Outlook.Attachment, olkAttachments As Outlook.Attachments

Dim objFSO As Object, strFolder As String, strFilename As String

Dim olkPA As PropertyAccessor

Dim arrRenamedAttachments() As String

Dim bValidAttachment, bRenamedAttachment As Boolean

If Application.ActiveInspector Is Nothing Then

Set olkItem = Application.ActiveExplorer.Selection.Item(1)

Else

Set olkItem = Application.ActiveInspector.CurrentItem

End If

i = 1

bValidAttachment = False

If olkItem.Attachments.Count > 0 Then

If MsgBox("Do you want to rename any of the attachments?", vbYesNo, "Rename any attachments?") = vbYes Then

Set olkAttachments = olkItem.Attachments

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Bind to the system temp folder

strFolder = objFSO.GetSpecialFolder(2)

'Loop through attachments in reverse to account for

'collection size changing when deleting an attachment

For j = olkAttachments.Count To 1 Step -1

Set olkAttachment = olkAttachments.Item(j)

Set olkPA = olkAttachment.PropertyAccessor

Dim bHidden As Boolean

'Visible attachments usually don't have hidden property set so ignore error

On Error Resume Next

bHidden = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7FFE000B")

On Error GoTo 0

'Skip embedded messages and hidden attachments

If olkAttachment.Type <> olEmbeddeditem And (Not bHidden Or IsNull(bHidden)) Then

bValidAttachment = True

strFilename = ""

strFilename = InputBox("What do you want to name the attachment?" & _

vbNewLine & vbNewLine & "(To leave it as is, click OK or Cancel.)", _

"Rename Attachment", olkAttachment.FileName)

If strFilename <> olkAttachment.FileName And strFilename <> "" Then

'Attachment file names are read-only, so save renamed attachment to disk

'and delete original from message

ReDim Preserve arrRenamedAttachments(i - 1)

olkAttachment.SaveAsFile strFolder & "\" & strFilename

olkAttachment.Delete

arrRenamedAttachments(i - 1) = strFolder & "\" & strFilename

bRenamedAttachment = True

i = i + 1

End If

If Not bValidAttachment Then

noValid = MsgBox("There are no attachments that can be renamed." & vbNewLine & vbNewLine & _

"(Only embedded messages or hidden attachments are in the message.)", vbOKOnly)

End If

'Add renamed attachment(s) to message and delete from temp folder

If bRenamedAttachment Then

For Each strFilePath In arrRenamedAttachments

olkItem.Attachments.Add strFilePath

objFSO.DeleteFile strFilePath

End If

Else

noAttach = MsgBox("There are no attachments in the message.", vbOKOnly)

End If

Set olkItem = Nothing

Set olkAttachment = Nothing

Set olkPA = Nothing

Set objFSO = Nothing

End Sub

sidefumbling

The consequence of not having six hydrocoptic marzelvanes fitted to the ambifacient lunar waneshaft.

Category Archives: VBA

New form for creating travel time appointments in Outlook

Articles in the "Outlook Travel Time Appointments" series

Outlook macro to assign retention policy when item is deleted

Add travel time appointments in Outlook

Articles in the "Outlook Travel Time Appointments" series

Rename Outlook attachments before you send them