Search Outlook Appionments (Need to delete some) (1 Viewer)

[robyholmes]

Hi, I have posted about this before, but never got anywhere, and seen as I have a bit of time off again, I am back to try again.

I am wanting to find and delete all Appointments with a * or any other character. This is so I can then add them again using VBA code from my database.

So I have this code currently:

Public mobjOLA As Outlook.Application
Public mobjNS As Outlook.NameSpace
Public mobjFLDR As Outlook.MAPIFolder
Public mobjAPPT As Outlook.AppointmentItem

'##CDO (COLLABORATION DATA OBJECTS) VARIABLES##


Public dteStart As Date
Public dteEnd As Date
Public bolEvent As Boolean
Public strSubject As String
Public strBody As String
Public strLocation As String
Public strCategory As String
Public strStatus As String
Public bolAddToOutlook As Boolean
Public strFindAppt As String

Public Sub CollectData()
    '--------------------------------------------------------------------------------
    'This collects the current data from the table and stores it for the loop
    '--------------------------------------------------------------------------------
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qrycalendar")
    Do Until rs.EOF
        With rs
            strSubject = !Appt
            strLocation = !ApptCat
            dteStart = !ApptDate
            dteEnd = !ApptEnd
            strBody = !ApptNotes
            'bolEvent = !AllDayEvent
            strCategory = !ApptCat
            strStatus = "Free"
            bolAddToOutlook = !AddedToOutlook
        End With
        'SET THE SEARCH VARIABLE
        strFindAppt = dteStart & " " & strSubject
        'CHECK FOR ENTRIES
        If strAddToOutlook = False Then
            'ADD THE APPT IF IT NOT SET TO TRUE
            AddAppt
            rs.Edit
            rs!AddedToOutlook = True
            rs.Update
        
        Else
        End If
        rs.MoveNext
    Loop
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing

    MsgBox ("All Appointments are entered into Outlook")

End Sub

Public Sub AddAppt()

    Dim outMail As Outlook.AppointmentItem
    'set the outlook connection
    Set mobjOLA = CreateObject("Outlook.Application")
    Set mobjNS = mobjOLA.GetNamespace("MAPI")
    mobjNS.Logon , , False, False
    Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
    On Error Resume Next
    Set mobjAPPT = mobjFLDR.Items(strFindAppt)
    'check for appointment set. if it is, bail and go to bottom
    If Err.Number = 0 Then GoTo FoundObject
    'collect the user preferences and add to the appointment
    Set outMail = Outlook.CreateItem(olAppointmentItem)
    With outMail
        .Subject = strFindAppt
        .Location = strLocation
        .Start = dteStart
        .End = dteEnd
        .Body = strBody
        .AllDayEvent = bolEvent
        .Categories = strCategory
        .BusyStatus = Free
        .Save
    End With
    'show message if appointment is created
    '    MsgBox ("Success!! Your appointment has been placed")
Bye:
    'close the connection
    Set mobjAPPT = Nothing
    Set mobjFLDR = Nothing
    Set mobjNS = Nothing
    Set mobjOLA = Nothing
    Exit Sub
    'arrive here if the appointment is already set
FoundObject:
    MsgBox "Halt!! Appointment Already Placed!" & vbCrLf & _
    strFindAppt, _
    vbOKOnly, "Information"
    GoTo Bye
End Sub

Public Sub RunDeleteAppt()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qrycalendar1")
    Do Until rs.EOF
        With rs
            dteStart = !ApptDate
            dteEnd = !ApptEnd
            'bolEvent = !AllDayEvent
            strSubject = !Appt
            strBody = !ApptNotes
            strLocation = !ApptLocation
            'strCategory = !Category
            'strStatus = !Status
            bolAddToOutlook = !AddedToOutlook
        End With
        'SET THE SEARCH VARIABLE
        strFindAppt = "*"
        'CHECK FOR ENTRIES
        If bolAddToOutlook = True Then
            'ADD THE APPT IF IT NOT SET TO TRUE
            Call DeleteAppt(strFindAppt)
            rs.Edit
            rs!AddedToOutlook = False
            rs.Update

        Else
        End If
        rs.MoveNext
    Loop
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    
    MsgBox ("All Appointments have been removed from Outlook")

    End Sub

Public Sub DeleteAppt()
    strFindAppt = strFindAppt

    '   Use this method ONLY if the subject of the
    '   Appointment Item is known and is UNIQUE.
    strFindAppt = "*"
    Set mobjOLA = CreateObject("Outlook.Application")
    Set mobjNS = mobjOLA.GetNamespace("MAPI")
    mobjNS.Logon , , False, False
    Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
    On Error Resume Next
    Set mobjAPPT = mobjFLDR.Items(strFindAppt)
    If Err.Number <> 0 Then GoTo CannotFindObject
    mobjAPPT.Delete

    'MsgBox ("Success!! Your appointment has been deleted")
Bye:
    Set mobjAPPT = Nothing
    Set mobjFLDR = Nothing
    Set mobjNS = Nothing
    Set mobjOLA = Nothing
    Exit Sub
CannotFindObject:
    MsgBox "Cannot find Appointment Item to delete. " & vbCrLf & _
    strFindAppt, _
    vbOKOnly, "Information"
    GoTo Bye
End Sub

Now this was created by someone on here (A long time ago) and was made to find the subject line of a appiontment in my database and update it in outlook if its been updated. The problem is the subject line contains information that may change, and so the appointment wouldn't be able to be found and a copy placed in outlook.

So I thought If I could delete all the appointments in outlook that the database has added (I have another code for this) and place a * or something in the subject, then it could search for that and delete it. Then add them again.

The problem is, this code:

        'SET THE SEARCH VARIABLE
        strFindAppt = "*"
        'CHECK FOR ENTRIES
        If bolAddToOutlook = True Then
            'ADD THE APPT IF IT NOT SET TO TRUE
            Call DeleteAppt(strFindAppt)

doesn't use a wildcard, it only finds and deletes subjects with * in. I need to search with a wild card after the * so '* Appointment Name' and '* Another Appointment Name' will be deleted.

Thanks

 

[darbid]

I think normally one could use

strfind = "[Subject] = " & Chr(34) & strFindAppt & Chr(34)
    Set mobjAPPT = mobjFLDR.Items.Find(strfind)

but this will NOT work if you want to find part of a string so you cannot use the find method.

It appears that you could use the Application.AdvanceSearch method but that looks complicated

The other way is you are going to have to set up a loop for example

mobjFLDR.Items.Count

will tell you how many items are in your folder - then you are going to have to loop through each item and do something like

 if instr(mobjAPPT.Subject,"*") then
do somthing
end if

The only thing is that this might take a while if you have thousands of appointments.

I have never done it but an appoitment item has a unique "EntryID" if VBA is making your Appointment items then after it is saved get the entryid of that item before you destroy the object and save that in your database.

Then to get that again you use "namespace.GetItemFromID(!myid)" with myid being what you saved before in the database

 

[darbid]

Actually you already know what I have told you cause you have already asked this question before. Did you not like the answer last time?

http://www.access-programmers.co.uk/forums/showthread.php?t=172500&highlight=outlook

 

[robyholmes]

Actually you already know what I have told you cause you have already asked this question before. Did you not like the answer last time?

http://www.access-programmers.co.uk/forums/showthread.php?t=172500&highlight=outlook

Yes but I don't understand it. I have only just got in to VBA and this outlook objects is mind blowing. I just wanted to find a simple solution. I could send days and days on this working it out, but I don't think I would get anywhere.

I just need a finished working code, so that as I develop my VBA skills more I can understand it later. This is for my parents business and my dad got a black berry for this job, at the mo I have to manual delete items out of outlook before adding them again. Which I don't have time for.

I'm sorry for posting twice and its cheeky to ask for a finished code, as this is shipping work on to you. But I have been working on this database for years now. Sorry

 

[robyholmes]

For the advanced search one, I could only add bookings that are from 1 week ago, which at the mo is:
36 at the moment (Its only 3 cottages and past bookings can be removed) So this was 29th June onwards, this can be done in a simple query.
So I just need a code that will delete all the appointments with * or something else at the start, the rest I can do using my current code to add things which will work off a query.

Thanks

 

[darbid]

I just need a finished working code, so that as I develop my VBA skills more I can understand it later. This is for my parents business and my dad got a black berry for this job, at the mo I have to manual delete items out of outlook before adding them again. Which I don't have time for.

I was in your position too so i know what it is like but you really must learn from the hours of testing, errors and pulling your hair out.

So in your code after setting this

Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)

mobjFLDR is going to hold an array of ALL your appointment items. The idea is that you now go through them one at a time and test for your "*" in the subject which is a property of an appointment item.

For i = 1 To (mobjFLDR.Items.Count - 1)  'it starts at 1 not 0 so you might not need the "-1"

    mobjAPPT = mobjFLDR.Items.Item(i) 'this will give you the 1st, 2nd etc appointment item


    If InStr(1, mobjAPPT.Subject, "this") > 0 And Len(mobjAPPT.Subject) > 1 Then

        'Perform the necessary action to the appointment

    End If

Next i

jjturner pretty much did this, I have just added some new things.

 

[robyholmes]

So this is the code:

Public Sub DeleteAppt()
    strFindAppt = strFindAppt

    '   Use this method ONLY if the subject of the
    '   Appointment Item is known and is UNIQUE.
    strFindAppt = "*"
    Set mobjOLA = CreateObject("Outlook.Application")
    Set mobjNS = mobjOLA.GetNamespace("MAPI")
    mobjNS.Logon , , False, False
    Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
    'New code to search for * in subject line and delete it
    For i = 1 To (mobjFLDR.Items.Count - 1)  'it starts at 1 not 0 so you might not need the "-1"
    mobjAPPT = mobjFLDR.Items.Item(i) 'this will give you the 1st, 2nd etc appointment item
    If InStr(1, mobjAPPT.Subject, "this") > 0 And Len(mobjAPPT.Subject) > 1 Then
        'Perform the necessary action to the appointment
        mobjAPPT.Delete
    End If
    Next i
End Sub

So If I call 'DeleteAppt()' it will delete all the apportionments with * in them?

If so, GREAT! I will start making some appointments to test it.

EDIT, ok looking at your code, I see:
mobjAPPT.Subject, "this"
Does the InStr mean its looking for 'this' in the subject, so I can change it to '*'?

Also I have put the variables in the top
Public mobjOLA As Outlook.Application
Public mobjNS As Outlook.NameSpace
Public mobjFLDR As Outlook.MAPIFolder
Public mobjAPPT As Outlook.AppointmentItem

 

[darbid]

Great and let me know if the "-1" is needed.

 

[robyholmes]

I get 'Runtime 91' Variable or Block variable not set on:

mobjAPPT = mobjFLDR.Items.Item(i) 'this will give you the 1st, 2nd etc appointment item

With or without the -1

 

[darbid]

Try testing a few things to see why you get that?

so what do you get for this?

debug.print mobjFLDR.Items.Count

Where are your variables declared?

Do you have a variable "i" declared

 

[darbid]

I think you will find that you need a "set" in there.

Another way of doing this (i am a learner too) might be like this

For Each mobjAPPT In mobjFLDR.Items
    If InStr(mobjAPPT.Subject, "test") And Len(mobjAPPT.Subject) > 1 Then
        'Perform the necessary action to the appointment
            Debug.Print mobjAPPT.Subject
           ' mobjAPPT.Delete
    End If
Next mobjAPPT

You can see that I am testing this to get the results to see what it finds.

 

[robyholmes]

Ok, I have got it to work, with this code:

Option Compare Database
Public mobjOLA As Outlook.Application
Public mobjNS As Outlook.NameSpace
Public mobjFLDR As Outlook.MAPIFolder
Public mobjAPPT As Outlook.AppointmentItem
Public i As Integer


Public Sub DeleteAppts()
    strFindAppt = strFindAppt

    '   Use this method ONLY if the subject of the
    '   Appointment Item is known and is UNIQUE.
    strFindAppt = "*"
    Set mobjOLA = CreateObject("Outlook.Application")
    Set mobjNS = mobjOLA.GetNamespace("MAPI")
    mobjNS.Logon , , False, False
    Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
    'New code to search for * in subject line and delete it
    For Each mobjAPPT In mobjFLDR.Items
        If InStr(mobjAPPT.Subject, "*") And Len(mobjAPPT.Subject) > 1 Then
            'Perform the necessary action to the appointment
                mobjAPPT.Delete
        End If
    Next mobjAPPT
End Sub

But it delete half the number of appointments in outlook every-time. So I currently have 2 none cottage appiontments that want to stay, and 91 added form my cottage database. So 93, the first time run, its 47, then 24, then 12, 6, 3, 0

Has this to do with the count, you had -1 before. Do I need to do this to mobjFLDR.Items somehow? Or is it something else

Thanks a lot
Rob Holmes

 

[darbid]

No idea what the problem could be.

I would suggest you get the count for the items and then put a counter in the loop to see that it loops through as many times as your initial count. If it does then there might be something wrong with the If inst part and the subject.