Linking access with outlook (1 Viewer)

[Kuleesha]

Hi,
I have a form which is used to give appointments. I need these appointments to show up in outlook calendar. I have successed partially by using following vba code in public function and then calling on this function in the VBA code of the form:

Public Function AddAppointment(ByVal BD As Date, ByVal Endo As String, ByVal Pt As String, ByVal Hos As String, ByVal CN As Long) As Boolean
Dim Ol As Outlook.Application
Dim appt As Outlook.AppointmentItem

Set Ol = New Outlook.Application
Set appt = Ol.CreateItem(olAppointmentItem)

With appt
.Start = BD
.Duration = 0
.Subject = Endo
.Location = Hos
.Body = Pt & " " & CN
.ReminderSet = False
.Save
End With
Set appt = Nothing
Set Ol = Nothing
AddAppointment = True

End Function

Since this doesnt work if outlook in not open, I have following code to open outlook if not already open:

Private Sub fireOutlook()
Dim olShellVal As Long
Dim g_olApp As Object

On Error GoTo FIREOUTLOOK_ERR
Set g_olApp = GetObject(, "Outlook.Application")

If g_olApp Is Nothing Then
olShellVal = Shell("OUTLOOK", vbNormalNoFocus)
Set g_olApp = CreateObject("Outlook.Application")
g_olApp.ActiveExplorer.WindowState = 1
End If

FIREOUTLOOK_EXIT:
Exit Sub

FIREOUTLOOK_ERR:
If g_olApp Is Nothing Then
Err.Clear
Resume Next
Else
MsgBox Err.Description, , "Error Number: " & Err.Number
End If
GoTo FIREOUTLOOK_EXIT
End Sub

This saves the appointments under calender folder in outlook. However I need for these to be saved under another calender (named "Private") which I have created as a subfolder of the main calendar folder.
Despite trying different things I have been unable to achieve this. Any ideas on how this can be achieved?
Thanks in advance

 

[Gasman]

See if this helps

Save appointments to a non-default Outlook calendar folder

Use a VBA macro to move new appointments (or contacts) to a different folder. Can be used to move appointments and contacts to Hotmail or iCloud folders.

www.slipstick.com

 

[Kuleesha]

See if this helps

Save appointments to a non-default Outlook calendar folder

Use a VBA macro to move new appointments (or contacts) to a different folder. Can be used to move appointments and contacts to Hotmail or iCloud folders.

www.slipstick.com

Thanks but I cannot figure out how to use this in my situation.
I tried adding following code to the public function but i get an error that he object could not be found

Dim Ol As Outlook.Application
Dim appt As Outlook.AppointmentItem
Dim Ns As Outlook.NameSpace
Dim myDestFolder As Outlook.Folder

Set Ol = New Outlook.Application
Set appt = Ol.CreateItem(olAppointmentItem)
Set Ns = Ol.GetNamespace("MAPI")
Set myDestFolder = Ns.GetDefaultFolder(olFolderCalendar)
Set myDestFolder = myDestFolder.Folders("Private")

 

[Minty]

This is an interesting problem.
In Outlook you can't simply refer to a specific folder directly, it doesn't seem to expose the folders as a "path". Which I think is bonkers, but I'm happy to be proved wrong.

You have to cycle down through the "path" to the folder you want.

So let's assume your know that the folder is in the path of Inbox¬Clients¬Private .
To get to it you can refer to a top level (e.g. Directly under the inbox) like this

    Dim OlApp         As Outlook.Application
    Dim OlNs        As Outlook.NameSpace
    Dim Inbox         As Outlook.MAPIFolder
    Dim olParent     As Object
    Dim olFolder     As Object
    Dim InboxItems     As Outlook.Items
    Dim Mailobject     As Object

    Const olFolderInbox = 6     '   This is the inbox constant
  
    Set OlApp = CreateObject("Outlook.Application")
    Set OlNs = OlApp.GetNamespace("Mapi")

   '     This will get you to the first level Inbox ¬ Clients
    Set olParent = OlNs.GetDefaultFolder(olFolderInbox).Folders("Clients")
    Debug.Print olParent.Name
   '        This then sets that down one level
    Set olFolder = olParent.Folders("Private")
  
    '      Now we can loop through the mailbox contents and look for "stuff"
    Set InboxItems = olFolder.Items
  
    For Each Mailobject In InboxItems
        If Mailobject.UnRead Then
                Debug.Print Mailobject.SenderEmailAddress, Mailobject.SenderName, Mailobject.SentOn, Mailobject.Subject
                 ' Debug.Print Mailobject.To
                 ' Mailobject.UnRead = False
        End If
    Next

    Set OlApp = Nothing
    Set Inbox = Nothing
    Set InboxItems = Nothing
    Set Mailobject = Nothing

Obviously, you need to be careful manipulating objects in shared mailboxes.
You'll have to excuse the mixture of late and early binding I was messing with this for a while to get it functioning.

 

[Pat Hartman]

Your code would be easier to read if you indented it correctly. Easier for YOU also.

 

[Kuleesha]

This is an interesting problem.
In Outlook you can't simply refer to a specific folder directly, it doesn't seem to expose the folders as a "path". Which I think is bonkers, but I'm happy to be proved wrong.

You have to cycle down through the "path" to the folder you want.

So let's assume your know that the folder is in the path of Inbox¬Clients¬Private .
To get to it you can refer to a top level (e.g. Directly under the inbox) like this

    Dim OlApp         As Outlook.Application
    Dim OlNs        As Outlook.NameSpace
    Dim Inbox         As Outlook.MAPIFolder
    Dim olParent     As Object
    Dim olFolder     As Object
    Dim InboxItems     As Outlook.Items
    Dim Mailobject     As Object

    Const olFolderInbox = 6     '   This is the inbox constant
 
    Set OlApp = CreateObject("Outlook.Application")
    Set OlNs = OlApp.GetNamespace("Mapi")

   '     This will get you to the first level Inbox ¬ Clients
    Set olParent = OlNs.GetDefaultFolder(olFolderInbox).Folders("Clients")
    Debug.Print olParent.Name
   '        This then sets that down one level
    Set olFolder = olParent.Folders("Private")
 
    '      Now we can loop through the mailbox contents and look for "stuff"
    Set InboxItems = olFolder.Items
 
    For Each Mailobject In InboxItems
        If Mailobject.UnRead Then
                Debug.Print Mailobject.SenderEmailAddress, Mailobject.SenderName, Mailobject.SentOn, Mailobject.Subject
                 ' Debug.Print Mailobject.To
                 ' Mailobject.UnRead = False
        End If
    Next

    Set OlApp = Nothing
    Set Inbox = Nothing
    Set InboxItems = Nothing
    Set Mailobject = Nothing

Obviously, you need to be careful manipulating objects in shared mailboxes.
You'll have to excuse the mixture of late and early binding I was messing with this for a while to get it functioning.

Thank you for this.
I am actually trying to access the calender folders (not mail). I have a calendar called "private" under the calender folder and want to create appointments in this.

 

[Minty]

Thank you for this.
I am actually trying to access the calender folders (not mail). I have a calendar called "private" under the calender folder and want to create appointments in this.

I think you simply change the constant at the beginning to 9?

Const olFolderInbox = 6 9

From here https://docs.microsoft.com/en-us/office/vba/api/outlook.oldefaultfolders

 

[Kuleesha]

I think you simply change the constant at the beginning to 9?

Const olFolderInbox = 6 9

From here https://docs.microsoft.com/en-us/office/vba/api/outlook.oldefaultfolders

This didn't work.
I tried modifying my code as follows but still get the same error messsage (object not found)

Sub ShowCalendar()

    Dim olApp As Outlook.Application
    Dim olNs As NameSpace
Dim olParent As Object

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")


    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.Application")
    End If


    On Error GoTo 0


    Set olNs = olApp.GetNamespace("MAPI")


    If olApp.ActiveExplorer Is Nothing Then
    olApp.Explorers.Add(olNs.GetDefaultFolder(olFolderCalendar)).Activate
    olApp.ActiveExplorer.WindowState = 1
    Else
        Set olApp.ActiveExplorer.CurrentFolder = olNs.GetDefaultFolder(olFolderCalendar).Folders("Private")
        olApp.ActiveExplorer.WindowState = 1
    End If


    Set olNs = Nothing
    Set olApp = Nothing


End Sub

Public Function AddAppointment(ByVal BD As Date, ByVal Endo As String, ByVal PT As String, ByVal Hos As String, ByVal CN As Long) As Boolean
Dim Ol As Outlook.Application
Dim appt As Outlook.AppointmentItem

Set Ol = New Outlook.Application
Set appt = Ol.CreateItem(olAppointmentItem)

With appt
.Start = BD
.Duration = 0
.Subject = Endo
.Location = Hos
.Body = PT & " " & CN
.ReminderSet = False
.Save
End With
Set appt = Nothing
Set Ol = Nothing
AddAppointment = True

End Function

 

[Pat Hartman]

What line raises the error?

 

[Kuleesha]

What line raises the error?

Actually it's not an error message I get with above code.
Even with above code trying to direct the appointment into the private folder, the appoitment gets saved in the parent folder (calendar).
Below is the folder structure I am using:

The error threw up when I tried to place the private folder at same level as parent folder and changed the code to: olNs.GetDefaultFolder(olFolderCalendar).Parent.Folders("Private")
In this case above was the line that threw up the error.

 

[Kuleesha]

Managed to get it working with following code I found at another site :

Public Function AddAppointmentP(ByVal BD As Date, ByVal Endo As String, ByVal PT As String, ByVal Hos As String, ByVal CN As Long) As Boolean
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim olFldr As Outlook.Folder
Dim olNS As Outlook.NameSpace

Set olApp = New Outlook.Application
Set olFldr = olApp.GetNamespace("MAPI").GetDefaultFolder(9).Folders("Private")
Set olAppt = olFldr.Items.Add

With olAppt
.Start = BD
.Duration = 0
.Subject = Endo
.Location = Hos
.Body = PT & " " & CN
.ReminderSet = False
.Save
End With

    Set olApp = Nothing
    Set olAppt = Nothing
    Set olFldr = Nothing

End Function