Ik heb het boek 'Elke dag je hoofd en inbox leeg' van Taco Oosterkamp gelezen. (zie www.elkedagleeg.nl). De titel spreekt voor zich en kan ik je van harte aanbevelen als je jouw mail efficienter wilt afhandelen.
In het boek wordt uitgelegd om 2 knoppen met sneltoetsen voor kopieren en verplaatsen te gebruiken. Dat is mooi, maar ik wil meer (automatisch laten doen). Uitgelegd wordt dat je mail die je niet direct kunt beantwoorden in een taak of agenda item moet overzetten. Daarnaast wordt het oorspronkelijke bericht in een standaard map 'Kort Archief' geplaatst.
Wat ik wil is het volgende:
3 knoppen op een werkbalk
- Knop 1: Verplaats mailitem naar de map [Kort Archief]
- Knop 2: Verplaats mailitem naar taakitem en verplaats daarna het mailitem naar de map [Kort Archief]. De taakmap heet 'Eerstvolgende actie'
- Knop 3: Verplaats mailitem naar agendaitem en verplaats daarna het mailitem naar de map [Kort Archief]
Op internet kom ik diverse kode tegen die allemaal heel veel op elkaar lijkt. Hieronder de meest uitgebreide versie.
In onderstaande kode wordt bij mij niet het mailitem verwijderd als ik wel op OK klik. Dit hoeft er voor mij niet in. De functionaliteit om het bericht om te zetten naar een bijlage moet wel intact blijven, want anders worden bijlagen bij een mail niet bewaard.
Wie kan voor mij de code aanleveren behorend bij de 3 knoppen? Daarbij maakt het mij niet uit of je dit baseert op onderstaande code of met eigen code komt. Bedoeling is hopelijk duidelijk anders hoor ik dat graag.
Hoor graag reactie.
gr Joost
Ps Ik werk nog met Office 2003, maar ga binnenkort over op 2007 of 2010.
Ik heb hieronder de kode staan met daarbij nog een opmerking van de maken. weet nu of het nodig is.
Hello,
I am suprised what a good VBA code can do.
De code I have gathered is almost complete.
I only struggel with the destinationfolder where I want to saves the task.
Outlook chooses my standard destination folder.
I work with exchange 2008 and outlook 2003.
Can someone help me to change this into outlook:\\Postvak - Kantoor\Taken
The solution refered as the MAPIFolder, I can't get working.
Your help is very appriciated.
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace("\\Postvak - Kantoor\Taken", "/", "\")
arrFolders() = Split("\\Postvak - Kantoor\Taken", "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Sub Testsamen()
'Sub OpslaanInMijnDocumenten()
Dim Item As Object
Dim Map As String
Dim BestandsNaam As String
Dim Mail As Outlook.MailItem
Dim MyDocumentsDirectory
Dim wshShell
Set wshShell = CreateObject("WScript.Shell")
MyDocumentsDirectory = wshShell.SpecialFolders("MyDocuments")
Set Item = Application.Explorers(1).Selection(1)
If TypeName(Item) <> "MailItem" Then
MsgBox "Selecteer eerst een mailbericht...", vbInformation, "Opdracht niet mogelijk"
Exit Sub
End If
Map = InputBox("Map en bestandsnaam:", "Bericht opslaan in...", MyDocumentsDirectory)
If CreateObject("Scripting.FileSystemObject").FolderExists(Map) Then
If Right(Map, 1) <> "\" Then
Map = Map + "\"
End If
Set Mail = Item
BestandsNaam = Replace(Mail.Subject, ":", "")
BestandsNaam = Replace(BestandsNaam, "/", "")
BestandsNaam = Replace(BestandsNaam, "\", "")
BestandsNaam = Replace(BestandsNaam, "<", "")
BestandsNaam = Replace(BestandsNaam, ">", "")
BestandsNaam = Replace(BestandsNaam, ";", "")
Mail.SaveAs Map & BestandsNaam & ".msg", olMSG
End If
'Created by Jeremy Edmiston
'Point Loma Nazarene University
'Version 0.1.2
'Updated 7/24/03
'On Error Resume Next
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)
'The next line contance my dastination folder.
'Set oTask = GetFolder("Postvak - Kantoor\Taken")
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 ("De bijlage van deze e-mail kan niet gekoppeld worden met de taak." & _
vbCrLf & vbCrLf & _
"Desondanks kun je deze wel bekijken in de bijgevoegde e-mail.")
End If
Next
End If
cmTaskName = "\\Postvak - Kantoor\Taken"
'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"
'oTask.Attachments.Add attPath & oMessage.EntryID, olEmbeddeditem, , "Original Message"
'Display New Task
.Display
End With
'Delete Original Message
If MsgBox("Wilt u het originele bericht uit de inbox verwijderen?", vbJaNee) = vbYes Then
oMessage.Delete
End If
End If
Next
End Sub
In het boek wordt uitgelegd om 2 knoppen met sneltoetsen voor kopieren en verplaatsen te gebruiken. Dat is mooi, maar ik wil meer (automatisch laten doen). Uitgelegd wordt dat je mail die je niet direct kunt beantwoorden in een taak of agenda item moet overzetten. Daarnaast wordt het oorspronkelijke bericht in een standaard map 'Kort Archief' geplaatst.
Wat ik wil is het volgende:
3 knoppen op een werkbalk
- Knop 1: Verplaats mailitem naar de map [Kort Archief]
- Knop 2: Verplaats mailitem naar taakitem en verplaats daarna het mailitem naar de map [Kort Archief]. De taakmap heet 'Eerstvolgende actie'
- Knop 3: Verplaats mailitem naar agendaitem en verplaats daarna het mailitem naar de map [Kort Archief]
Op internet kom ik diverse kode tegen die allemaal heel veel op elkaar lijkt. Hieronder de meest uitgebreide versie.
In onderstaande kode wordt bij mij niet het mailitem verwijderd als ik wel op OK klik. Dit hoeft er voor mij niet in. De functionaliteit om het bericht om te zetten naar een bijlage moet wel intact blijven, want anders worden bijlagen bij een mail niet bewaard.
Wie kan voor mij de code aanleveren behorend bij de 3 knoppen? Daarbij maakt het mij niet uit of je dit baseert op onderstaande code of met eigen code komt. Bedoeling is hopelijk duidelijk anders hoor ik dat graag.
Hoor graag reactie.
gr Joost
Ps Ik werk nog met Office 2003, maar ga binnenkort over op 2007 of 2010.
Ik heb hieronder de kode staan met daarbij nog een opmerking van de maken. weet nu of het nodig is.
Hello,
I am suprised what a good VBA code can do.
De code I have gathered is almost complete.
I only struggel with the destinationfolder where I want to saves the task.
Outlook chooses my standard destination folder.
I work with exchange 2008 and outlook 2003.
Can someone help me to change this into outlook:\\Postvak - Kantoor\Taken
The solution refered as the MAPIFolder, I can't get working.
Your help is very appriciated.
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace("\\Postvak - Kantoor\Taken", "/", "\")
arrFolders() = Split("\\Postvak - Kantoor\Taken", "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Sub Testsamen()
'Sub OpslaanInMijnDocumenten()
Dim Item As Object
Dim Map As String
Dim BestandsNaam As String
Dim Mail As Outlook.MailItem
Dim MyDocumentsDirectory
Dim wshShell
Set wshShell = CreateObject("WScript.Shell")
MyDocumentsDirectory = wshShell.SpecialFolders("MyDocuments")
Set Item = Application.Explorers(1).Selection(1)
If TypeName(Item) <> "MailItem" Then
MsgBox "Selecteer eerst een mailbericht...", vbInformation, "Opdracht niet mogelijk"
Exit Sub
End If
Map = InputBox("Map en bestandsnaam:", "Bericht opslaan in...", MyDocumentsDirectory)
If CreateObject("Scripting.FileSystemObject").FolderExists(Map) Then
If Right(Map, 1) <> "\" Then
Map = Map + "\"
End If
Set Mail = Item
BestandsNaam = Replace(Mail.Subject, ":", "")
BestandsNaam = Replace(BestandsNaam, "/", "")
BestandsNaam = Replace(BestandsNaam, "\", "")
BestandsNaam = Replace(BestandsNaam, "<", "")
BestandsNaam = Replace(BestandsNaam, ">", "")
BestandsNaam = Replace(BestandsNaam, ";", "")
Mail.SaveAs Map & BestandsNaam & ".msg", olMSG
End If
'Created by Jeremy Edmiston
'Point Loma Nazarene University
'Version 0.1.2
'Updated 7/24/03
'On Error Resume Next
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)
'The next line contance my dastination folder.
'Set oTask = GetFolder("Postvak - Kantoor\Taken")
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 ("De bijlage van deze e-mail kan niet gekoppeld worden met de taak." & _
vbCrLf & vbCrLf & _
"Desondanks kun je deze wel bekijken in de bijgevoegde e-mail.")
End If
Next
End If
cmTaskName = "\\Postvak - Kantoor\Taken"
'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"
'oTask.Attachments.Add attPath & oMessage.EntryID, olEmbeddeditem, , "Original Message"
'Display New Task
.Display
End With
'Delete Original Message
If MsgBox("Wilt u het originele bericht uit de inbox verwijderen?", vbJaNee) = vbYes Then
oMessage.Delete
End If
End If
Next
End Sub
