[tabi]

Hab jetzt einen Code gefunden. Der würde auch funktionieren, aber verschickt keinen Anhang mit!!!

Private WithEvents Items As Outlook.Items
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
End Sub
Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder
  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderCalendar)
  ' Set Folder = Folder.Folders("Subfolder")
  Set Items = Folder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
  Dim Appt As Outlook.AppointmentItem
  If TypeOf Item Is Outlook.AppointmentItem Then
    Set Appt = Item
    Appt.Recipients.Add "xxxxx@xxxx.com"
    Appt.MeetingStatus = olMeeting
    Appt.Save
    Appt.Send
  End If
End Sub