Deleting Only Attachments of all Outlook Calender Enteries.

Posted on 2009-07-02
Last Modified: 2012-05-07
Help get this code working.

I ran the code found in:

When I enter the date in various formats I always get Run-time error 'Cannot save the attachment.'

Debug focus on:
                            .attachments.Item(intCount).SaveAsFile myOrt & _
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"


        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 <= CDate(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 & _



                            intAttachmentsRemoved = intAttachmentsRemoved + 1



                    End If

                End If

            End With


        If intMsgsInDateRange = 0 Then

            MsgBox "All done.  There were no messages in the date range specified.", vbInformation + vbOKOnly, "Delete Calendar Attachments Macro"


            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

Question by:Dooglave
LVL 13

Accepted Solution

ioane earned 500 total points
ID: 24769713
Do you have an H: drive?

Author Comment

ID: 24795663
lol, no.  I bet that's it.   Thanks I'll get back to you when I have time to do this again.

Featured Post

What is SQL Server and how does it work?

The purpose of this paper is to provide you background on SQL Server. It’s your self-study guide for learning fundamentals. It includes both the history of SQL and its technical basics. Concepts and definitions will form the solid foundation of your future DBA expertise.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Outlook keeps opened file locked 2 55
Update As Well As Add 6 38
exchange, outlook 4 18
Excel - find text within text? 1 24
Outlook Free & Paid Tools
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

911 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now