Outlook Termine in Access Tabelle übergeben

[silentwolf]

Hi bin wieder mal lästig 
ich würde gerne in meine Access DB alle Termine von Outlook 2010 nach Access 2010 in eine Tabelle einfügen.
Ich habe es momentan mit einer einfachen Verknüpfung erledigt nur kann ich die Termine nur bis den Heutigen Datum sehen bzw. werden nur Termine bis zum Heutigen Datum in die Tabelle eingefügt.
Da ich aber mehrere Serien Termine habe möchte ich auch diese zur weiteren Verarbeitung in Access haben also auch zukünftige Termine.
Habe auch verschiede Codes für VBA probiert aber leider konnte ich diese nicht verwenden da ich immer Fehlermeldungen bekommen habe

Vielleicht könnte mir diesbezüglich jemand helfen?

Vielen Dank

Silentwolf

[Hondo]

Hallo,
da sollte es aber genügend Lösungen im Netz geben.
Schau mal hier: http://www.access-im-unternehmen.de/index1.php?id=300&BeitragID=828
der wesentliche Codeblock wird dort veröffentlicht.
Leider doch nicht, sorry.

Gruß Andreas

[silentwolf]

Zusatz...

Hier habe ich den Code den ich Probiert habe...den ich aus einen Buch habe.

Code [Auswählen] Erweitern


Public Function ImportApptsFromOutlook()

    On Error GoTo ErrorHandler
    Dim objNameSpace As NameSpace
    Dim fldCalendar As Outlook.Folder
    Dim appt As Outlook.AppointmentItem
    Dim strApptName As String
    Dim dteStartTime As Date
    Dim dteEndTime As Date
    Dim strLocation As String
    Dim strSQL As String
    Dim strDescription As String
    Dim appOutlook As Application

    Set appOutlook = GetObject(, "Outlook.appointment")
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fldCalendar = nms.GetDefaultFolder(olFolderCalender)
clear table of old data
    strSQL = "DELETE *From tblImportedCalendar"
    DoCmd.SetWarnings False
    DoCmd.RunSQL

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblImportedCalendar")

Iterate through the apointments in the local Calendar folder and import them to the Access table
    For Each itm In fldCalendar.Items
        If itm.Class = olAppointment Then
            Set appt = itm
                With appt
                strApptName = Nz(.Subject)
                dteStartTime = Nz(.Start)
                dteEndTime = Nz(.End)
                strLocation = Nz(.Location)
                strDescription = Nz(.Body)
            End With

            With rst
                rst.AddNew
                ![Subject] = strApptName

                If dteStartTime <> #1/1/4501# Then
                    ![Start Time] = dteStartTime
                End If

                If dteEndTime <> #1/1/4105# Then
                    ![End Time] = dteEndTime
                End If
                    ![Location] = strLocation
                    ![Description] = strDescription
                    .Update
                End With
            End If
        Next itm

        rst.Close
        DoCmd.OpenTable "tblImportedCaledar"

ErrorhandlerExit:
        Exit Function

ErrorHandler:
        Outlook is not running; Outlook with Create Object

        If Err.Number = 429 Then
            Set .appOutlook = CreateObject("Outlook.application")
            resum.Next
        Else
            MsgBox "Error No: " & Err.Number _
                & "; Description: " & Err.Description
            Resume ErrorhandlerExit
        End If

End Function
[/size]

der Code hält das erste mal schon bei GetNamespace

wo liegt hier das Problem kann wüste das jemand?

Glg

SW

[silentwolf]

Hi Hondo,

danke für Deine Antwort! Ja ich habe diesen Beitrag selbst auch schon gesehen aber da ist ja Code nicht komplette oder? Bei der Function fehlt doch noch einiges..?? Oder??

Lg

[Hondo]

Hallo,
also dein Code ist total fehlerhaft. Calender statt Calendar etc.
Anbei der korrigierte Code - als early Binding also Verweiss auf Microsoft Outlook X.X Object Library setzten oder wieder umändern auf lateBinding.

Code (vb) [Auswählen] Erweitern


Public Function ImportApptsFromOutlook()
    On Error GoTo ErrorHandler
    Dim objNameSpace As NameSpace
    Dim fldCalendar As Outlook.Folder
    Dim appt As Outlook.AppointmentItem
    Dim strApptName As String
    Dim dteStartTime As Date
    Dim dteEndTime As Date
    Dim strLocation As String
    Dim strSQL As String
    Dim strDescription As String
    Dim appOutlook As Outlook.Application

    Set appOutlook = New Outlook.Application
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fldCalendar = nms.GetDefaultFolder(olFolderCalendar)

    'clear table of old data
    strSQL = "DELETE *From tblImportedCalendar"
    DoCmd.SetWarnings False
    DoCmd.RunSQL strSQL

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblImportedCalendar")

    'Iterate through the apointments in the local Calendar folder and import them to the Access table
    For Each itm In fldCalendar.Items
        If itm.Class = olAppointment Then
            Set appt = itm
            With appt
                strApptName = Nz(.Subject)
                dteStartTime = Nz(.Start)
                dteEndTime = Nz(.End)
                strLocation = Nz(.Location)
                strDescription = Nz(.Body)
            End With

            With rst
                rst.AddNew
                ![Subject] = strApptName

                If dteStartTime <> #1/1/4501# Then
                    ![Start Time] = dteStartTime
                End If

                If dteEndTime <> #1/1/4105# Then
                    ![End Time] = dteEndTime
                End If
                ![Location] = strLocation
                ![Description] = strDescription
                .Update
            End With
        End If
    Next itm

    rst.Close
    DoCmd.OpenTable "tblImportedCaledar"

ErrorhandlerExit:
    Exit Function

ErrorHandler:
    MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
    Resume ErrorhandlerExit
End Function

[silentwolf]

Danke Hondo!!
hab Ihn grad kompiliert.
Es hat leider noch einen Fehler.

Die Variable nms ist nicht definiert.
Wie muss ich diese den definieren?

dim nms as "Welcher Datentyp"?

Danke.

[Hondo]

Na ein bisschen Mitdenken hätte nicht geschadet ;-)
Dim nms As Outlook.NameSpace

[silentwolf]

Hi Hondo,

ja Dankeschön Hast eh recht nur bin ich trotz allem noch nicht so ganz sicher mit VBA und daher noch etwas ängstlich  ,

Diese habe ich noch dazu gefügt.

    Dim dbs As Database
    Dim rst As Recordset
    Dim itm As Items

sollten so stimmen oder?

Habs zumindest so gemacht

Nun habe ich die Function ausgeführt und bekomme schon wieder einen Fehler dieses mal die msgbox Describtion Type unverträglich..
Muss ich dann nochmals ansehen hoffe ich kann es lösen.
Im Formular ist es ein Textfeld

Schöne Grüße und nochmals vielen Dank!

[silentwolf]

Hallo nochmal,

hab jetzt nochmal den Code durchgeschaut weis aber nicht woran es liegt das ich diese Fehlermeldung bekomme.
Error No:13 Description: Typen unverträglich.

Muss ich hier meine Tabelle ändern??

Danke für Eure Hilfe!!

SW

[Hondo]

Hallo,
ja wird ganz sicher an deiner Tabellenstruktur liegen.
Schreibe doch mal wie die Tabelle aufgebaut ist.

[silentwolf]

Hallo,

ja dachte ich mir..

ID

[silentwolf]

das ist wohl etwas zu schnell gegangen

Also nochmal

ID .........AutoWert
Subject........Text
Start Time.......Datum/Uhrzeit
End Time.........Datum/Uhrzeit
Location...........Text
Description...........Text

Dankeschön

[DF6GL]

Hallo,

   Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim itm As Object

[silentwolf]

Hallo,
danke Franz das hat mal den Fehler behoben
Jetzt kommt aber schon wieder eine neue Error No: 2046: Description: Der Befehl oder die Aktion 'Ausführen SQL' ist zurzeit
nicht verfügbar...

Habe leider keine Ahnung warum oder was es bedeutet.

Schöne Grüße

SW

[DF6GL]

Hi,
ist die Tabelle "tblImportedCalendar"  irgendwo geöffnet?

Zudem fehlt ein Leerzeichen nach dem Sternchen...