outlook.vba

Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items

Private Sub Application_ItemSend(ByVal Item As Object, _
    Cancel As Boolean)

'Variablen für Folder
Dim objNS As NameSpace
Dim objFolder As MAPIFolder

'Variablen für Task
Dim sentMsg As Object
Dim objTask As TaskItem
Dim intRes As Integer
Dim strMsg As String
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String

 strMsg = "Soll die Mail nachverfolgt werden?"
 intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")
      
    If intRes = vbNo Then
      Cancel = False
    Else
      
  Set objNS = Application.GetNamespace("MAPI")
  Set objFolder = GetFolder("\\[email protected]\FU")
  Set Item.SaveSentMessageFolder = objFolder
  Set objFolder = Nothing
  Set objNS = Nothing
      
  
      
    For Each Recipient In Item.Recipients
        strRecip = strRecip & vbCrLf & Recipient.Address
    Next Recipient

Debug.Print Item.Subject
        
With objTask

    .Body = strRecip & vbCrLf & Item.Body
    .Subject = Item.Subject
    '.StartDate = Item.ReceivedTime
' Can use Now + nn for the start and/or due dates
    .DueDate = Now + 3
    .StartDate = Now + 2

    .ReminderSet = True
    .ReminderTime = Now + 2 + #10:00:00 AM#
' alternately, use the due date to set the reminder:
'   .ReminderTime = .DueDate - 2 + #2:00:00 PM#

    .Attachments.Add Item
    .Save
End With

End If

Set Item = Nothing
End Sub

Function GetFolder(ByVal FolderPath As String) As Outlook.folder
    Dim TestFolder As Outlook.folder
    Dim FoldersArray As Variant
    Dim i As Integer
        
    On Error GoTo GetFolder_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not TestFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = TestFolder.Folders
            Set TestFolder = SubFolders.Item(FoldersArray(i))
            If TestFolder Is Nothing Then
                Set GetFolder = Nothing
            End If
        Next
    End If
    'Return the TestFolder
    Set GetFolder = TestFolder
    Exit Function
        
GetFolder_Error:
    Set GetFolder = Nothing
    Exit Function
End Function