Macro voor taken subfolders

[pjk21]

Hallo,

In mijn Outlook heb ik een takenlijst voor elk bedrijf waar ik zaken mee doe.

Tasks
- Bedrijf A
- Bedrijf B

Op internet heb ik een macro gevonden die een email om kan zetten in een taak. Dit is perfect voor mij en wat ik nodig heb. De macro zet emails alleen om in taken in de Tasks.

Ik moet ook subfolders/subtaken kunnen benaderen (bijv. Tasks/Bedrijf A). Voor elke bedrijf wil ik een aparte macro aanmaken.

Kunnen jullie mij hiermee helpen? Zie onderstaande code:

--------------------------------------------------------------------------------------------------------------------------------------------------------
Sub CreateEmailTask()

Dim oExplorer As Outlook.Explorer
Dim oMessage As Outlook.MailItem
Dim oTask As Outlook.TaskItem
Dim msgCount As Integer

Set oExplorer = Outlook.ActiveExplorer.CurrentFolder.GetExplorer

msgCount = 0

For Each Item In oExplorer.Selection 'Check items in current folder
msgCount = msgCount + 1 'increase counter
If oExplorer.Selection.Item(msgCount).Class = 43 Then 'Only do for Mail Items
Set oMessage = oExplorer.Selection.Item(msgCount)
Set oTask = Outlook.CreateItem(olTaskItem)


With oTask
.Body = oMessage.Body
.Importance = oMessage.Importance

'Attachment Handler
If oMessage.Attachments.Count > 0 Then
Dim attCount As Integer
attCount = 0

'Copy Attachments to new task
For Each Attachment In oMessage.Attachments
Dim oAttachment As Outlook.Attachment
Dim attPath As String
Dim attName As String

attCount = attCount + 1

' MsgBox oMessage.Attachments.Item(attCount).type
If Not oMessage.Attachments.Item(attCount).Type = 6 Then

attPath = "C:\"
attName = oMessage.Attachments.Item(attCount).FileName

oMessage.Attachments.Item(attCount).SaveAsFile (attPath & attName)
oTask.Attachments.Add (attPath & attName)
Else
MsgBox ("This type of attachment cannot be embedded in the task." & _
vbCrLf & vbCrLf & _
"However, it is still in the attached Original Message.")
End If
Next
End If

'Flag Handler
If oMessage.FlagStatus = 2 Then 'Message is flagged
' MsgBox oMessage.FlagRequest
Select Case oMessage.FlagRequest
Case "Follow up"
.Subject = "Follow up with " & oMessage.SenderName & _
" about " & oMessage.Subject & " (e-mail)"
Case "Call"
.Subject = "Call " & oMessage.SenderName & _
" about " & oMessage.Subject & " (e-mail)"
Case Else
' MsgBox oMessage.FlagRequest
End Select
.ReminderSet = True
.ReminderTime = oMessage.FlagDueBy
.DueDate = oMessage.FlagDueBy
Else
.Subject = oMessage.Subject
End If

.Contacts = oMessage.SenderName

'Save Message Copy
oMessage.SaveAs attPath & oMessage.EntryID

'Attach Message Copy as Original Message
oTask.Attachments.Add attPath & oMessage.EntryID, olEmbeddeditem, , "Original Message"


'Display New Task
.Display
'Set the due date for today
oTask.DueDate = Date + 5
End With

End If
Next

End Sub

--------------------------------------------------------------------------------------------------------------------------------------------------------

Ik hoop dat jullie mij kunnen helpen, het zou mijn werk echt vermakkelijken. Dankjewel.