Saving a outlook appointment in the non default account

In my outlook program I have 2 accounts.  I´m trying to save a appointment in then non default account  but I don´t have any idea how to do it.
Could somebody help  how to do it? thanks.

This is my code buy saved it in the default account

Private Sub AddAppt_Click()
On Error GoTo AddAppt_Err
         ' Primeramente guardar el registro para asegurarnos que los campos requeridos han sido editados.
         DoCmd.RunCommand acCmdSaveRecord
         
         ' Cerrar el procedimiento si la cita ya ha sido agregada previamente a Outlook.
         If Me!AddedToOutlook = True Then
            MsgBox "Esta cita ya ha sido añadida al calendario de Microsoft Outlook"
            Exit Sub
         
         Else
            ' Añadir una nueva cita.
            Const BodyWarning = "Outlook generó esta cita automáticamente basándose en la información recibida de BGB."
            Dim outobj As Outlook.Application
            Dim outappt As Outlook.AppointmentItem
            Dim response As Variant
            Set outobj = CreateObject("outlook.application")
            Set outappt = outobj.CreateItem(olAppointmentItem)
            With outappt
               .start = Me!ApptDate & " " & Me!ApptTime
               .Duration = Me!ApptLength
               .Subject = Me!Appt
               .Body = Nz(Me!ApptNotes, vbNullString) & vbNewLine & vbNewLine & vbNewLine & Space(50) & BodyWarning
               If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation
               If Me!ApptReminder Then
                  .ReminderMinutesBeforeStart = Me!ReminderMinutes
                  .ReminderSet = True
               End If
               .Save
            End With
         End If
         
         ' Quitar la variable objeto de memoria.
         outobj.Quit
         Set outobj = Nothing
         Set outappt = Nothing
         
         ' Set the AddedToOutlook flag, save the record, display a message.
         Me!AddedToOutlook = True
         DoCmd.RunCommand acCmdSaveRecord
         
         ' Pregunta si desea añadir una cita mas...
         response = MsgBox("La cita ya ha sido añadida!." & vbNewLine & "¿Desea añadir otra cita más al calendario" & _
         "de Outlook?", vbInformation + vbYesNo + vbDefaultButton2, "Cita Añadida a Microsoft Outlook")
         Select Case response
            Case vbYes
                ' Añade un registro en blanco para ser editado
                DoCmd.RunCommand acCmdRecordsGoToNew
                ' Establecer foco en el cuadro de texto 'Asunto'
                Me!TxtAsunto.SetFocus
            Case vbNo
                ' Cierra la ventana
                DoCmd.Close acForm, Me.Name
         End Select
         
frmBye:
    Exit Sub

AddAppt_Err:
         UnexpectedErrorMsg Err.Number, Err.Description, Me.Caption
         Err.Clear
         Resume frmBye

End Sub

Open in new window

José Luis José LuisAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

mbizupCommented:
CreateItem will always add to  the default folder (that's just the way it works, and can't be changed).  What you want to do is use the ADD method to create the appointment in the desired folder.  Give this a try, making the appropriate substitutions to specify the correct account folder, and work it into your own code.


    Dim outobj As Object
    Dim outNS As Object
    Dim outappt As Object
    
    Set outobj = CreateObject("outlook.application")
    Set outNS = outobj.GetNamespace("MAPI")
    Set outappt = outNS.Folders.Item("Your account").Folders.Item("Calendar").Items.Add(olAppointmentItem)
    
    With outappt
        .start = Me!ApptDate & " " & Me!ApptTime
        .Duration = Me!ApptLength
        .Subject = Me!Appt
        .Body = Nz(Me!ApptNotes, vbNullString) & vbNewLine & vbNewLine & vbNewLine & Space(50) & BodyWarning
        If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation
        If Me!ApptReminder Then
            .ReminderMinutesBeforeStart = Me!ReminderMinutes
            .ReminderSet = True
        End If
        .Save
    End With

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
José Luis José LuisAuthor Commented:
Thanks for the reply.  I will test it and  later on I will tell you the result. Thanks.
0
José Luis José LuisAuthor Commented:
Thank you very much for the solution. I tried it and it works perfectly. Thank you.
1
José Luis José LuisAuthor Commented:
' Añadir una nueva cita.
            Const BodyWarning = "Outlook agregó automáticamente esta cita al calendario basándose en la información recibida desde BGB."
            Dim outobj As Outlook.Application
            Dim outNS As Outlook.NameSpace
            Dim outappt As Outlook.AppointmentItem
            Dim response As Variant
       
            Set outobj = CreateObject("outlook.application")
            Set outNS = outobj.GetNamespace("MAPI")
            Set outappt = outNS.Folders.Item(1).Folders.Item("Calendario").Items.Add(olAppointmentItem)
   
            With outappt
               .start = Me!ApptDate & " " & Me!ApptTime
               .Duration = Me!ApptLength
               .Subject = Me!Appt
               .Body = Nz(Me!ApptNotes, vbNullString) & vbNewLine & vbNewLine & vbNewLine & Space(40) & BodyWarning
               If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation
               If Me!ApptReminder Then
                  .ReminderMinutesBeforeStart = Me!ReminderMinutes
                  .ReminderSet = True
               End If
               .Save
            End With
        End If
         
         ' Quitar la variable objeto de memoria.
        outobj.Quit
        Set outobj = Nothing
        Set outNS = Nothing
        Set outappt = Nothing
0
mbizupCommented:
Glad I could help!  Good luck with your project.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.