[Sporadic]

Hey guys, I had some great assistance from computerman29642 earlier on this macro. It works perfectly on my own calendar; however, I need to target a specific shared calendar. Hopefully it could be user imput by a msg box. I am struggling to find information on how to do this.

The first thread was this
http://forums.techguy.org/business-a...-calendar.html

So, as for now the example works. But before it writes to the calendar I want a msg box pops up asking for the desired calendar(Sometimes more than one word), and then target that calendar and write the data. A simple little box that confirms or denies progress (I am pretty sure I can figure that one out) Any suggestions or directions where I can learn more fire away please. Ill attach a copy of my test again.

[computerman29642]

Sporadic, I do not have the capability to create or use shared calendars, but I will do my best to lend you a hand.

Let me do some research.

[Sporadic]

Thanks Computerman! Always appreciate the help I may have found a way around it if it can't be done.

[computerman29642]

I apologize Sporadic. I have been extremely busy here at work, and I have not had time to look into the issue as I would have liked to do.

I will try to take a look at this issue again this weekend.

[Sporadic]

No need to apologize computerman any help at any time is welcome Don't stress about it if you get the time take a peak. I have been crazy busy too. Any help whenever is much appreciated so again no worries

[Zack Barresse]

Hi there,

Although I can't test this where I'm at, maybe you could try something like this ...

Sub ExportAppointmentsToOutlook()

    Dim olApp As Outlook.Application
    Dim olFolder As Outlook.MAPIFolder      '**
    Dim olSubfolder As Outlook.MAPIFolder   '**
    Dim olApt As Outlook.AppointmentItem    '*
    Dim sCalendar As String                 '**
    Dim blnCreated As Boolean
    Dim x As Variant, LastRow As Long, ws As Worksheet
    
'Read the table with appointments:
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    On Error GoTo 0

    Set ws = ActiveWorkbook.ActiveSheet     '*
    
    With ws.Range("A2:B" & ws.Rows.Count)
        LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    sCalendar = InputBox("Calendar Name Please")
    
    'Code to access another calender (folder)
    Set olFolder = Application.Session.GetDefaultFolder(olFolderCalendar)
    On Error Resume Next
    Set olSubfolder = Folder.Folders(sCalendar)
    If olSubfolder Is Nothing Then
        'an error occured
        MsgBox "An error occured attempting that Calendar!", vbExclamation, "ERROR!"
        'do whatever you want
    End If
    Set olApt = olSubfolder.Items.Add
    
    For x = 2 To LastRow
'    Set olApt = olApp.CreateItem(olAppointmentItem) '*
    With olApt
        .Start = Range("B" & x).Value
        .End = Range("C" & x).Value
        .Subject = Range("A" & x).Value
        .Location = Range("D" & x).Value
        .BusyStatus = olBusy
        .ReminderSet = False
        .AllDayEvent = True
        .Save
    End With
    Next x

    If blnCreated = True Then olApp.Quit    '*
    
    Set olApt = Nothing
    Set olApp = Nothing

End Sub

Ensure you save a copy of the file prior to testing. Let us know how it works.

[Sporadic]

Thank you I appreciate you taking the time to write up some code. It is currently giving me a Compile error: User-defined type not defined. And it is highlighting
Sub ExportAppointmentsToOutlook
Dim olApp As Outlook.Application
I am going to try to look up what all that means and fiddle around with it. This is an awesome start Thank you again

[Zack Barresse]

Well, the dimensioning (Dim lines) are an Early binding. If you don't have the Outlook reference set, it will give you a compile error. Go (in the VBE) to Tools | References. List what is checked. If Microsoft Outlook xx.0 Object Library (where xx.0 is your version number) is not checked, find it and check it, then click OK. Test your project (compile it) by using the keyboard shortcut Alt + D, L.

Does that help?

[Sporadic]

Okay, I did that when I run it it now gives me a
Run-time error '91' Object or varible or With block variable not set.
Not exaclty sure where that error is comming from ill continue to try to find it

[Sporadic]

End With
sCalendar = InputBox("Calendar Name Please")

'Code to access another calender (folder)
Set olFolder = Application.Session.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set olSubfolder = Folder.Folders(sCalendar)
If olSubfolder Is Nothing Then
'an error occured
MsgBox "An error occured attempting that Calendar!", vbExclamation, "ERROR!"
'do whatever you want
End If
Set olApt = olSubfolder.Items.Add


I can run my debugger up to this point before it gives me the error. So, I assume that it must be here or further down. I am not sure how to check below a certain point.

[Zack Barresse]

What line is highlighted when you debug? And after you debug, can you step through each line with F8, and what line does it stop on? (Sometimes these two are different, sometimes they are the same, which tells us different things.)

[Sporadic]

LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

is the line it will stop at. It won't let me past it. This line is just above the End With that I posted ealier

[Zack Barresse]

That's because you have nothing in those cells, and the Find method will error out if there is nothing to find. Try replacing the following lines of code...

    With ws.Range("A2:B" & ws.Rows.Count)
        LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With

... with this code ...

    With ws.Range("A2:B" & ws.Rows.Count)
        If WorksheetFunction.CountA(.Cells) = 0 Then
            LastRow = 0 'you don't REALLY need this line, since it'll already be zero..
        Else
            LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        End If
    End With

[Sporadic]

Awesome thank you that has cleared that part now. It gives me an error after I attempt to type the calendar in.
Set olFolder = Application.Session.GetDefaultFolder(olFolderCalendar) is where the debugger stops.

Run-time '438'
Object doesn't support this property or method

Thanks again for the help if this is starting to stress you id understand it boggles my mind how you can pick this stuff apart how you do.

[Zack Barresse]

Right-o, didn't catch that. On that line, change the Application to olApp. On the line just below it (2 lines below), change it from Folder.Folders(sCalendar) to olFolder.Folders(sCalendar) (just add the "ol" in front of it).