Created
April 2, 2019 12:05
-
-
Save wangeleile/d4320bc6b40b47ccdac7017b3a9c956b to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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("\\xxx@xxx.xx\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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment