G
Guest
What I've done is uninstall the David Allen "Getting Things Done" Add-In,
because it doesn't play nice with the Project Web Access Add-In. So here's
the main functionality from GTD I'm trying to replace...I'd like to be able
to take a message from any folder (mostly my Inbox), and with one click on
the toolbar, mark it as read, convert it to a task, and open the resulting
task form so I can edit categories, dates and such.
Here's what I have so far (borrowed and stolen from around the 'net), and it
works like a charm. Obviously, it doesn't open the task form, because
everything I've tried opens the original email, not the task.
<snip>
Sub MoveMessages(strFolder As String)
Dim olkItem As Object, _
olkFolder As Outlook.MAPIFolder
Set olkFolder = OpenMAPIFolder(strFolder)
If TypeName(olkFolder) = "MAPIFolder" Then
For Each olkItem In Application.ActiveExplorer.Selection
olkItem.UnRead = False
olkItem.Save
olkItem.Move olkFolder
Next
End If
Set olkFolder = Nothing
Set olkItem = Nothing
End Sub
Sub CreateTask()
MoveMessages "\Personal Folders\Tasks"
End Sub
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, i
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath <> ""
i = InStr(szPath, "\")
If i Then
szDir = Left(szPath, i - 1)
szPath = Mid(szPath, i + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function
Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function
</snip>
Anyone? Bueller?
The above move multiple messages at a time; that functionality isn't
critical to me, as I tend to process everything as it arrives; but someone
else might have a need to move a large number of items all at once.
Thanks in advance for any advice.
because it doesn't play nice with the Project Web Access Add-In. So here's
the main functionality from GTD I'm trying to replace...I'd like to be able
to take a message from any folder (mostly my Inbox), and with one click on
the toolbar, mark it as read, convert it to a task, and open the resulting
task form so I can edit categories, dates and such.
Here's what I have so far (borrowed and stolen from around the 'net), and it
works like a charm. Obviously, it doesn't open the task form, because
everything I've tried opens the original email, not the task.
<snip>
Sub MoveMessages(strFolder As String)
Dim olkItem As Object, _
olkFolder As Outlook.MAPIFolder
Set olkFolder = OpenMAPIFolder(strFolder)
If TypeName(olkFolder) = "MAPIFolder" Then
For Each olkItem In Application.ActiveExplorer.Selection
olkItem.UnRead = False
olkItem.Save
olkItem.Move olkFolder
Next
End If
Set olkFolder = Nothing
Set olkItem = Nothing
End Sub
Sub CreateTask()
MoveMessages "\Personal Folders\Tasks"
End Sub
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, i
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath <> ""
i = InStr(szPath, "\")
If i Then
szDir = Left(szPath, i - 1)
szPath = Mid(szPath, i + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function
Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function
</snip>
Anyone? Bueller?
The above move multiple messages at a time; that functionality isn't
critical to me, as I tend to process everything as it arrives; but someone
else might have a need to move a large number of items all at once.
Thanks in advance for any advice.