Vanuit vba/Excel een agendapunt toevoegen 2e agenda

[MEradus]

Hallo!

Ik ben bezig met een programmaatje voor wagenparkbeheer en nu wil ik graag een functie inbouwen dat er rechtstreeks in een zelf aangemaakte (2e) agenda in outlook de afspraken te staan komen. Nu heb ik al een aantal dingen geprobeerd, maar ik kom er niet uit. Ik kan die 2e agenda niet vinden....
Met onderstaande code lukt het wel, maar dan komt de afspraak in mijn eigen 'standaard' agenda te staan. En dat wil ik nou juist niet.

Is er iemand die mij kan / wil helpen?
Ik hoop het!

Private Sub CommandButton1_Click()

Dim lb1 As String
Dim lb8 As String
Dim cm1 As String

lb1 = Label1.Caption
lb8 = Label8.Caption
cm1 = ComboBox1.Value

With CreateObject("Outlook.Application").CreateItem(1)
 .Subject = cm1 & ":" & Chr(10) & "Wagen:" & Chr(10) & lb1 & Chr(10) & Chr(10) & lb8
 .Start = DateValue(DTPicker1.Value) + TimeValue(DTPicker2.Value)
 .Duration = 60
 .Location = "Werkplaats"
 .Body = TextBox1.Text
 .Save
 End With
 Me.Hide
 MsgBox "Uw afspraak is opgeslagen!", vbInformation, "Opgeslagen"
 End Sub

 

[MEradus]

Het gaat hier om een zakelijk netwerk ( exchange )
Ik hoop dat met deze nieuwe informatie mij iemand kan helpen.

( @huijb, mijn excuus wist niet dat ik de vraag geen 2x mocht stellen. )

 

[huijb]

Nee niet opnieuw stellen, de andere is inmiddels gesloten. Je kan gewoon je startpost aanpassen. Bovendien kan je ook even wachten tot je reacties krijgt.

 

[MEradus]

Aanhouder wint

Hallo allemaal,

Door te blijven zoeken op internet heb ik uiteindelijk zelf het antwoord gevonden.
Dit wil ik graag met jullie delen, misschien heeft iemand er nog iets aan.

Private Sub CommandButton1_Click()

Dim lb1 As String
Dim lb8 As String
Dim cm1 As String
Dim km As String
Dim ap As String
Dim vd As String

lb1 = Label1.Caption
lb8 = Label8.Caption
cm1 = ComboBox1.Value
km = Label10.Caption
ap = Label12.Caption
vd = DTPicker3.Value

Const olAppointmentItem As Long = 1

Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim myCalendar As Object
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

    Set OLNS = OLApp.GetNamespace("MAPI")
    OLNS.Logon
    Set myCalendar = OLApp.Session.GetDefaultFolder(9).Folders("Wagenparkbeheer")
    Set OLAppointment = myCalendar.Items.Add(olAppointmentItem)
    OLAppointment.Subject = "Reden inplannen: " & Chr(10) & cm1 & Chr(10) & "Voor wagen: " & Chr(10) & lb1 & Chr(10) & "/" & Chr(10) & lb8
    OLAppointment.Start = DateValue(DTPicker1.Value) + TimeValue(DTPicker2.Value)
    OLAppointment.Duration = "60"
    OLAppointment.Location = "Werkplaats"
    OLAppointment.Body = "Aanvullende informatie: " & Chr(13) & "Kilometerstand: " & Chr(10) & km & Chr(13) & "Vervaldatum APK: " & _
    Chr(10) & ap & Chr(13) & "Extra informatie :" & Chr(10) & TextBox1.Text & Chr(13) & Chr(13) & "Datum Melding: " & DTPicker3.Value
    OLAppointment.Save

    Set OLAppointment = Nothing
    Set OLNS = Nothing
    Set OLApp = Nothing
End If
Me.Hide
MsgBox "Uw afspraak is opgeslagen!", vbInformation, "Opgeslagen"
End Sub

 

[snb]

Dat kan veel simpeler; zie

http://www.snb-vba.eu/VBA_Outlook_external.html#L5

NB Je kunt beter code schrijven dan vinden.

 

[MEradus]

Hoi snb,

Ik ben meerdere keren op jouw site geweest en heb vanalles geprobeerd, maar op een of anderen manier lukte mij het niet om in mijn SUB-agenda te komen.
Want hier moeten namelijk de 'afspraken' in komen te staan, omdat deze agenda gedeeld gaat worden met nog 2 anderen die ook afspaken moet kunnen plaatsten.

Het is alleen de vraag of zij dat met deze code ook kunnen.

Maar zou je mij kunnen vertellen hoe ik met de code op jouw site de afspraak in de subagenda krijg?

NB Ik zou heel graag zelf alles willen zelf willen schrijven, maar ik ben nog niet zo heel lang bezig. Daarom ben ik erg blij met dit forum en ander forums!
Schrijf wel steeds meer

 

[snb]

Waarschijnljk met:

Sub afspraak_nieuw() 
  With CreateObject("Outlook.Application").Getnamespace(""MAPI").GetDefaultFolder(9).Folders("Wagenparkbeheer").Items.add 
    .subject = "Jaarvergadering"
    .Start = DateValue("06-03-2019") + TimeValue("12:30")
    .Duration = 45
    .Location = "Vergaderzaal C"
    .Save
  End With
End Sub

Schrijf wel steeds meer

Prima !!

 

[MEradus]

Geweldig!
Dank je wel, ga ik zeker uitproberen!

 

[MEradus]

Hoi snb!

De code die je mij gegeven hebt werkt voor mij wel, maar ik heb de agenda nu gedeeld met mijn collega en daar krijg ik een foutmelding ( zie rode regel ). Heb jij misschien een oplossing? De naam is naar mijn idee wel hetzelfde bij mij collega, alleen de lokatie is wat apart, maar dat zal wel liggen aan het feit dat die gedeeld is. Uiteraard ga ik ondertussen nog wel op onderzoek uit, maar als jij gelijk weet wat het zou kunnen zijn!

Sub afspraak_nieuw() 
  [COLOR="#FF0000"]With CreateObject("Outlook.Application").Getnamespace(""MAPI").GetDefaultFolder(9).Folders("Wagenparkbeheer").Items.add [/COLOR]    .subject = "Jaarvergadering"
    .Start = DateValue("06-03-2019") + TimeValue("12:30")
    .Duration = 45
    .Location = "Vergaderzaal C"
    .Save
  End With
End Sub

 

[snb]

Schrijf dan een het volledig pad uit van die aggenda bij de collega; nu hangt hij standdsr onder de agenda van de hoofaddoiunt.
Met een persoonlijke account ordt dat anders.

Dan kun je bijv. gebruiken:

CreateObject("Outlook.Application").Getnamespace(""MAPI").Folders("mijnnaam").Folders("Wagenparkbeheer").Items.add