excel naar outlook agenda

cvhuis · 17 nov 2008

Hallo,

Ik ben bezig om vanuit een excel bestand een rooster om te zetten naar de agenda van outlook. dit lukt met bijgevoegde code inmiddels prima.
Nu is het alleen zo dat als iet wijzigt in het rooster er een nieuwe afspraak gemaakt wordt en de "oude' informatie blijft staan.
Dus hoe krijg ik het in VB geregeld om de oude afspraak te vervangen door de nieuwe.
Of eventueel de hele dag wissen en het rooster opnieuw toevoegen o.i.d.
Ik wil nog wel even melden dat ik sinds afgelopn donderdag in VB bezig ben en dat wat er nu aan code staat via diverse sites tot stand is gekomen.
Dus waarschijnlijk zal e.e.a. niet erg handig geprogrameerd zijn.....

Opmaak Excel is

Datum Taakcode Starttijd Eindtijd Info Dienst Aanvang Einde
--------------------------------------------------------------------------------------------------------------------------

VBA code:

Sub MakeAppts()

Dim olApp As Object
Dim olAppt As Object
Dim cel As Object
Dim sFind As String
Dim appt As Outlook.AppointmentItem
Dim olFolder As Outlook.MAPIFolder
Dim ns As Outlook.Namespace
Dim ol As New Outlook.Application
Dim objCopy As Outlook.AppointmentItem
Dim appointment As Outlook.AppointmentItem
Dim duplicate As Outlook.AppointmentItem

Set ns = ol.GetNamespace("MAPI")
Set olFolder = ns.GetDefaultFolder(olFolderCalendar)
Set myFolder_privCal = ol.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Set olApp = CreateObject("Outlook.Application")
Set objItem_orig = myFolder_privCal.Items

objItem_orig.Sort ("Start")

For Each cel In Intersect(Sheets("Blad1").UsedRange, Sheets("Blad1").[a8:a80]).Cells
If cel.Offset(0, 1) <> "" Then
Set olAppt = olApp.CreateItem(1)
With olAppt
Set objCopy = objItem_orig.GetFirst
Plandatum = cel.Offset(0, 0)
Planstart = cel.Offset(0, 2)
Planeind = cel.Offset(0, 3)
.Start = Plandatum + Planstart
.End = Plandatum + Planeind
.Subject = cel.Offset(0, 1)
.Location = cel.Offset(0, 5)
.ReminderSet = False
'Controle op dubbele afspraken
sFind = "[Start] = '" & Format(.Start, "ddddd h:mm") & "' AND [Subject]='" & cel.Offset(0, 1) & "' And [End] = '" & Format(.End, "ddddd h:mm") & "'"
Set appt = olFolder.Items.Find(sFind)

If Not appt Is Nothing Then
GetAppt
appt.Delete
.Save

'GoTo dubbel

End If

'nieuwe of geupdate afspraak
.Save

End With

ElseIf (cel.Offset(0, 5) <> "Pauze") And (cel.Offset(0, 5) <> "Dag") Then
Set olAppt = olApp.CreateItem(1)
With olAppt
Plandatum = cel.Offset(0, 0)
Planstart = cel.Offset(0, 6)
Planeind = cel.Offset(0, 7)
.Start = Plandatum + Planstart
.End = Plandatum + Planeind
.Subject = cel.Offset(0, 4)
.Location = cel.Offset(0, 5)
.ReminderSet = False
'Controle op dubbele afspraken
sFind = "[Start] = '" & Format(.Start, "ddddd h:mm") & "' AND [Subject]='" & cel.Offset(0, 4) & "' And [End] = '" & Format(.End, "ddddd h:mm") & "'"
Set appt = olFolder.Items.Find(sFind)
If Not appt Is Nothing Then
GetAppt
appt.Delete
.Save

'GoTo dubbel
End If

'nieuwe of geupdate afspraakSave
.Save
End With
End If

dubbel:
Next

' Clean up...

MsgBox "Rooster is verwerkt in je Outlook agenda...", vbMsgBoxSetForeground
Set olNs = Nothing
Set olAppt = Nothing
Set olItem = Nothing
Set olApp = Nothing

End Sub

Guus2005 · 24 nov 2008

misschien moet je eens kijken op de site van HelenFeddema
Zij heeft tal van voorbeelden over office interactie.

HTH

murdoch · 24 feb 2009

Ik zag de code staan omtrent het bewerken van de afspraken vanuit excel naar outlook agenda.

Ik gebruik versie 2003, maar ik krijg gelijk een foutmelding. Aangezien ik ook op zoek ben naar een soortgelijke interactie hoop ik dat je me mogelijk een voorbeeldje kan toesturen.

Alvast bedankt

Rene

snb · 24 feb 2009

Code:

Sub afspraken()
  For Each cl In Blad1.[a8:a80]
   If cl.Offset(0, 1) <> "" Then
     with creat[B][COLOR="DarkRed"]e[/COLOR][/B]object("outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).CreateItem(1)
       .Start = cl.value +cl.offset(,2)
       .End = cl.value + cl.offset(,3)
       .Subject = cl.Offset(, 1)
       .Location = cl.Offset(, 5)
       .ReminderSet = False

       Set appt = .parent.Items.Find("[Start] = '" & Format(.Start, "ddddd h:mm") & "' AND [Subject]='" & cl.Offset(0, 1) & "' And [End] = '" & Format(.End, "ddddd h:mm") & "'")
       If Not appt Is Nothing Then appt.Delete
       .Save
      End With
    End If
  Next
End Sub

murdoch · 24 feb 2009

thx voor de snelle reactie

murdoch · 24 feb 2009

Toch weer een foutmelding....

Ik krijg de foutmelding:

Systeemfout &H80070057 (-2147024809). De parameter is onjuist

Ik gebruik XP Prof en Office 2003 incl alle updates

snb · 24 feb 2009

Je moet natuurlijk wel zorgen dat in je excelsheet op de aangegeven plaatsen tijdstippen en andere gegevens staan.

murdoch · 25 feb 2009

snb zei:
Je moet natuurlijk wel zorgen dat in je excelsheet op de aangegeven plaatsen tijdstippen en andere gegevens staan.

Uiteraard had ik daar naar gekeken... toch krijg ik de foutmelding

Maar als ik het eerste bericht zie, en jouw antwoord, zie ik verschil tussen de opbouw van de sheet. Vandaar dat ik ook vraag om een werkend voorbeeld.. dan kan ik zien waar ik het fout heb gedaan....

snb · 25 feb 2009

Er stond een typefout in mijn suggestie. Is nu gewijzigd.

murdoch · 25 feb 2009

die had ik al ondervangen.. helaas nog steeds een foutmelding zoals eerder opgegeven..

murdoch · 27 feb 2009

helaas krijg ik hem nog steeds niet aan de gang.. Mogelijk iemand nog een oplossing

cvhuis · 5 mrt 2009

Werkend script

Deze werkt goed bij mij, alleen is de eerst gestelde vraag nog steds actueel

Code:

'*Macro voor invoeren rooster in Outlook Agenda                             *

'*                                                                          *

'* Excel opmaak moet er zo uitzien:                                        *

'* Datum | Taakcode | Starttijd | Eindtijd | Info | Dienst | Aanvang | Einde*

'*                                                                          *

'****************************************************************************
Dim exlApp As Excel.Application
Dim SWCSheet As Worksheet
Dim iRow As Integer
Dim subject As Integer
Dim subject_row As Integer

Dim time_start_place As Integer
Dim time_end_place As Integer

Dim mystr As Integer

Dim MyFldr As Outlook.MAPIFolder
Dim MyCDO As MAPI.Session
Dim CedarPublicFldr As Outlook.MAPIFolder
Dim PWSCalendar As Outlook.MAPIFolder
Dim SMCalendar As Outlook.MAPIFolder
Dim SMAppt As Outlook.AppointmentItem
Dim SubjectCheck As String
Dim ol As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim appt As Outlook.AppointmentItem
Dim oDialog As Object
Dim r As Integer
Dim X As Integer
 
Dim olApp As Object
Dim olAppt As Object
Dim cel As Object
Dim sFind As String

Dim objCopy As Outlook.AppointmentItem
Dim appointment As Outlook.AppointmentItem
Dim duplicate As Outlook.AppointmentItem

Public Tdystart As Date
Public Tdyend As Date
Public Date_1 As Date
Public Date_2 As Date
Public MyAppt As Outlook.AppointmentItem

Sub Import_Scheduled_Work()
 

    Set ns = ol.GetNamespace("MAPI")
    Set SMCalendar = ns.GetDefaultFolder(olFolderCalendar)
    Set MyFldr = ol.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    Set olApp = CreateObject("Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    Set olFolder = ns.GetDefaultFolder(olFolderCalendar)
    Set exlApp = New Excel.Application
    time_start_place = 0
    time_end_place = 0
    iRow = 8

    Set oDialog = CreateObject("MSComDlg.CommonDialog")
    oDialog.DialogTitle = "Kies opgeslagen rooster"
    oDialog.Filter = "Microsoft Excel Files (*.xls*)|*.xls*"
    oDialog.InitDir = "Mijn Documenten"
    oDialog.ShowOpen
    sFileName = oDialog.FileName
    SWCFilePath = oDialog.FileName


    If SWCFilePath = "" Then
        MsgBox ("Het roosterbestand kon niet gevonden worden")
        exlApp.Quit
        Set exlApp = Nothing
        Exit Sub

        FilePathCheck = True
    End If

    Set SWCSheet = exlApp.Workbooks.Open(SWCFilePath).Worksheets(1)
    While SWCSheet.Cells(iRow, 1) <> ""
    Date_2 = SWCSheet.Cells(iRow, 1)
    iRow = iRow + 1
    Wend
    Date_1 = SWCSheet.Cells(8, 1)

    intbevestiging = MsgBox("Bent u zeker dat u dit rooster wilt invoegen: " _
    & Chr(13) & "van " & Date_1 & " t/m " & Date_2 & " ?", vbInformation + vbOKCancel, "Bevestiging")


    iRow = 8 'wel even terugstellen
    While SWCSheet.Cells(iRow, 1) <> ""
    Call ApptCheck
    iRow = iRow + 1
    Wend

 

    Excel.Application.Workbooks.Close
    exlApp.Quit
    Set SWCFilePath = Nothing
    Set exlApp = Nothing

    MsgBox ("Het rooster is ingevoerd in je Outlook agenda")

    End Sub

 

Private Sub ApptCheck()

 

    If SWCSheet.Cells(iRow, 2) <> "" Then

    time_start_place = 3

    time_end_place = 4

    subject_row = 2

    SubjectCheck = SWCSheet.Cells(iRow, subject_row)

    Call CheckAppt

 

    Else

 

    If SWCSheet.Cells(iRow, 6) = "BD" Then

    time_start_place = 7

    time_end_place = 8

    subject_row = 6

    SubjectCheck = SWCSheet.Cells(iRow, subject_row)

    Call CheckAppt

 

    Else

 

    If SWCSheet.Cells(iRow, 5) = "INC" And SWCSheet.Cells(iRow, 6) = "Pauze" Then

    Exit Sub

    

    Else

 

    If SWCSheet.Cells(iRow, 5) = "INC" Then

    time_start_place = 7

    time_end_place = 8

    subject_row = 5

    SubjectCheck = SWCSheet.Cells(iRow, subject_row)

    Call CheckAppt

    

    Else

    Exit Sub

 

    End If

    End If

    End If

    End If

 

End Sub

 

 

 

Private Sub CheckAppt()

 

 

    Set MyAppt = SMCalendar.Items.Find("[Subject] = " & Chr(34) & SubjectCheck & Chr(34))

    Dim myAppointments As Outlook.Items

    Dim currentAppointment As Outlook.AppointmentItem

    Set myOlApp = CreateObject("Outlook.Application")

    Set myNameSpace = myOlApp.GetNamespace("MAPI")

    Dim datedAppointment As Outlook.AppointmentItem

    

    Tdystart = FormatDateTime(SWCSheet.Cells(iRow, 1)) & Chr(32) & FormatDateTime(SWCSheet.Cells(iRow, time_start_place).Value, vbShortTime)

   

         'om "gekke" (in dit geval ">")karakters te strippen uit de string moet we even de string aanpassen

    strholdstring = ""

    Tdy = SWCSheet.Cells(iRow, time_end_place)

    charcheck = Right(Tdy, 1)

        If charcheck = ">" Then 'we moeten strippen

        mystr = SWCSheet.Cells(iRow, time_end_place)

        For i = 1 To Len(mystr)

        strChar = Mid$(mystr, i, 1)

        If Not InStr(1, ">", strChar) Then

        strholdstring = strholdstring & strChar

            If i = 5 Then

            Tdyend = FormatDateTime(SWCSheet.Cells(iRow, 1)) & Chr(32) & strholdstring

            GoTo verder

            End If

        End If

        Next i

        

        Else

        

        Tdyend = FormatDateTime(SWCSheet.Cells(iRow, 1)) & Chr(32) & FormatDateTime(SWCSheet.Cells(iRow, time_end_place).Value, vbShortTime)

        End If

verder:

  

        If Tdyend <= Tdystart Then

        Tdyend = FormatDateTime(SWCSheet.Cells(iRow, 1) + 1) & Chr(32) & strholdstring


        End If

 

    Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items

    myAppointments.Sort "[Start]"

    myAppointments.IncludeRecurrences = True

 

 

    Set currentAppointment = myAppointments.Find("[Subject] = " & Chr(34) & SubjectCheck & Chr(34))

LUS:

 

        While TypeName(currentAppointment) <> "Nothing"

            If SubjectCheck = currentAppointment.subject Then

            Debug.Print currentAppointment.subject & " - " & Format(currentAppointment.Start, "yyyy mm dd hh:mm") & " - " & Format(currentAppointment.End, "yyyy mm dd hh:mm")

                If Not Tdystart = Format(currentAppointment.Start, "yyyy mm dd hh:mm") Then

                Set currentAppointment = myAppointments.FindNext

                

                GoTo LUS

 

                Else

                MyAppt = currentAppointment.subject

 

                    If Not Tdyend = Format(currentAppointment.End, "yyyy mm dd hh:mm") Then

                    Call ReschInfo

                    Call RescheduledAppt(MyAppt, 1)

                    Call NewAppt

                    GoTo endsub

                    Else

                    GoTo endsub

                    End If

 

                End If

 

            End If

            Call ReschInfo

            Call RescheduledAppt(MyAppt, 1)

            Call NewAppt

            Debug.Print currentAppointment.subject & " - " & Format(currentAppointment.Start, "yyyy mm dd hh:mm" & Chr(32) & "fou")

 

        Wend

        'geen match gevonden in de huidige week/agenda dus maken we een nieuwe afspraak

        Call NewAppt

 

 

        

 

endsub:

        

        

        End Sub

 

 

 

Private Sub NewAppt()

 

    Set SMAppt = SMCalendar.Items.Add

    If Not SMAppt Is Nothing Then

    With SMAppt

    .subject = SWCSheet.Cells(iRow, subject_row)

    .Start = Tdystart

    .End = Tdyend

    .BusyStatus = olFree

    .Body = "Automatisch geplaatst door Macro"

    .AllDayEvent = False

    .ReminderSet = False

    .Save

 

    End With

 

    End If

 

    Set SMAppt = Nothing

    End Sub

 

 

Private Sub RescheduledAppt(objAppt As Outlook.AppointmentItem, intColor As Integer)

' requires reference to CDO 1.21 Library

' intColor corresponds to the ordinal value of the color label

'1=Important, 2=Business, etc.

 

    Const CdoPropSetID1 = "0220060000000000C000000000000046"

    Const CdoAppt_Colors = "0x8214"

    Dim objCDO As MAPI.Session

    Dim objMsg As MAPI.Message

    Dim colFields As MAPI.Fields

    Dim objField As MAPI.Field

    Dim strMsg As String

    Dim intAns As Integer

    On Error Resume Next

 

    Set objCDO = CreateObject("MAPI.Session")

    objCDO.Logon "", "", False, False

        If Not objAppt.EntryID = "" Then

        Set objMsg = objCDO.GetMessage(objAppt.EntryID, objAppt.Parent.StoreID)

        Set colFields = objMsg.Fields

        Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)

        

        If objField Is Nothing Then

        Err.Clear

        Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor, CdoPropSetID1)

        

        Else

        objField.Value = intColor

        

        End If

        

        objMsg.Update True, True

        Else

        strMsg = "You must save the appointment before you add a color label. " & "Do you want to save the appointment now?"

        intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Set Appointment Color Label")

 

        If intAns = vbYes Then

        Call RescheduledAppt(objAppt, intColor)

        End If

        

        End If

 

    Set objMsg = Nothing

    Set colFields = Nothing

    Set objField = Nothing

    objCDO.Logoff

    Set objCDO = Nothing

 

    End Sub

 

 

Private Sub ReschInfo()

'Put rescheduling information into old appt body

 

    Dim ApptString1 As String

    Dim ApptString2 As String

    

    ApptString1 = "Deze afspraak is veranderd "

    ApptString2 = " door dat "

 

    If FormatDateTime(SWCSheet.Cells(iRow, time_start_place), vbShortDate) = FormatDateTime(SWCSheet.Cells(iRow, time_start_place), vbShortDate) Then

    MyAppt.Body = ApptString1 & Chr(34) & FormatDateTime(SWCSheet.Cells(iRow, time_start_place), vbGeneralDate) & Chr(34)

    MyAppt.Save

    Else

    MyAppt.Body = ApptString1 & Chr(34) & FormatDateTime(SWCSheet.Cells(iRow, time_end_place), vbShortDate) & Chr(34) & ApptString2 & Chr(34) & FormatDateTime(SWCSheet.Cells(iRow, time_end_place), vbShortDate) & Chr(34)

    MyAppt.Save

    End If

 

    ApptString1 = "" 'Nothing

    ApptString2 = "" 'Nothing

 

End Sub

Wel moet je het wel aanpassen naar je eigen situatie.

murdoch · 6 mrt 2009

re: werkend script

Hartelijk dank voor het plaatsen van het script, alleen wat ik ook doe.. Ik krijg weer een foutmelding.

Ik krijg de foutmelding op de regel "Public MyAppt As Outlook.AppointmentItem"
Met als fout: "Compileerfout : Een door de gebruiker gedefinieerd gegevenstype is niet gedefinieerd."

Hopelijk heb je een oplossing

Guus2005 · 6 mrt 2009

je moet de outlook reference toevoegen.
VBA IDE menu Tools | References

HTH

murdoch · 6 mrt 2009

hoe doe ik dat precies

cvhuis · 6 mrt 2009

Foutmelding?

Onderstaande objecten heb ik toegevoegd in VBA. (zie bijlage)

murdoch · 6 mrt 2009

cvhuis zei:
Onderstaande objecten heb ik toegevoegd in VBA. (zie bijlage)

Ok, maar nu weet ik niet waar ik het moet toevoegen, kan je me uitleggen hoe ik dat moet doen..... zal wel stom zijn, maar ik kom er echt even niet uit

cvhuis · 6 mrt 2009

in de VBA editor

in de VBA editor via extra/verwijzingen

murdoch · 6 mrt 2009

cvhuis zei:
in de VBA editor via extra/verwijzingen

ok..... nu snap ik het... daar had ik even niet gekeken...

Tja soms kan het ook zo makkelijk zijn. Stom van me.

Thx voor de snelle reactie en service!:thumb:

murdoch · 6 mrt 2009

pfff het zit me echt niet mee...
Nu heb ik gelukkig het eea toegevoegd.. (zie bijlage) Maar nu komt hij bij de regel " Set oDialog = CreateObject("MSComDlg.CommonDialog")" met een foutmelding dat activex geen object kan maken.....

excel naar outlook agenda

Gebruiker

Terugkerende gebruiker

Gebruiker

Verenigingslid

Gebruiker

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Gebruiker

Bijlagen

Gebruiker

Gebruiker

Bijlagen

Gebruiker

Gebruiker

Bijlagen

Wij waarderen jouw privacy