asked on

remove attachments from callendar in outlook

I am putting some code in place to remove attachments from outlook calendars, the code (attached) works perfectly as long as their is a value for date and their are attachments in the period being run. If incorrect or blank value is put in date it produces a runtime error 13 type mismatch, and if there are no attachments in the month being looked at it produces the same error.
I understand the error is generated because there are null values.

What i would like assistance with is implementing some code that if either the date is blank or in an incorrect format it prompts the user to put a date in or exit the macro, secondly if there are no attachments found in the period being looked at, that it puts a message no attachments found and on closing the message exits the macro.

Finally is there any way i can get this code to prompt for the location to store the attachments (allow user to create the folder when the macro runs) this last one is a nice to have the first two issues relating to date and attachments are the crucial issues.

The code follows:

Sub DeleteCalendarAttachments()

Dim strEnd As Date
Dim myOrt As String
Dim olkCalendar As Outlook.MAPIFolder, _
olkAppointment As Outlook.AppointmentItem, _
intCount As Integer, _
intItemsWithAttachments As Integer, _
intAttachmentsRemoved As Integer

strEnd = Format(InputBox("Enter the end date (DD/MM/YYYY:)"), "ddddd") 'user input last date to remove appointments

myOrt = "H:\Attachments\"

'create a string to use to filter the outlook items

Set olkCalendar = Application.ActiveExplorer.CurrentFolder
For Each olkAppointment In olkCalendar.Items
With olkAppointment
'Change the dates on the next line as desired
If .Start <= strEnd Then
If .Attachments.Count > 0 Then
intItemsWithAttachments = intItemsWithAttachments + 1
For intCount = .Attachments.Count To 1 Step -1
.Attachments.Item(intCount).SaveAsFile myOrt & _
.Attachments.Item(intCount).DisplayName
.Attachments.Item(intCount).Delete
intAttachmentsRemoved = intAttachmentsRemoved + 1
Next
.Save
End If
End If
End With
Next
Set olkAppointment = Nothing
Set olkCalendar = Nothing
MsgBox "All done!" & vbCrLf & "We removed " & intAttachmentsRemoved & " attachments from " & _
intItemsWithAttachments & " appointments.", vbInformation + vbOKOnly, "Delete Calendar Attachments Macro"
End Sub

I have assigned top points as a solution is urgetly required

Cheers for the help

David Lee

Hi, 3Dstudi0.

If I've understood correctly, then I think the version below will do what you want.

Sub DeleteCalendarAttachments()
    Dim strEnd As Date, _
        myOrt As String, _
        olkCalendar As Outlook.MAPIFolder, _
        olkAppointment As Outlook.AppointmentItem, _
        intCount As Integer, _
        intMsgsInDateRange As Integer, _
        intItemsWithAttachments As Integer, _
        intAttachmentsRemoved As Integer
    strEnd = Format(InputBox("Enter the end date (DD/MM/YYYY:)"), "ddddd") 'user input last date to remove appointments
    If Not IsDate(strDate) Then
        MsgBox "No date entered.  Run again and enter a date.", vbCritical + vbOKOnly, "DeleteCalnedarAttachments - Error"
    Else
        myOrt = "H:\Attachments\"
        Set olkCalendar = Application.ActiveExplorer.CurrentFolder
        For Each olkAppointment In olkCalendar.items
            With olkAppointment
                'Change the dates on the next line as desired
                If .Start <= strEnd Then
                    intMsgsInDateRange = intMsgsInDateRange + 1
                    If .Attachments.Count > 0 Then
                        intItemsWithAttachments = intItemsWithAttachments + 1
                        For intCount = .Attachments.Count To 1 Step -1
                            .Attachments.Item(intCount).SaveAsFile myOrt & _
                            .Attachments.Item(intCount).DisplayName
                            .Attachments.Item(intCount).Delete
                            intAttachmentsRemoved = intAttachmentsRemoved + 1
                        Next
                        .Save
                    End If
                End If
            End With
        Next
    End If
    Set olkAppointment = Nothing
    Set olkCalendar = Nothing
    If intMsgsInDateRange = 0 Then
        MsgBox "All done.  There were no messages in the date range specified.", vbInformation + vbOKOnly, "Delete Calendar Attachments Macro"
    Else
        MsgBox "All done!" & vbCrLf & "We removed " & intAttachmentsRemoved & " attachments from " & _
            intItemsWithAttachments & " appointments.", vbInformation + vbOKOnly, "Delete Calendar Attachments Macro"
    End If
End Sub

Open in new window

3Dstudi0

ASKER

BlueDevilFan, almost what i need! is there some way to include if the date is null, for example if you run the macro and when the date input box appears if you either press cancel or leave it blank and hit ok,currently it creates the error,what i want is in these instances is to bring up the msgbox you used for If Not isDate

Hope this makes sense
Cheers

David Lee

I fixed that problem, but I see I had a typo. Change line 11 to

If Not IsDate(strEnd) Then

3Dstudi0

ASKER

It still produces the run time error 13 type mismatch

David Lee

Ok, try this version.

Sub DeleteCalendarAttachments()
    Dim strEnd As String, _
        myOrt As String, _
        olkCalendar As Outlook.MAPIFolder, _
        olkAppointment As Outlook.AppointmentItem, _
        intCount As Integer, _
        intMsgsInDateRange As Integer, _
        intItemsWithAttachments As Integer, _
        intAttachmentsRemoved As Integer
    strEnd = Format(InputBox("Enter the end date (DD/MM/YYYY:)"), "ddddd") 'user input last date to remove appointments
    If Not IsDate(strEnd) Then
        MsgBox "No date entered.  Run again and enter a date.", vbCritical + vbOKOnly, "DeleteCalnedarAttachments - Error"
    Else
        myOrt = "H:\Attachments\"
        Set olkCalendar = Application.ActiveExplorer.CurrentFolder
        For Each olkAppointment In olkCalendar.items
            With olkAppointment
                'Change the dates on the next line as desired
                If .Start <= strEnd Then
                    intMsgsInDateRange = intMsgsInDateRange + 1
                    If .Attachments.Count > 0 Then
                        intItemsWithAttachments = intItemsWithAttachments + 1
                        For intCount = .Attachments.Count To 1 Step -1
                            .Attachments.Item(intCount).SaveAsFile myOrt & _
                            .Attachments.Item(intCount).DisplayName
                            .Attachments.Item(intCount).Delete
                            intAttachmentsRemoved = intAttachmentsRemoved + 1
                        Next
                        .Save
                    End If
                End If
            End With
        Next
        If intMsgsInDateRange = 0 Then
            MsgBox "All done.  There were no messages in the date range specified.", vbInformation + vbOKOnly, "Delete Calendar Attachments Macro"
        Else
            MsgBox "All done!" & vbCrLf & "We removed " & intAttachmentsRemoved & " attachments from " & _
                intItemsWithAttachments & " appointments.", vbInformation + vbOKOnly, "Delete Calendar Attachments Macro"
        End If
    End If
    Set olkAppointment = Nothing
    Set olkCalendar = Nothing
End Sub

Open in new window

3Dstudi0

ASKER

I tried that earlier, it works as far as blanks, but when i enter a valid date it then comes up with a type mismatch error (because the date is a string not a date)
hopefully we can get it to work for both. just for your info i am in Australia, so my date format is day/month/year
Cheers

ASKER CERTIFIED SOLUTION

David Lee

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

3Dstudi0

ASKER

Thanks for the time fixing this for me.
Cheers

David Lee

No problem. Glad I could help.