Outlinker.bas

'Outlinker http://wiki.activityowner.com/index.php?title=OutLinker ' http://creativecommons.org/licenses/by-nc-nd/3.0/ Option Explicit Public Const version = "20110728" ' Adapted from macros by Mike Wikerson: http://nodeglue.com/blog/excited-about-mindreader/ 'Recent Changes 'add context option, fix bug 'add labels 'remove legacy input box, unzoom when zoomed on 1 message, catch memory issue, contact-about in billing field 'remove annoying prompts on task list 'fix 6 label loading in settings, 'put message categories in dialog box in brackets with * in front of each 'put [* entries in outlook categories 'add button to create an appointment with current message as an attachment 'eliminate big message warning when just archiving big messages 'add dedicated routines for archiving and deleting that increment counters as well (can assign to OutLook toolbar) 'improve error trapping 'more error trapping 'try to avoid advancing when user uses reply, i, etc. 'improve error message on mindreaderopen error 'add rss processing 'change capturedoc to mycapturedoc to avoid some type of 8.1 conflict 'add confirmation for deleting or achiving multiple messages '13Feb2010 -- add autooutlinker '14Feb2010 -- change method for deleting gmail '15Feb2010 -- Enhance outlinker form, allow for 5 different archive folders and more contexts/tags '16Feb2010 -- fix archive bug, organize form better '17Feb2010 -- Streamline form '20Feb2010 -- fix bug in setting up new install archive folder 1 '22Feb2010 -- make clean subject optional '23Feb2010 -- improve folder path display and add new map button '25Feb2010 -- increase size of next action text box '11Mar2010 -- enhance autooutlinker to provide option to bypass gyroq (send to active map wasn't) '15Mar2010 -- fix autoOutlinker bug and set folder type '21Mar2010 -- shrink form for 1024 screens and fix another autooutlinker bug '22Jun2010 -- change as topic variables to as mindmanager.topic '14Jul2010 -- fix bug causing changes in 1st archive location not to stick from session to session '04Jan2011 -- fix bug in queue characters impacting latest gyroq code '29Mar2011 -- clear clipboard to avoid problems with autoutlinker '28Jul2011 -- add macro to send notes, appts, contacts links/body to mindmanager. '23Aug2011 -- add "waiting for next week" macro ' ' This project requires two References to be added with Tools->References in Visual Basic Editor ' 1) c:\windows\system32\scrrun.dll (Microsoft Scripting Runtime) 'if you are using MindManager, #usemm must be true and you must have ' c:\program files\mindmanager 8\mindmanager.exe (MindManager Type Library) or 7 or 6 ' Full mindmanager functionality required mindreader (Setup.exe available on wiki)

'MindManager users set below = true, 'Language codes - set english=false if you customize
 * 1) Const usemm = True
 * 2) Const UseExcel = False 'if set true, you need to add excel x.0 object library reference -- this enables history graphing

Public Const english = True Public Const code15m = "15m" Public Const code1h = "1h" Public Const code2h = "2h"

Public Const CodeToday = "today" Public Const codenextweek = "next week" Public Const codenextmonth = "next month" Public Const CodeTomorrow = "tomorrow"

Public Const codesomeday = "someday" Public Const codeisproject = "isproject" Public Const codeisdone = "isdone" Public Const codeisinfo = "isinfo"

Public Const CodeIOwe = "I owe" Public Const CodeDelegatedTo = "delegated to" Public Const codewaitingfor = "R:"

Public Const codedeadline = "!" Public Const codep1 = "p1" Public Const codep2 = "p2" Public Const codep3 = "p3" '- '

Public Const assigncontexttotasks = True

Public Const nl = vbNewLine Public archivefolder1 As Outlook.MAPIFolder Public archivefolder2 As Outlook.MAPIFolder Public archivefolder3 As Outlook.MAPIFolder Public archivefolder4 As Outlook.MAPIFolder Public archivefolder5 As Outlook.MAPIFolder Public gmailtrash As Outlook.MAPIFolder Public outlooktasklist As Outlook.MAPIFolder Public Const OutLinkerRegName = "OutLinker" Public Const OutLInkerRegPref = "Preferences" Public Const maxbodylength = 24000 Public Const defaultformleft = "200" Public Const maxskips = 3

Public mtime As Double Public dtime As Double Public longmessagewarned As Boolean Public resettoday As Integer Public lastentry As Object Public nextentry As Object Public lastprompt As Double Public lastprocess As Double Public avgprocess As Double Public avgcount As Integer Public nextaction As String Public iszoomed As Boolean Public obj As Object 'make selected objec accessible to form Public totalitems As Integer Public objitems As Object Public gone As Boolean Public automaticstring As String Public settings As Outlook.MAPIFolder

Declare Function OpenClipboard _ Lib "User32.dll" _ (ByVal hWndNewOwner As Long) As Long Declare Function EmptyClipboard _ Lib "User32.dll" As Long Declare Function CloseClipboard _ Lib "User32.dll" As Long

Sub autoOutlinker outlinker_sub True, "" End Sub Sub waitingforsomebodynextweek outlinker_sub True, "R:Somebody [next week]" End Sub Sub outlinker outlinker_sub False, "" End Sub

Sub outlinker_sub(ByRef automatic As Boolean, ByVal autocmd As String) Dim exitprogram As Boolean Dim cmd As String Dim lastcmd As String Dim processit As Boolean Dim jumpahead As Boolean Dim lastentryid As String Dim objentryid As String Dim gotoprev As Boolean Dim apptobj As Object Dim fname As String Dim i As Integer Dim j As Integer mtime = Timer sw "Starting Program-" automaticstring = "" If automatic Then If autocmd = "" Then If MsgBox("Do you want to Send to Active Map?", vbYesNo, "Send to Active Map?") = vbYes Then automaticstring = automaticstring & " " & "[s2am]" ElseIf MsgBox("Do you want to bypass GyroQ Queue and process immediately?", vbYesNo, "Bypass GyroQ?") = vbYes Then automaticstring = automaticstring & " " & "[bygq]" End If           automaticstring = automaticstring & "[" & InputBox("Enter mindreader mark up to use on selected messages", "AutoOutLinker") & "]" Else automaticstring = autocmd & "[s2tl]" End If   End If    If settings Is Nothing Then setupSession If Application.ActiveExplorer.Selection.count = 0 Then MsgBox "You must selected message(s) to process with Outlinker" If archivefolder1 Is Nothing Then Set archivefolder1 = getarchivefolder1 If archivefolder2 Is Nothing Then Set archivefolder2 = getarchivefolder2 If archivefolder3 Is Nothing Then Set archivefolder3 = getarchivefolder3 If archivefolder4 Is Nothing Then Set archivefolder4 = getarchivefolder4 If archivefolder5 Is Nothing Then Set archivefolder5 = getarchivefolder5 If Not archivefolder1 Is Nothing Then totalitems = Application.ActiveExplorer.Selection.count ReDim gone(totalitems) ReDim objitems(totalitems) For i = 1 To totalitems Set objitems(i) = Application.ActiveExplorer.Selection.Item(i) gone(i) = False Next iszoomed = False jumpahead = canjumpahead(lastentry, nextentry) 'Try to jump ahead in selection to where you left off exitprogram = False lastcmd = "" While itemsleft(gone, totalitems) > 0 And exitprogram = False For i = 1 To totalitems If jumpahead Then jumpahead = canjumpahead(lastentry, nextentry) If Not gone(i) Then If objitems(i) Is Nothing Then gone(i) = True On Error Resume Next 'type 45=rss If Not (objitems(i).Class = olAppointment Or objitems(i).Class = olTask Or objitems(i).Class = olMail Or objitems(i).Class = 45) Then gone(i) = True If Not Err.Number = 0 Then gone(i) = True Err.Clear On Error GoTo 0 End If            If Not gone(i) Then Set obj = objitems(i) If lastentry Is Nothing Then Set lastentry = nextentry If lastentry Is Nothing Then Set lastentry = obj On Error Resume Next Err.Clear lastentryid = lastentry.EntryID If Not Err = 0 Then lastentryid = obj.EntryID Err.Clear End If               objentryid = obj.EntryID If Not Err = 0 Then gone(i) = True Set obj = Nothing Set lastentry = Nothing Set nextentry = Nothing Err.Clear End If              If obj Is Nothing Then gone(i) = True On Error GoTo 0 If (Not gone(i)) And ((Not jumpahead) Or (objentryid = lastentryid)) Then jumpahead = False Set lastentry = obj If obj.Class = olTask Then processit = (obj.Complete = 0) If processit Then gone(i) = True End If                  If obj.Class = 45 Or obj.Class = olMail Or obj.Class = olAppointment Or (obj.Class = olTask And processit) Then nextaction = getnextaction(obj, i, settings, automatic) 'prompt for next action If Not (nextaction = "n" Or nextaction = "p" Or nextaction = "s" Or nextaction = "q" Or nextaction = "") Then lastprocess = DateDiff("s", lastprompt, Now) avgcount = avgcount + 1 If avgcount > 1 Then avgprocess = (lastprocess / avgcount) + (avgprocess * (avgcount - 1) / avgcount) Else avgprocess = lastprocess End If                           lastprompt = Now End If                      setnextentry i, nextentry gotoprev = False cmd = Trim(LCase(nextaction)) If "1" = cmd Then Set lastentry = Nothing Set nextentry = Nothing Exit For ElseIf "d" = cmd Then gone(i) = True If lastcmd = "pt" Or lastcmd = "nt" Then nextmsginthread totalitems, i, obj, lastentry, jumpahead Else Set lastentry = nextentry End If                         If Not InStr(obj.Parent.FolderPath, "@gmail.com") > 0 And InStr(obj.Parent.FolderPath, "\\") > 0 Then Debug.Print "not gmail" On Error Resume Next obj.Close olDiscard obj.Delete gone(i) = True On Error GoTo 0 Else Set gmailtrash = getgmailtrashfolderfromobj(obj) If Not gmailtrash Is Nothing Then On Error Resume Next objitems(i).Move gmailtrash obj.Close olDiscard gone(i) = True On Error GoTo 0 Else On Error Resume Next obj.Delete gone(i) = True On Error GoTo 0 MsgBox "gmail trash folder not found: deleting manually" End If                           End If                            IncrementProcessCounters "deletecount" ElseIf "c" = cmd Then Set obj = CreateItem(olMailItem) obj.Display incrementsetting "composecount" exitprogram = True ElseIf "s" = cmd Then obj.Close olDiscard gone(i) = True incrementskipcount obj ElseIf "n" = cmd Then incrementskipcount obj obj.Close olDiscard ElseIf "p" = cmd Then obj.Close olDiscard prevmsg totalitems, i, obj, lastentry, jumpahead, gotoprev ElseIf "pt" = cmd Then obj.Close olDiscard prevmsginthread totalitems, i, obj, lastentry, jumpahead, gotoprev ElseIf "nt" = cmd Then nextmsginthread totalitems, i, obj, lastentry, jumpahead ElseIf "i" = cmd Then Set lastentry = obj exitprogram = True ElseIf "q" = cmd Then Set lastentry = obj exitprogram = True avgcount = 0 avgprocess = 0 ElseIf "" = Trim(nextaction) Then Set lastentry = obj exitprogram = True avgcount = 0 avgprocess = 0 ElseIf "h" = LCase(nextaction) Then showoutlinkerhelp exitprogram = True ElseIf "olreset" = LCase(nextaction) Or "reset" = LCase(nextaction) Then Set settings = Nothing exitprogram = True ElseIf "r" = LCase(nextaction) Then Set lastentry = obj If obj.Class = olMail Then obj.Reply.Display exitprogram = True IncrementProcessCounters "replycount" End If                       ElseIf "ca" = LCase(nextaction) Then If obj.Class = olMail Then fname = SaveAsMsg(obj) Set apptobj = Outlook.Application.CreateItem(olAppointmentItem) apptobj.Subject = obj.Subject apptobj.Attachments.Add fname apptobj.Display exitprogram = True End If                      ElseIf "rd" = LCase(nextaction) Then If obj.Class = olMail Then obj.Reply.Display setnextentry i, nextentry exitprogram = True IncrementProcessCounters "replycount" obj.Delete gone(i) = True End If                      ElseIf "rs" = LCase(nextaction) Then If obj.Class = olMail Then obj.Reply.Display setnextentry i, nextentry exitprogram = True MoveToSaved obj IncrementProcessCounters "replycount" End If                      ElseIf "ras" = LCase(nextaction) Then If obj.Class = olMail Then obj.ReplyAll.Display Set lastentry = nextentry exitprogram = True MoveToSaved obj IncrementProcessCounters "replycount" End If                      ElseIf "ra" = LCase(nextaction) Then If obj.Class = olMail Then obj.ReplyAll.Display exitprogram = True IncrementProcessCounters "replycount" End If                      ElseIf "rad" = LCase(nextaction) Then If obj.Class = olMail Then obj.ReplyAll.Display setnextentry i, nextentry exitprogram = True IncrementProcessCounters "replycount" obj.Delete gone(i) = True End If                      ElseIf "f" = LCase(nextaction) Then Set lastentry = obj If obj.Class = olMail Then obj.Forward.Display exitprogram = True IncrementProcessCounters "forwardcount" End If                      ElseIf "fd" = LCase(nextaction) Then If obj.Class = olMail Then obj.Forward.Display On Error Resume Next obj.Delete gone(i) = True setnextentry i, nextentry On Error GoTo 0 IncrementProcessCounters "forwardcount" exitprogram = True End If                      ElseIf "fs" = LCase(nextaction) Then If obj.Class = olMail Then obj.Forward.Display exitprogram = True Set lastentry = nextentry MoveToSaved obj IncrementProcessCounters "archivecount" End If                      ElseIf "o" = LCase(nextaction) Then 'experiment with saving to disk to open attachment Set lastentry = obj OpenAttachment obj, 1 exitprogram = True ElseIf "o2" = LCase(nextaction) Then Set lastentry = obj OpenAttachment obj, 2 exitprogram = True ElseIf "o3" = LCase(nextaction) Then Set lastentry = obj OpenAttachment obj, 3 exitprogram = True ElseIf "a" = LCase(nextaction) Then obj.Close olDiscard If obj.Class = olMail Then MoveToSaved obj IncrementProcessCounters "archivecount" gone(i) = True Else MsgBox "Only works on messages right now" End If                      Else ProcessNextAction nextaction, obj 'user entered a next action instead of command gone(i) = True End If                  End If                   If exitprogram Then If Not LCase(nextaction) = "rd" And Not LCase(nextaction) = "rad" And Not LCase(nextaction) = "fd" Then Set lastentry = obj setnextentry i, nextentry Exit For End If              End If 'jump ahead End If           Next If itemsleft(gone, totalitems) > 0 And Not exitprogram And Not gotoprev And Not cmd = "1" Then Set lastentry = Nothing Set nextentry = Nothing If MsgBox("You are at bottom of message list. Start over at top?", vbYesNo) = vbNo Then cmd = "q" exitprogram = True Else exitprogram = False End If           End If            If itemsleft(gone, totalitems) < 2 And iszoomed Then unthreadzoom iszoomed lastcmd = cmd Wend If (cmd = "q" Or Not exitprogram) And istrue("showstats") And totalitems > 1 Then displaystats settings End If 'end of is archivefolder not nothing 'clean up   Set obj = Nothing End Sub Function getnextaction(ByRef objitem As Object, i As Integer, settings As Outlook.MAPIFolder, automatic As Boolean) Dim defaultna As String Dim tempobj As Object Dim taskobj As Object If istrue("trimsubject") Then defaultna = cleansubject(objitem.Subject) Else defaultna = objitem.Subject End If   If Not objitem.Categories = "" Then defaultna = defaultna & getoutlookcategories(objitem) End If   obj.Display If isOutLinkerTask(obj) Then 'always process as msg if is a message Set tempobj = GetMsgFromTask(obj) If Not tempobj Is Nothing Then Set taskobj = obj Set obj = tempobj taskobj.Close olDiscard Set tempobj = Nothing Else MsgBox "Error opening message." End If   End If    obj.Display If objitem.Class = olAppointment Then defaultna = "Prepare for " & defaultna End If   nextaction = defaultna Debug.Print "going into form" If Not automatic Then With OutLinkerForm .nextactionTextBox.Text = defaultna .Left = Val(gset("formleft")) .Top = Val(gset("formtop")) .MindReadButton.Visible = istrue("usemindreader") If Not istrue("usegyroq") Then .QueueButton.Caption = "Send" End If           .openAttachmentButton.Visible = (objitem.Attachments.count > 0) If Not objitem.Class = 45 Then .replyallButton.Visible = (objitem.Recipients.count > 1) .replyalldeleteButton.Visible = (objitem.Recipients.count > 1) .ReplyAllSaveButton.Visible = (objitem.Recipients.count > 1) End If           If Not archivefolder1 Is Nothing Then .ArchiveFolderButton1.Caption = archivefolder1.Name & " in " & archivefolder1.Parent If Not archivefolder2 Is Nothing Then .ArchiveFolderButton2.Caption = archivefolder2.Name & " in " & archivefolder2.Parent If Not archivefolder3 Is Nothing Then .ArchiveFolderButton3.Caption = archivefolder3.Name & " in " & archivefolder3.Parent If Not archivefolder4 Is Nothing Then .ArchiveFolderButton4.Caption = archivefolder4.Name & " in " & archivefolder4.Parent If Not archivefolder5 Is Nothing Then .ArchiveFolderButton5.Caption = archivefolder5.Name & " in " & archivefolder5.Parent .actionButton.value = True .attachCheckBox.value = istrue("attachmsg") .putmsginnoteCheckBox.value = istrue("PutMsgInNote") .context1Button.Caption = gset("context1") .context2button.Caption = gset("context2") .context3Button.Caption = gset("context3") .context4Button.Caption = gset("context4") .context5Button.Caption = gset("context5") .Context6Button.Caption = gset("context6") .Context7Button.Caption = gset("context7") .Context8Button.Caption = gset("context8") .Context9Button.Caption = gset("context9") .UseArchive1Button.value = istrue("usearchive1") .UseArchive2Button.value = istrue("usearchive2") .UseArchive3Button.value = istrue("usearchive3") .UseArchive4Button.value = istrue("usearchive4") .UseArchive5Button.value = istrue("usearchive5") If Not (istrue("usearchive1") Or istrue("usearchive2") Or istrue("usearchive3") Or istrue("usearchive4") Or istrue("usearchive5")) Then setboolean "usearchive1", True .UseArchive1Button.value = istrue("usearchive1") End If           .tag1CheckBox.Caption = gset("tag1") .tag2CheckBox.Caption = gset("tag2") .tag3CheckBox.Caption = gset("tag3") .tag4CheckBox.Caption = gset("tag4") .tag5CheckBox.Caption = gset("tag5") .tag6CheckBox.Caption = gset("tag6") .Tag7CheckBox.Caption = gset("tag7") .tag8CheckBox.Caption = gset("tag8") .Tag9CheckBox.Caption = gset("tag9") .Tag10CheckBox.Caption = gset("tag10") .Tag11CheckBox.Caption = gset("tag11") .Tag12CheckBox.Caption = gset("tag12") .tag13CheckBox.Caption = gset("tag13") .tag14CheckBox.Caption = gset("tag14") .Tag15CheckBox.Caption = gset("tag15") .Tag16CheckBox.Caption = gset("tag16") .Tag17CheckBox.Caption = gset("tag17") .Tag18CheckBox.Caption = gset("tag18") .tag19CheckBox.Caption = gset("tag19") .Tag20CheckBox.Caption = gset("tag20") If iszoomed Then .threadzoomButton.Visible = True .threadzoomButton.Caption = "UnZoom" End If           If isbulk(obj) Then .messageLabel = "Consider unsubscribing" .messageLabel.ForeColor = vbRed End If           If skipcount(obj) > maxskips Then .messageLabel = "Handle it once!" .messageLabel.ForeColor = vbRed End If           If conversationcount(obj) > 1 Then .nextthreadButton.Visible = laterconversationmsg(objitem, i)                   .prevthreadButton.Visible = earlierconversationmsg(objitem, i)                    .messageLabel = conversationcount(objitem) & " msgs in thread" .threadzoomButton.Visible = True If iszoomed Then .threadzoomButton.Caption = "UnZoom" Else .threadzoomButton.Caption = "Zoom" End If           End If            If Not english Then 'Language constants .todayButton.Caption = CodeToday .nextweekButton.Caption = codenextweek .nextmonthButton.Caption = codenextmonth .tomorrowButton.Caption = CodeTomorrow .somedayCheckBox.Caption = codesomeday .a15mButton.Caption = code15m .a1hButton.Caption = code1h .a2hButton.Caption = code2h .olioButton.Caption = CodeIOwe .delegateButton.Caption = CodeDelegatedTo .olwfButton.Caption = codewaitingfor End If           #If Not usemm Then .MindReadButton.Visible = False .NewMapButton.Visible = False .sendButton.Visible = False .QueueButton.Visible = False .Caption = "OutLinker Lite" #End If           .Show End With Else 'if automatic Debug.Print "is automatic" nextaction = obj.Subject & automaticstring End If   getnextaction = nextaction If Not taskobj Is Nothing Then If Not ((getnextaction = "n") Or (getnextaction = "p") Or (getnextaction = "") Or (getnextaction = "s") Or (getnextaction = "1") Or (getnextaction = "h")) Then taskobj.Display If istrue("deleteprocessedtasks") Then taskobj.Close olDiscard taskobj.Delete Else taskobj.MarkComplete taskobj.Close olDiscard End If      End If    End If End Function Sub ProcessNextAction(ByRef nextaction As String, obj As Object) #If usemm Then Dim mm As MindManager.Application Dim mycapturedoc As MindManager.Document Dim newmap As MindManager.Document Dim intray As MindManager.Topic Dim newtask As MindManager.Topic #End If   Dim mindreaderstring As String Dim hlink As String Dim fname As String Dim newtaskitem As Object

Dim person As String Dim tdate As String Dim mrcode As String Dim resource As String Dim sendtoactivemap As Boolean Dim bypassgyroq As Boolean Dim sendtotasklist As Boolean Dim newprojmap As Boolean Dim attach As Boolean 'Look for Keywords- newprojmap = InStr(nextaction, "npm") > 0 Debug.Print nextaction sendtoactivemap = InStr(nextaction, "s2am") > 0 If sendtoactivemap Then Debug.Print "send to active map" 'nextaction = Replace(nextaction, "s2am ", "") 'nextaction = Replace(nextaction, " s2am", "") 'nextaction = Replace(nextaction, "s2am", "") End If    bypassgyroq = InStr(nextaction, "bpgq") > 0 If bypassgyroq Then 'nextaction = Replace(nextaction, "bpgq ", "") 'nextaction = Replace(nextaction, " bpgq", "") 'nextaction = Replace(nextaction, "bpgq", "") End If    #If usemm = False Then sendtotasklist = True #Else sendtotasklist = InStr(nextaction, "s2tl") > 0 #End If           If sendtotasklist Then nextaction = Replace(nextaction, "s2tl ", "") nextaction = Replace(nextaction, " s2tl", "") nextaction = Replace(nextaction, "s2tl", "") End If   attach = istrue("attachmsg") If InStr(nextaction, "olam") > 0 Then attach = True nextaction = Replace(nextaction, "olam ", "") nextaction = Replace(nextaction, " olam", "") nextaction = Replace(nextaction, "[olam]", "") End If   If attach Then fname = SaveAsMsg(obj) nextaction = Replace(nextaction, "[]", "") nextaction = Replace(nextaction, "[*]", "") 'Set Resource If InStr(nextaction, "olwf") > 0 Or InStr(nextaction, "olio") > 0 Or InStr(nextaction, "olca") > 0 Or InStr(nextaction, "oldt") Then If InStr(nextaction, "olto") > 0 Or obj.Parent.Name = gset("sentitemsfolder") Or (extractname(Outlook.Application.GetNamespace("MAPI").CurrentUser.Name) = getsendername(obj)) Then nextaction = Replace(nextaction, "olto", "") person = getaddresseename(obj) Else person = getsendername(obj) End If       If InStr(nextaction, "olwf") > 0 Then nextaction = Replace(nextaction, "olwf", "") resource = "R:" & person ElseIf InStr(nextaction, "olio") > 0 Then nextaction = Replace(nextaction, "olio", "") resource = "I owe " & person ElseIf InStr(nextaction, "olca") > 0 Then nextaction = Replace(nextaction, "olca", "") resource = RTrim(person) & "@" ElseIf InStr(nextaction, "oldt") > 0 Then nextaction = Replace(nextaction, "oldt", "") resource = "delegated to RTrim(person)" Else resource = "" End If   Else resource = "" End If   'Set Target Date tdate = "" If obj.Class = olAppointment Then tdate = obj.Start & "!" 'assumes deadline for appointments mrcode = "olmsg" ElseIf obj.Class = olTask Then Dim objmsg As New DataObject 'clear clipboard If TaskWasCreatedbyOutLinker(obj) Then mrcode = "olmsg" If InStr(obj.body, vbCrLf) Then objmsg.SetText Left(obj.body, InStr(obj.body, vbCrLf) - 1) & "|" & Right(obj.body, Len(obj.body) - InStr(obj.body, vbCrLf) - 1) Else objmsg.SetText obj.body & "|" End If           ClearClipboard objmsg.PutInClipboard Set objmsg = Nothing Else mrcode = "" 'no hyperlink objmsg.SetText "" ClearClipboard objmsg.PutInClipboard Set objmsg = Nothing End If       If obj.DueDate > 0 And Not (DateValue(obj.DueDate) = DateValue("01/01/4501")) Then tdate = obj.DueDate End If   Else mrcode = "olmsg" End If   '- obj.Close (olDiscard) If sendtotasklist Then setoutlookcategories obj, nextaction hlink = MoveToSavedAndCopyLink(obj) Set newtaskitem = outlooktasklist.Items.Add newtaskitem.Subject = nextaction newtaskitem.body = Left(hlink, InStr(hlink, "|") - 1) & vbCrLf & Right(hlink, Len(hlink) - InStr(hlink, "|")) If istrue("attachmsg") Then newtaskitem.Attachments.Add fname End If       If istrue("putmsginnote") Then newtaskitem.body = newtaskitem.body & vbCrLf & Right(hlink, Len(hlink) - InStr(hlink, "|")) End If       If InStr(LCase(nextaction), codep1) > 0 Then newtaskitem.Importance = olImportanceHigh If InStr(LCase(nextaction), codep2) > 0 Then newtaskitem.Importance = olImportanceNormal If InStr(LCase(nextaction), codep3) > 0 Then newtaskitem.Importance = olImportanceLow If InStr(LCase(nextaction), CodeToday) > 0 Then newtaskitem.DueDate = Date If InStr(LCase(nextaction), CodeTomorrow) > 0 Then newtaskitem.DueDate = Date + 1 If InStr(LCase(nextaction), codenextweek) > 0 Then newtaskitem.DueDate = Date + 7 If InStr(LCase(nextaction), codenextmonth) > 0 Then newtaskitem.DueDate = Date + 30 If InStr(LCase(nextaction), codeisdone) > 0 Then newtaskitem.Complete = 100 If assigncontexttotasks Then 'On Error Resume Next If InStr(LCase(nextaction), "@") > 0 Then newtaskitem.Categories = FirstWord(Right(nextaction, Len(nextaction) - InStr(nextaction, "@") + 1)) End If           If InStr(LCase(nextaction), "@]") > 0 Then 'put contact about in billing information field Dim tmp As String tmp = nextaction tmp = Left(tmp, InStr(tmp, "@]") - 1) tmp = Right(tmp, Len(tmp) - InStrRev(tmp, "[")) newtaskitem.BillingInformation = FirstWord(tmp) End If           If InStr(LCase(nextaction), "r:") > 0 Then newtaskitem.Companies = FirstWord(Right(nextaction, Len(nextaction) - InStr(LCase(nextaction), "r:") - 1)) End If           On Error GoTo 0 If InStr(LCase(nextaction), "call") = 1 Then newtaskitem.Categories = "@phone" If InStr(LCase(nextaction), "pick up") = 1 Then newtaskitem.Categories = "@errand" If InStr(LCase(nextaction), "buy") = 1 Then newtaskitem.Categories = "@errand" If InStr(LCase(nextaction), "return") = 1 Then newtaskitem.Categories = "@errand" If InStr(LCase(nextaction), "order") = 1 Then newtaskitem.Categories = "@web" If InStr(LCase(nextaction), "pay") = 1 Then newtaskitem.Categories = "@web" If InStr(LCase(nextaction), "research") = 1 Then newtaskitem.Categories = "@web" If InStr(LCase(nextaction), "fix") = 1 Then newtaskitem.Categories = "@home" If InStr(LCase(nextaction), "@phone") > 0 Then newtaskitem.Categories = "@phone" If InStr(LCase(nextaction), "@errand") > 0 Then newtaskitem.Categories = "@errand" End If       newtaskitem.Save Exit Sub End If   #If usemm Then If Not istrue("usegyroq") Or sendtoactivemap Or bypassgyroq Or newprojmap Then If mm Is Nothing Then Set mm = getmindmanagerobject If mm Is Nothing Then MsgBox "Outlinker could not open mindmanager" Else mm.Visible = True End If             End If        End If        If Not istrue("usemindreader") Then If mycapturedoc Is Nothing Then Set mycapturedoc = GetOutLinkermycapturedoc(mm) End If           If intray Is Nothing Then Set intray = createmainbranch("OutLinker In-tray", mycapturedoc) End If       If sendtoactivemap Then Set mycapturedoc = mm.ActiveDocument If mycapturedoc Is Nothing Then Set mycapturedoc = mm.Documents.Add If mycapturedoc.Selection.count > 0 Then Set intray = mycapturedoc.Selection.PrimaryTopic Else Set intray = createmainbranch("OutLinker In-tray", mycapturedoc) End If       End If    #End If    If obj.Class = olMail Or obj.Class = olAppointment Or obj.Class = 45 Then hlink = MoveToSavedAndCopyLink(obj) ElseIf obj.Class = olTask Then If InStr(obj.body, "Outlook:") = 1 Then 'this came from outlinker If InStr(obj.body, vbCrLf) > 0 Then hlink = Left(obj.body, InStr(obj.body, vbCrLf) - 1) & "|" & Right(obj.body, Len(obj.body) - InStr(obj.body, vbCrLf) - 1) Else hlink = obj.body End If       Else hlink = obj.body 'transfer task notes End If   End If    #If usemm Then If istrue("usemindreader") Then If Not resource = "" Then mindreaderstring = "[" + resource + "]" + nextaction + "[" + tdate + " " + mrcode + "]" Else mindreaderstring = nextaction + "[" + tdate + " " + obj.Categories + " " + mrcode + "]" End If           If istrue("usegyroq") And Not sendtoactivemap And Not bypassgyroq And Not newprojmap Then If attach Then mindreaderstring = mindreaderstring & "[attach:" & fname & "]" Enqueue mindreaderstring, hlink, settings Else If newprojmap Then Set newmap = mm.Documents.Add If attach Then newmap.CentralTopic.Attachments.Add (fname) mm.ActiveDocument.CentralTopic.Text = mindreaderstring & "[isproject]" newmap.Selection.Set newmap.CentralTopic mm.RunMacro mm.GetPath(MindManager.mmDirectoryMyMaps) + gset("mindreadernlpmacro") 'add in-tray branch newmap.CentralTopic.AddSubTopic("In-tray [isresult]").Task.Categories = "Process,In-tray*" newmap.Selection.Set newmap.CentralTopic.AllSubTopics(1) mm.RunMacro mm.GetPath(MindManager.mmDirectoryMyMaps) + gset("mindreadernlpmacro") 'add reference branch newmap.CentralTopic.AddSubTopic("Reference").Icons.AddStockIcon (mmStockIconNoEntry) 'add plan branch Application.ActiveExplorer.Activate newmap.Selection.Set newmap.CentralTopic.AddBalancedSubTopic("Plan").AddSubTopic(InputBox("What is the next action? Use 1st>>2nd>>3rd to define a sequence of tasks.")) mm.RunMacro mm.GetPath(MindManager.mmDirectoryMyMaps) + gset("mindreadernlpmacro") 'add destination keyword code not implemented yet Set newmap = Nothing ElseIf sendtoactivemap Then mycapturedoc.Activate Set newtask = intray.AddSubTopic(mindreaderstring) If attach Then On Error Resume Next newtask.Attachments.Add fname If Err.Number = 0 Then DeleteFile (fname) Else MsgBox "message file not attached" Err.Clear End If                       On Error GoTo 0 End If                    mycapturedoc.Selection.Set newtask Else mm.Documents.Add mm.ActiveDocument.Activate mm.ActiveDocument.CentralTopic.Notes.Text = "1" If attach Then mm.ActiveDocument.CentralTopic.Text = mindreaderstring & "[attach:" & fname & "]" Else mm.ActiveDocument.CentralTopic.Text = mindreaderstring End If                    On Error Resume Next mm.RunMacro mm.GetPath(MindManager.mmDirectoryMyMaps) + gset("mindreaderopenmacro") If Not (Err.Number = 0) Then MsgBox ("Outlinker got error " & Err.Description & " when it tried to run " & vbCrLf & mm.GetPath(MindManager.mmDirectoryMyMaps) & gset("mindreaderopenmacro") & vbCrLf & "Check your OutLinker settings or contact AO.") End End If                    On Error GoTo 0 End If                'On Error Resume Next On Error Resume Next mm.RunMacro mm.GetPath(MindManager.mmDirectoryMyMaps) + gset("mindreadernlpmacro") If Not (Err.Number = 0) Then MsgBox ("Contact info@activityowner.com to get new version of mindreader or adjust your mindreadernlpmacro setting") End If                On Error GoTo 0 End If       Else Set newtask = intray.AddSubTopic(nextaction) newtask.Task.Complete = 0 newtask.Task.Resources = resource If Not tdate = "" Then newtask.Task.DueDate = tdate If Not obj.Categories = "" Then newtask.Task.Categories = obj.Categories If attach Then On Error Resume Next newtask.Attachments.Add fname If Err.Number = 0 Then DeleteFile (fname) Else MsgBox "message file not attached" Err.Clear End If                 On Error GoTo 0 End If       End If    #End If    If obj.Class = olTask Then If istrue("deleteprocessedtasks") Then obj.Delete Else obj.MarkComplete End If   End If    #If usemm Then If sendtoactivemap Then mm.ActiveDocument.Selection.Set intray IncrementProcessCounters "transfercount" If Not istrue("usemindreader") And Not (mycapturedoc Is Nothing) Then mycapturedoc.Save Set mycapturedoc = Nothing Set intray = Nothing #End If End Sub Function expandword(sometext As String) As String 'expands a "single.word" into a "double word" 'eliminate trailing portion of email addresses being expanded sometext = Replace(sometext, ".", " ") expandword = sometext End Function Function FirstWord(sometext As String) As String sometext = Replace(sometext, ":", "") sometext = Replace(sometext, "]", "") sometext = Replace(sometext, "[", " ") If InStr(sometext, " ") > 0 Then sometext = Left(sometext, InStr(sometext, " ") - 1) End If   FirstWord = expandword(sometext) End Function Function LastWord(sometext As String) As String sometext = Replace(sometext, "[", " ") sometext = Replace(sometext, "]", " ") If InStr(sometext, " ") > 0 Then sometext = Mid(sometext, InStrRev(sometext, " ") + 1) End If   LastWord = expandword(sometext) End Function Function canjumpahead(ByRef lastentry As Object, ByRef nextentry As Object) As Boolean Dim ob As Object canjumpahead = False On Error Resume Next If Not lastentry Is Nothing Then For Each ob In Application.ActiveExplorer.Selection On Error Resume Next If ob.EntryID = lastentry.EntryID Then canjumpahead = True Exit For End If          Next End If      If Not canjumpahead Then If Not nextentry Is Nothing Then Set lastentry = nextentry For Each ob In Application.ActiveExplorer.Selection On Error Resume Next If ob.EntryID = lastentry.EntryID Then canjumpahead = True Exit For End If              Next End If       End If       If Not Err.Number = 0 Then canjumpahead = False Err.Clear End If      On Error GoTo 0 Set ob = Nothing End Function Sub displaystats(ByRef settings As MAPIFolder) If Not settings Is Nothing Then MsgBox ("You have processed " & gset("processcount") & " items" + nl + _                 " deleted:" & gset("deletecount") & nl + _                  " archived:" & gset("archivecount") & nl + _                  " replied:" & gset("replycount") & nl + _                  " forwarded:" & gset("forwardcount") & nl + _                  " transferred:" & gset("transfercount") & nl + nl + _                  "Processed today:" & gset("todaycount")) End If If MsgBox("Do you want excel charts?", vbYesNo) = vbYes Then plothistory getnote(settings, "dailyprocessed"), "Daily Processed" End If End Sub Function itemsleft(ByRef gone As Boolean, totalitems As Integer) As Integer Dim i As Integer Dim tmp As String 'used to test for object errors itemsleft = 0
 * 1) If UseExcel Then
 * 1) End If

On Error Resume Next For i = 1 To totalitems If Not gone(i) Then tmp = objitems(i).EntryID If Err.Number = 0 Then itemsleft = itemsleft + 1 Else Err.Clear End If       End If    Next On Error GoTo 0 End Function Sub showoutlinkerhelp(Optional ByRef blah As Integer) Dim ie As Object Set ie = CreateObject("InternetExplorer.Application") ie.Visible = True ie.navigate "http://wiki.activityowner.com/index.php?title=OutLinker" Set ie = Nothing End Sub Sub incrementskipcount(ByRef obj As Object) Dim objskipcount As UserProperty incrementsetting "skipcount" If istrue("trackskips") Then Set objskipcount = obj.UserProperties.Find("skip") If objskipcount Is Nothing Then Set objskipcount = obj.UserProperties.Add("skip", olNumber) objskipcount.value = 1 Else objskipcount.value = objskipcount.value + 1 End If   On Error Resume Next obj.Save On Error GoTo 0 End If End Sub Sub ResetTodayCounter(Optional dummy As String) Dim lastuse As String lastuse = gset("lastuse") If lastuse = "" Then sset lastuse, Date lastuse = Date End If   If Not (DateValue(lastuse) = DateValue(Date)) Then If MsgBox("Reset today counter (" & gset("todaycount") & ") because date changed from " & gset("lastuse") & " to " & Date & "?", vbYesNo) = vbYes Then addentry settings, "dailyprocessed", gset("lastuse"), gset("todaycount") sset "todaycount", "0" sset "lastuse", Date End If   End If End Sub Sub IncrementProcessCounters(setting As String) incrementsettingby "processcount", 1 incrementsettingby "todaycount", 1 incrementsettingby setting, 1 End Sub Function timesincelastprompt As String timesincelastprompt = Str(DateDiff("s", lastprompt, Now)) End Function Function skipcount(ByRef objitem As Object) As Integer Dim objskipcount As UserProperty On Error Resume Next Set objskipcount = objitem.UserProperties.Find("skip") If objskipcount Is Nothing Or Not istrue("trackskips") Then skipcount = 0 Else skipcount = objskipcount.value End If Set objskipcount = Nothing On Error GoTo 0 End Function Function skiptext(ByRef objitem As Object) As String Dim objskipcount As UserProperty Set objskipcount = objitem.UserProperties.Find("skip") If objskipcount Is Nothing Or Not istrue("trackskips") Then skiptext = "" Else skiptext = Str(objskipcount.value) & "x" End If Set objskipcount = Nothing End Function Function laterconversationmsg(ByRef obj As Object, i As Integer) As Boolean Dim j As Integer On Error Resume Next If i < totalitems Then laterconversationmsg = False For j = i + 1 To totalitems If Not gone(i) Then If obj.ConversationTopic = objitems(j).ConversationTopic Then laterconversationmsg = True Exit Function End If            End If        Next Else laterconversationmsg = False End If   On Error GoTo 0 End Function Function earlierconversationmsg(ByRef obj As Object, i As Integer) As Boolean Dim j As Integer On Error Resume Next If i > 1 Then earlierconversationmsg = False For j = i - 1 To 1 Step -1 If Not gone(i) Then If obj.ConversationTopic = objitems(j).ConversationTopic Then earlierconversationmsg = True Exit Function End If           End If        Next Else earlierconversationmsg = False End If   On Error GoTo 0 End Function

Function conversationcount(ByRef obj As Object) As Integer Dim i As Integer conversationcount = 0 On Error Resume Next For i = 1 To totalitems If Not gone(i) Then If objitems(i).ConversationTopic = obj.ConversationTopic Then conversationcount = conversationcount + 1 End If   Next On Error GoTo 0 End Function Sub sw(label As String) Debug.Print Round(Timer - mtime, 2) & "  :   " & Round(Timer - dtime, 2) & "      :" & label dtime = Timer End Sub Sub addentry(ByRef settings As Outlook.MAPIFolder, setting As String, datestamp As String, num As String) 'Get setting value or prompt for it   Dim found As Boolean Dim i As Integer Dim nitem As Outlook.NoteItem found = False For Each nitem In settings.Items If InStr(nitem.body, setting) = 1 Then nitem.body = nitem.body & vbCrLf & datestamp & ", " & num nitem.Save found = True Exit For End If   Next If Not found Then Set nitem = Outlook.CreateItem(olNoteItem) nitem.body = setting & vbCrLf & datestamp & ", " & num nitem.Move settings End If End Sub Function getnote(ByRef settings As Outlook.MAPIFolder, setting As String) As String 'Get setting value or prompt for it   Dim i As Integer Dim nitem As Outlook.NoteItem getnote = "" For Each nitem In settings.Items If InStr(nitem.body, setting) = 1 Then getnote = nitem.body Exit For End If   Next Set nitem = Nothing End Function

'MindManager Related Code for OutLinker Function getmindmanagerobject As MindManager.Application On Error Resume Next Set getmindmanagerobject = CreateObject("MindManager.Application") If getmindmanagerobject Is Nothing Then Set getmindmanagerobject = CreateObject("MindManager.Application.8") End If       If getmindmanagerobject Is Nothing Then Set getmindmanagerobject = CreateObject("MindManager.Application.7") End If       If getmindmanagerobject Is Nothing Then Set getmindmanagerobject = CreateObject("MindManager.Application.6") End If         On Error GoTo 0 End Function Function GetOutLinkermycapturedoc(ByRef mm As MindManager.Application) As MindManager.Document Dim mrmapStr As String Dim mycapturedoc As MindManager.Document mrmapStr = mm.GetPath(mmDirectoryMyMaps) & "outlookcapture.mmap" On Error Resume Next Set mycapturedoc = mm.Documents.Open(mrmapStr, "", True) On Error GoTo 0 If mycapturedoc Is Nothing Then If MsgBox("Error trying to open " & mrmapStr _               & nl & nl & "Would you like to create one? " _                & nl & nl & "Answer NO if you have have an existing file.", vbYesNoCancel) = vbYes Then Set mycapturedoc = mm.Documents.Add(True) mycapturedoc.CentralTopic.Text = "Outlinker Capture Map" mycapturedoc.CentralTopic.CreateHyperlink ("http://wiki.activityowner.com/index.php?title=OutLinker") mycapturedoc.SaveAs (mrmapStr) End If       End If        Set GetOutLinkermycapturedoc = mycapturedoc End Function Function isVisible(mm As MindManager.Application, mrmapStr As String) As Boolean 'Determine if map is one of the currently visible maps Dim DocCurrent As MindManager.Document isVisible = False For Each DocCurrent In mm.VisibleDocuments If DocCurrent.FullName = mrmapStr Then isVisible = True Exit Function End If       Next Set DocCurrent = Nothing End Function Function GetMindReaderOption(ByRef mroption As String, ByRef ConfigDoc As MindManager.Document) As String 'get value for mroption from ConfigDoc Dim t As MindManager.Topic Dim s As MindManager.Topic Set s = createmainbranch("options", ConfigDoc) GetMindReaderOption = "" If Not ConfigDoc Is Nothing Then For Each t In s.AllSubTopics If t.Text = mroption Then GetMindReaderOption = t.Notes.Text Exit Function End If           Next End If       Set t = Nothing Set s = Nothing End Function Function createmainbranch(mainstring As String, ConfigDoc As MindManager.Document) As MindManager.Topic 'find or create a main topic for mindreader.mmap Dim found As Boolean Dim i As Integer If Not ConfigDoc Is Nothing Then i = ConfigDoc.CentralTopic.AllSubTopics.count While i > 0 And Not found If LCase(ConfigDoc.CentralTopic.AllSubTopics(i).Text) = LCase(mainstring) Then found = True Set createmainbranch = ConfigDoc.CentralTopic.AllSubTopics(i) End If               i = i - 1 Wend If Not found Then Set createmainbranch = ConfigDoc.CentralTopic.AddBalancedSubTopic(mainstring) End If       End If    End Function Sub Enqueue(gyroqstring As String, msglink As String, settings As MAPIFolder) Dim txtTempFileName As String Dim txtCommand As String Dim txtCommandLine As String Dim objmsg As New DataObject Dim rc As Long gyroqstring = Replace(gyroqstring, "'", "%27") gyroqstring = Replace(gyroqstring, ";", "%3B") gyroqstring = Replace(gyroqstring, Chr(34), "%27%27") gyroqstring = Replace(gyroqstring, "%", "%25") If Not "" = msglink Then msglink = Replace(msglink, nl, "*nl*") ' Remove new lines from task notes, replace with *nl* msglink = Replace(msglink, "'", "%27") ' Replace various punctuation marks with escape codes msglink = Replace(msglink, ";", "%3B") msglink = Replace(msglink, Chr(34), "%27%27") ClearClipboard objmsg.SetText msglink ' now copy it to the clipboard objmsg.PutInClipboard End If       txtCommand = "{queue:" & Chr(39) & "GyroQ\GyroActivator-Queue.txt" & Chr(39) & ";clipboard:" & Chr(39) & msglink & Chr(39) & ";" txtCommand = txtCommand + "run:macro:" & Chr(39) & "Call MacroRun(GetPath(mmDirectoryMyMaps)&%22" + gset("mindreaderopenmacro") + "%22,%22/queu" + gyroqstring       txtCommand = txtCommand + "%22) %0D%0A Call MacroRun(GetPath(mmDirectoryMyMaps)&%22" + gset("mindreadernlpmacro") + "%22,%22%22)" & Chr(39) & "}" txtTempFileName = WriteTextToFile(txtCommand, Environ("TMP") + "\" + "GyroTemp.gyr") txtCommandLine = gset("gyroqpath") & "GyroActivator.exe " + "{run:" & Chr(39) & txtTempFileName & Chr(39) & "}" rc = 0 On Error Resume Next rc = Shell(txtCommandLine, vbNormalFocus): DoEvents If rc = 0 Then MsgBox "Make sure you have the path to GyroQ set correctly on the options page (particularly if you are on a 64 bit system)" On Error GoTo 0 Set objmsg = Nothing End Sub Sub EnqueueActivitiesFromTasks_MindReader(ByRef ConfigDoc As MindManager.Document, ByRef objtask As Outlook.TaskItem) Dim txtTempFileName As String Dim txtFileContents As String Dim txtCommand As String Dim txtNotes As String Dim txtSubject As String Dim txtCommandLine As String Dim objmsg As New DataObject Dim rc As Long If Not "" = objtask.body Then txtNotes = Replace(objtask.body, nl, "*nl*") ' Remove new lines from task notes, replace with *nl* txtNotes = Replace(txtNotes, "'", "%27") ' Replace various punctuation marks with escape codes txtNotes = Replace(txtNotes, ";", "%3B") ClearClipboard objmsg.SetText txtNotes ' now copy it to the clipboard objmsg.PutInClipboard End If       txtSubject = Replace(objtask.Subject, "'", "%27") txtSubject = Replace(txtSubject, ";", "%3B") ' More encodings: http://www.blooberry.com/indexdot/topics/urlencoding.htm ' Create the queue command string, based on the MindReader "fq" tag txtCommand = "{queue:" & Chr(39) & "GyroQ\GyroActivator-Queue.txt" & Chr(39) & ";clipboard:" & Chr(39) & "_clipboard_" & Chr(39) & ";" txtCommand = txtCommand + "run:macro:" & Chr(39) & "Call MacroRun(GetPath(mmDirectoryMyMaps)&%22" + gset("mindreaderopenmacro") + "%22,%22/queu" + txtSubject       If Not "" = txtNotes Then            ' only add [note] keyword if there were notes in the task--they will have been copied to the clipboard            txtCommand = txtCommand + " [note]"        End If        txtCommand = txtCommand + "%22) %0D%0A Call MacroRun(GetPath(mmDirectoryMyMaps)&%22" + gset("mindreadernlpmacro") + "%22,%22%22)" & Chr(39) & "}" txtFileContents = txtFileContents + nl + txtCommand If Not objtask.Complete Then objtask.MarkComplete txtTempFileName = WriteTextToFile(txtFileContents, Environ("TMP") + "\" + "GyroTemp.gyr") txtCommandLine = gset("gyroqpath") & "GyroActivator.exe " + "{run:" + Chr(39) + txtTempFileName + Chr(39) + "}" rc = 0 rc = Shell(txtCommandLine, vbNormalFocus): DoEvents If rc = 0 Then MsgBox "Make sure you have the path to GyroQ set correctly in your mindreader.mmap options" Set objtask = Nothing Set objmsg = Nothing End Sub Sub LaunchGyroQWithLink(arg As String, inarg As String, ByRef ConfigDoc As MindManager.Document) Dim txtCommandLine As String ' the two double quotes on either side of the command line arguments are significant. ' the result is that the argument will be passed to the command line with a single pair ' of double quotes around it, which is necessary to get the effect we desire. ' See also: http://www.thescripts.com/forum/thread353820.html 'add text olmsg so that icon can be assigned by mindreader if desired txtCommandLine = gset("gyroqpath") & "GyroQ.exe ""fq [" & inarg & " olmsg]" & arg & """" Dim rc As Long rc = 0 On Error Resume Next rc = Shell(txtCommandLine, vbNormalFocus): DoEvents If rc = 0 Then MsgBox "FAILURE! GyroQ" End Sub Function WriteTextToFile(sContent As String, sfilename As String) Dim fs As Scripting.FileSystemObject Dim a As Scripting.TextStream Dim i As Long Dim newstring As String Set fs = CreateObject("Scripting.FileSystemObject") Set a = fs.CreateTextFile(sfilename, True) newstring = "" For i = 1 To Len(sContent) newstring = newstring & Chr(Asc(Mid(sContent, i, 1))) Next a.WriteLine (newstring) a.Close WriteTextToFile = sfilename '   Set fs = Nothing Set a = Nothing End Function 'Generic Outlook Routines for OutLinker Function cleansubject(Subject As String) As String Dim arg As String arg = Subject arg = Replace(arg, "RE:", "") arg = Replace(arg, "Re:", "") arg = Replace(arg, "Fw:", "") arg = Replace(arg, "FW:", "") cleansubject = arg End Function Function gettasklist As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Dim outlookfolder As Outlook.MAPIFolder Dim i As Integer Set objNS = Application.GetNamespace("MAPI") Set gettasklist = objNS.GetDefaultFolder(olFolderTasks) Set objNS = Nothing End Function Function getaddresseename(ByRef objitem As Object) As String getaddresseename = "" On Error Resume Next If objitem.Class = olTask Then getaddresseename = "" ElseIf objitem.Class = olAppointment Then getaddresseename = objitem.Organizer Else getaddresseename = objitem.To   End If    On Error GoTo 0 If Not Err.Number = 0 Then getaddresseename = "" Err.Clear Else getaddresseename = extractname(getaddresseename) End If  End Function Function getsendername(ByRef objitem As Object) As String getsendername = "" On Error Resume Next If objitem.Class = olTask Then getsendername = "" ElseIf objitem.Class = olAppointment Then getsendername = objitem.Organizer Else getsendername = objitem.SenderName End If   On Error GoTo 0 If Not Err.Number = 0 Then getsendername = "" Err.Clear Else getsendername = extractname(getsendername) End If  End Function Function extractname(estr As String) As String 'extract a MindManager resource from a email string extractname = "" On Error Resume Next If InStr(estr, "RECIPIENTS/CN=") > 0 Then estr = Right(estr, Len(estr) - InStr(estr, "RECIPIENTS/CN=") - Len("RECIPIENTS/CN=") + 1) End If   If InStr(estr, ",") Then estr = Left(estr, InStr(estr, ",") - 1) End If   If InStr(estr, ",") > 0 Then estr = LTrim(Mid(estr, InStr(estr, ",") + 1)) & "." & Mid(estr, 1, InStr(estr, ",") - 1) End If   estr = Replace(estr, " ", ".") ' replace spaces in address with. If InStr(estr, "@") > 1 Then estr = Mid(estr, 1, InStr(estr, "@") - 1) End If   If InStr(estr, ";") > 0 Then estr = Mid(estr, 1, InStr(estr, ";") - 1) End If   estr = Replace(estr, "'", "") extractname = LTrim(RTrim(estr)) On Error GoTo 0 If Not Err.Number = 0 Then extractname = "" Err.Clear End If End Function
 * 1) If usemm Then
 * 1) End If

Sub OpenAttachment(ByRef obj As Object, i As Integer) If obj.Attachments.count >= i Then Dim fso As Scripting.FileSystemObject Set fso = CreateObject("scripting.filesystemobject") Dim fld As Scripting.folder Set fld = fso.GetSpecialFolder(TemporaryFolder) Dim objwshshell As IWshRuntimeLibrary.WshShell Set objwshshell = CreateObject("wscript.shell") Dim fname As String 'On Error Resume Next fname = fld.Path & "\" & obj.Attachments.Item(i).FileName obj.Attachments.Item(i).SaveAsFile (fname) objwshshell.run Chr(34) & fname & Chr(34) 'On Error GoTo 0 Set fso = Nothing Set fld = Nothing Set objwshshell = Nothing End If End Sub Function SaveAsMsg(ByRef obj As Object) As String Dim fso As Scripting.FileSystemObject Set fso = CreateObject("scripting.filesystemobject") Dim fld As Scripting.folder Set fld = fso.GetSpecialFolder(TemporaryFolder) Dim fname As String Dim objwshshell As IWshRuntimeLibrary.WshShell Set objwshshell = CreateObject("wscript.shell") fname = fld.Path & "\" & Right(obj.EntryID, 10) & ".msg" On Error Resume Next obj.SaveAs fname, olMSG If Not Err.Number = 0 Then MsgBox "message file not saved" Err.Clear fname = "" End If       On Error GoTo 0 SaveAsMsg = fname Set fso = Nothing Set fld = Nothing Set objwshshell = Nothing End Function Function DeleteFile(ByRef fname As String) As String Dim fso As Scripting.FileSystemObject Set fso = CreateObject("scripting.filesystemobject") On Error Resume Next fso.DeleteFile fname On Error GoTo 0 End Function Function MoveToSaved(ByRef obj As Object) As String ' This subroutine will move the select email object to pstfolder in pstfile. Pass back hyperlink to object Dim objfolder As Outlook.MAPIFolder Dim objMovedItem As Object If istrue("usearchive1") Then Set objfolder = getarchivefolder1 If istrue("usearchive2") Then Set objfolder = getarchivefolder2 If istrue("usearchive3") Then Set objfolder = getarchivefolder3 If istrue("usearchive4") Then Set objfolder = getarchivefolder4 If istrue("usearchive5") Then Set objfolder = getarchivefolder5 If obj.Class = olMail Or obj.Class = 45 Then If Not (objfolder.DefaultItemType = olMailItem) Then MsgBox ("You can only use this on mail folder") Set objfolder = Nothing Set objMovedItem = Nothing Exit Function End If       ' Move the mail item to the archive folder as objMovedItem ' objMovedItem will contain a reference to the new object that lives in archive On Error Resume Next If obj.Parent.Name = objfolder.Name Then If obj.Parent.Parent.Name = objfolder.Parent.Name Then Set objMovedItem = obj Else Set objMovedItem = obj.Move(objfolder) End If       Else Set objMovedItem = obj.Move(objfolder) End If       If objMovedItem Is Nothing Then MsgBox ("Error trying to move this message: " & Err.Description) Set objfolder = Nothing Set objMovedItem = Nothing Exit Function End If        If Not objMovedItem Is Nothing Then 'On Error Resume Next MoveToSaved = "Outlook:" + objMovedItem.EntryID On Error GoTo 0 Else MoveToSaved = "" End If        Set objMovedItem = Nothing Else MsgBox "Can only archive messages" MoveToSaved = "" End If End Function Sub SendLinktoMindManager Dim obj As Object Dim objectlink As String Dim objecttext As String Dim mm As MindManager.Application Dim d As MindManager.Document Dim t As MindManager.Topic Dim t2 As MindManager.Topic Set mm = getmindmanagerobject Set d = mm.ActiveDocument If d Is Nothing Then Set d = mm.Documents.Add If Not d Is Nothing Then Set t = d.Selection.PrimaryTopic If t Is Nothing Then Set t = d.CentralTopic For Each obj In Application.ActiveExplorer.Selection 'Set obj = Application.ActiveExplorer.Selection.Item(1) If obj.Class = olContact Then objecttext = obj.FullName Else objecttext = obj.Subject End If       objectlink = "Outlook:" + obj.EntryID Set t2 = t.AddSubTopic(objecttext) t2.CreateHyperlink (objectlink) t2.Notes.Text = obj.body t2.Hyperlink.Absolute = True Next Set mm = Nothing Set d = Nothing Set t = Nothing Set t2 = Nothing MsgBox ("Map topics added for selected items.") End Sub Function MoveToSavedAndCopyLink(ByRef obj As Object) As String ' This subroutine will move the select email object to pstfolder in pstfile and copy a link to that item to clipboard Dim objfolder As Outlook.MAPIFolder Dim osender As String Dim txtMsg As String Dim txtDate As String MoveToSavedAndCopyLink = "" txtMsg = MoveToSaved(obj) If txtMsg = "" Then MsgBox "Error trying to move message" Exit Function End If   On Error Resume Next txtDate = obj.SentOn If obj.Type = olMail Then osender = obj.SenderName ElseIf obj.Type = olAppointment Then osender = obj.Organizer Else osender = "" End If   On Error GoTo 0 ' Now build a link to that item. The URI should start with "Outlook:" ' The body of the link is the EntryID for the item. If obj.Class = olMail Then txtMsg = txtMsg + "|" If istrue("PutMsgInNote") Then txtMsg = txtMsg + "From: " + osender + nl               txtMsg = txtMsg + "Date: " + txtDate + nl                txtMsg = txtMsg + "To: " + obj.To + nl                txtMsg = txtMsg + "CC: " + obj.CC + nl            End If        Else txtMsg = txtMsg + "|" End If       If istrue("PutMsgInNote") Then txtMsg = txtMsg + "Subject: " + obj.Subject + nl           txtMsg = txtMsg + nl            If Len(obj.body) > maxbodylength Then If Not longmessagewarned Then longmessagewarned = (MsgBox("Warning: Messages has more than " & Str(maxbodylength) & " characters and will be trunicated in note. Do you want further warnings?", vbYesNo) = vbNo) End If               On Error Resume Next txtMsg = txtMsg + Left(obj.body, maxbodylength) On Error GoTo 0 Else txtMsg = txtMsg + obj.body End If       End If        Dim objmsg As New DataObject objmsg.SetText txtMsg ClearClipboard objmsg.PutInClipboard Set objmsg = Nothing MoveToSavedAndCopyLink = txtMsg End Function Function getarchivefolder1 As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") On Error Resume Next Set getarchivefolder1 = objNS.GetFolderFromID(gset("ArchiveFolder1ID"), gset("ArchiveStore1ID")) If getarchivefolder1 Is Nothing Then MsgBox "You will not be prompted to pick a folder ot archive messages to" Set getarchivefolder1 = objNS.PickFolder End If   If Not getarchivefolder1 Is Nothing Then sset "ArchiveStore1ID", getarchivefolder1.StoreID sset "ArchiveFolder1ID", getarchivefolder1.EntryID End If   On Error GoTo 0 Set objNS = Nothing End Function Function getarchivefolder2 As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") On Error Resume Next Set getarchivefolder2 = objNS.GetFolderFromID(gset("ArchiveFolder2ID"), gset("ArchiveStore2ID")) On Error GoTo 0 'If getarchivefolder2 Is Nothing Then Set getarchivefolder2 = objNS.PickFolder If Not getarchivefolder2 Is Nothing Then sset "ArchiveStore2ID", getarchivefolder2.StoreID sset "ArchiveFolder2ID", getarchivefolder2.EntryID End If   Set objNS = Nothing End Function Function getarchivefolder3 As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") On Error Resume Next Set getarchivefolder3 = objNS.GetFolderFromID(gset("ArchiveFolder3ID"), gset("ArchiveStore3ID")) 'If getarchivefolder3 Is Nothing Then Set getarchivefolder3 = objNS.PickFolder If Not getarchivefolder2 Is Nothing Then sset "ArchiveStore3ID", getarchivefolder3.StoreID sset "ArchiveFolder3ID", getarchivefolder3.EntryID End If   Set objNS = Nothing End Function Function getarchivefolder4 As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") On Error Resume Next Set getarchivefolder4 = objNS.GetFolderFromID(gset("ArchiveFolder4ID"), gset("ArchiveStore4ID")) 'If getarchivefolder4 Is Nothing Then Set getarchivefolder4 = objNS.PickFolder If Not getarchivefolder4 Is Nothing Then sset "ArchiveStore4ID", getarchivefolder4.StoreID sset "ArchiveFolder4ID", getarchivefolder4.EntryID End If   Set objNS = Nothing End Function Function getarchivefolder5 As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") On Error Resume Next Set getarchivefolder5 = objNS.GetFolderFromID(gset("ArchiveFolder5ID"), gset("ArchiveStore5ID")) 'If getarchivefolder5 Is Nothing Then Set getarchivefolder5 = objNS.PickFolder If Not getarchivefolder5 Is Nothing Then sset "ArchiveStore5ID", getarchivefolder5.StoreID sset "ArchiveFolder5ID", getarchivefolder5.EntryID End If   Set objNS = Nothing End Function
 * 1) If usemm Then
 * 1) End If

Function getfolder(ostore As String, ofolder As String) As Outlook.MAPIFolder Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") On Error Resume Next Set getfolder = objNS.Folders(ostore).Folders(ofolder) On Error GoTo 0 Set objNS = Nothing End Function Function getgmailtrashfolderfromobj(ByRef obj As Object) ' Work in Progress Dim objNS As Outlook.NameSpace Dim f As Outlook.MAPIFolder Dim f1 As Outlook.MAPIFolder Dim f2 As Outlook.MAPIFolder Dim objaccount As String If InStr(obj.Parent.FolderPath, "@gmail.com") > 0 Then objaccount = Mid(obj.Parent.FolderPath, 1, InStr(obj.Parent.FolderPath, "@")) Else Exit Function End If   Set objNS = Application.GetNamespace("MAPI") For Each f In objNS.Folders If InStr(f.FolderPath, objaccount) > 0 Then For Each f1 In f.Folders If InStr(f1.Name, "[Gmail]") > 0 Then For Each f2 In f1.Folders If InStr(f2.Name, "Trash") > 0 Then Set getgmailtrashfolderfromobj = f2                           Exit Function End If                   Next End If           Next End If   Next End Function

Function getfolder2deep(store As String, folder As String, subfolder As String) As Outlook.MAPIFolder Dim pfolder As Outlook.MAPIFolder Dim sfolder As Outlook.MAPIFolder Set pfolder = getfolder(store, folder) Dim found As Boolean found = False For Each sfolder In pfolder.Folders If LCase(sfolder.Name) = LCase(subfolder) Then found = True Set getfolder2deep = sfolder End If   Next If Not found Then MsgBox ("sub-folder " & subfolder & " not found in " & folder & " in " & store) Set pfolder = Nothing Set sfolder = Nothing End End If   Set pfolder = Nothing Set sfolder = Nothing End Function Function isbulk(obj) As Boolean Dim body As String Const maxkeywords = 20 Dim i As Integer Dim bulkkeywords(maxkeywords) As String bulkkeywords(1) = "unsubscribe" bulkkeywords(2) = "opt out" bulkkeywords(3) = "register now and save" bulkkeywords(4) = "register now & save" bulkkeywords(5) = "further emails" bulkkeywords(6) = "in the subject line" bulkkeywords(7) = "prefer not to receive" bulkkeywords(8) = "adjust your preferences" bulkkeywords(9) = "to stop receiving such messages from" bulkkeywords(10) = "to be removed from" bulkkeywords(11) = "outopt" bulkkeywords(12) = "address-book" bulkkeywords(13) = "email communication preferences" bulkkeywords(14) = "from out mailing list" bulkkeywords(15) = "if you no longer wish to receive" bulkkeywords(16) = "if you do not wish to receive" bulkkeywords(17) = "if you do not want to receive" bulkkeywords(18) = "excluded from this list" bulkkeywords(19) = "subscription" bulkkeywords(20) = "receive these messages" isbulk = False On Error Resume Next body = LCase(obj.body) For i = 1 To maxkeywords If InStr(body, bulkkeywords(i)) > 0 Then isbulk = True Next If InStr(LCase(obj.Subject), "fw:") > 0 Then isbulk = False On Error GoTo 0 'should also look for messages from person's domain End Function 'Settings Related Code for Outlinker Function existsetting(setting) As Boolean existsetting = Not GetSetting(OutLinkerRegName, OutLInkerRegPref, setting, "emptysetting") = "emptysetting" End Function Sub CreateSetting(setting As String, value As String) If Not existsetting(setting) Then sset setting, value Debug.Print "creating setting " & setting & " with value of " & value End If End Sub Function gset(ByRef setting As String) As String gset = GetSetting(OutLinkerRegName, OutLInkerRegPref, setting, "empty") If gset = "empty" Then gset = "" End If End Function Sub dset(setting As String) On Error Resume Next DeleteSetting OutLinkerRegName, OutLInkerRegPref, setting On Error GoTo 0 End Sub Sub sset(setting As String, value As String) On Error Resume Next SaveSetting OutLinkerRegName, OutLInkerRegPref, setting, value If Not Err.Number = 0 Then dset setting SaveSetting OutLinkerRegName, OutLInkerRegPref, setting, value Err.Clear End If   On Error GoTo 0 End Sub Sub setboolean(setting As String, value As Boolean) If value Then SaveSetting OutLinkerRegName, OutLInkerRegPref, setting, "1" Else SaveSetting OutLinkerRegName, OutLInkerRegPref, setting, "0" End If End Sub Function istrue(ByRef setting As String) As Boolean istrue = LTrim(RTrim(gset(setting))) = "1" End Function Function getolsetting(ByRef settingsfolder As Outlook.MAPIFolder, ByRef setting As String) As String 'Get setting value or prompt for it   Dim i As Integer Dim nitem As Outlook.NoteItem If Not settingsfolder Is Nothing Then For Each nitem In settingsfolder.Items If InStr(nitem.body, setting) = 1 Then getolsetting = Replace(nitem.body, setting & ":", "") Exit Function End If       Next End If   getolsetting = getdefaultsetting(setting) End Function Sub deleteolsetting(ByRef settings As Outlook.MAPIFolder, setting As String) 'Get setting value or prompt for it   Dim found As Boolean Dim nitem As Outlook.NoteItem found = False For Each nitem In settings.Items If InStr(nitem.body, setting) = 1 Then nitem.Delete Next End Sub Sub incrementsetting(setting As String) incrementsettingby setting, 1 End Sub Sub incrementsettingby(setting As String, num As Integer) Dim count As String count = gset(setting) If count = "" Then count = "0" sset setting, Str(Val(count) + num) End Sub Function CreateSettingsFolder(settingsname As String) As Outlook.MAPIFolder 'find or add settings folder Dim objNS As Outlook.NameSpace Dim defaultfolder As Outlook.MAPIFolder Dim fold As Outlook.MAPIFolder On Error Resume Next Set objNS = Application.GetNamespace("MAPI") Set defaultfolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) For Each fold In defaultfolder.Parent.Folders If fold.Name Like settingsname Then Set CreateSettingsFolder = fold Exit For End If   Next If CreateSettingsFolder Is Nothing Then Set CreateSettingsFolder = defaultfolder.Parent.Folders.Add(settingsname, olFolderNotes) If CreateSettingsFolder Is Nothing Then MsgBox ("Could not create settings folder " & settingsname & ". " & Err.Description) Set objNS = Nothing Set fold = Nothing Set defaultfolder = Nothing On Error GoTo 0 End Function

Function getdefaultsetting(ByRef setting As String) As String Select Case setting Case "trimsubject": getdefaultsetting = "1" Case "gyroqpath": getdefaultsetting = "C:\program files\Gyronix\GyroQ\" Case "usegyroq":  getdefaultsetting = "1" Case "trackskips": getdefaultsetting = "1" Case "showstats": getdefaultsetting = "1" Case "ArchiveStore": getdefaultsetting = "Personal Folders" Case "ArchiveFolder1": getdefaultsetting = "mainarchive" Case "ArchiveStore2": getdefaultsetting = "Personal Folders" Case "ArchiveFolder2": getdefaultsetting = "mainarchive" Case "ArchiveStore3": getdefaultsetting = "Personal Folders" Case "ArchiveFolder3": getdefaultsetting = "mainarchive" Case "ArchiveStore4": getdefaultsetting = "Personal Folders" Case "ArchiveFolder4": getdefaultsetting = "mainarchive" Case "ArchiveStore5": getdefaultsetting = "Personal Folders" Case "ArchiveFolder5": getdefaultsetting = "mainarchive" Case "usearchive1": getdefaultsetting = "1" Case "usearchive2": getdefaultsetting = "0" Case "ArchiveFolder2": getdefaultsetting = "mainarchive" Case "PutMsgInNote": getdefaultsetting = "0" Case "gmailstore": getdefaultsetting = "imap.gmail.com" Case "underinbox": getdefaultsetting = "0" Case "mindreaderopenmacro": getdefaultsetting = "ao\ao_mindreaderopen.mmbas" Case "mindreadernlpmacro": getdefaultsetting = "ao\ao_mindreaderNLP.mmbas" Case "usemindreader": getdefaultsetting = "1" Case "formleft": getdefaultsetting = defaultformleft Case "formtop": getdefaultsetting = "1" Case "lastuse": getdefaultsetting = Date Case "archivecount": getdefaultsetting = "0" Case "composecount": getdefaultsetting = "0" Case "deletecount": getdefaultsetting = "0" Case "forwardcount": getdefaultsetting = "0" Case "archivecount": getdefaultsetting = "0" Case "processcount": getdefaultsetting = "0" Case "replycount": getdefaultsetting = "0" Case "skipcount": getdefaultsetting = "0" Case "todaycount": getdefaultsetting = "0" Case "transfercount": getdefaultsetting = "0" Case "attachmsg": getdefaultsetting = "0" Case "lastupgrade": getdefaultsetting = "0" Case "deleteprocessedtasks": getdefaultsetting = "0" Case "versioncheckfrequency": getdefaultsetting = "30" Case "lastversioncheck": getdefaultsetting = Date Case "context1": getdefaultsetting = "@errand" Case "context2": getdefaultsetting = "@phone" Case "context3": getdefaultsetting = "@desk" Case "context4": getdefaultsetting = "@home" Case "context5": getdefaultsetting = "@web" Case "tag1": getdefaultsetting = "Family" Case "tag2": getdefaultsetting = "Friends" Case "tag3": getdefaultsetting = "Finances" Case "tag4": getdefaultsetting = "Career" Case "tag5": getdefaultsetting = "Home Repair" Case "tag6": getdefaultsetting = "Sharpen Saw" Case Else Debug.Print "default value not found for " & setting getdefaultsetting = "" End Select End Function Sub movesetting(ByRef settings As Outlook.MAPIFolder, ByRef setting As String) CreateSetting setting, getolsetting(settings, setting) deleteolsetting settings, setting End Sub Sub createdefaultsetting(ByRef setting As String) CreateSetting setting, getdefaultsetting(setting) End Sub

Sub UpgradeSettings(ByRef settings As Outlook.MAPIFolder) Const lastupgrade = "20090402" Dim userupgrade As String userupgrade = gset("lastupgrade") If userupgrade = "" Then userupgrade = getolsetting(settings, "lastupgrade") If userupgrade = "" Then userupgrade = "0" If Val(userupgrade) < Val(lastupgrade) Then If Val(lastupgrade) > 0 And Val(userupgrade) < 20090306 Then If MsgBox("OutLinker needs to do initial setup/upgrade of your settings. This may take a minute", vbOKCancel) = vbOK Then movesetting settings, "usegyroq" movesetting settings, "usemindreader" movesetting settings, "trackskips" movesetting settings, "showstats" movesetting settings, "PutMsgInNote" movesetting settings, "ArchiveStore" movesetting settings, "gyroqpath" movesetting settings, "mindreaderopenmacro" movesetting settings, "mindreadernlpmacro" movesetting settings, "archivecount" movesetting settings, "composecount" movesetting settings, "deletecount" movesetting settings, "forwardcount" movesetting settings, "lastuse" movesetting settings, "processcount" movesetting settings, "replycount" movesetting settings, "skipcount" movesetting settings, "todaycount" movesetting settings, "transfercount" 'obsolete settings deleteolsetting settings, "mindreaderconfigmap" deleteolsetting settings, "mmversion" deleteolsetting settings, "sentitemsfolder" 'get directly from outlook now deleteolsetting settings, "oneprompt" deleteolsetting settings, "lastupgrade" deleteolsetting settings, "formtop" deleteolsetting settings, "formleft" Else End End If       End If        createdefaultsetting "usegyroq" createdefaultsetting "usemindreader" createdefaultsetting "trackskips" createdefaultsetting "showstats" createdefaultsetting "PutMsgInNote" createdefaultsetting "gyroqpath" createdefaultsetting "mindreaderopenmacro" createdefaultsetting "mindreadernlpmacro" createdefaultsetting "archivecount" createdefaultsetting "composecount" createdefaultsetting "deletecount" createdefaultsetting "forwardcount" createdefaultsetting "lastuse" createdefaultsetting "processcount" createdefaultsetting "replycount" createdefaultsetting "skipcount" createdefaultsetting "todaycount" createdefaultsetting "transfercount" createdefaultsetting "attachmsg" createdefaultsetting "lastversioncheck" createdefaultsetting "versioncheckfrequency" createdefaultsetting "deleteprocessedtasks" createdefaultsetting "context1" createdefaultsetting "context2" createdefaultsetting "context3" createdefaultsetting "context4" createdefaultsetting "context5" createdefaultsetting "tag1" createdefaultsetting "tag2" createdefaultsetting "tag3" createdefaultsetting "tag4" createdefaultsetting "tag5" createdefaultsetting "tag6" createdefaultsetting "usearchive1" createdefaultsetting "trimsubject" sset "formtop", "1" sset "formleft", defaultformleft sset "attachmsg", "0" sset "lastversioncheck", Date '       dset "ArchiveStore" dset "ArchiveFolder" dset "underinbox" dset "gmailstore" dset "useform" sset "lastupgrade", lastupgrade End If End Sub Sub showsettings(Optional dummy As String) With OutLinkerSettings .mindreadernlpmacroTextBox.value = gset("mindreadernlpmacro") .mindreaderopenmacroTextBox.value = gset("mindreaderopenmacro") .gyroqpathTextBox.value = gset("gyroqpath") .usegyroqCheckBox.value = istrue("usegyroq") .usemindreaderCheckBox.value = istrue("usemindreader") #If Not usemm Then .mindreadernlpmacroTextBox.Visible = False .mindreaderopenmacroTextBox.Visible = False .gyroqpathLabel.Visible = False .gyroqpathTextBox.Visible = False .usemindreaderCheckBox.Visible = False .mindreadernlpmacroLabel.Visible = False .mindreaderopenmacroLabel.Visible = False .usegyroqCheckBox.Visible = False .defaultmapLabel.Visible = False .defaultmappath.Visible = False #Else Dim mm As MindManager.Application Set mm = getmindmanagerobject .defaultmappath.Caption = mm.GetPath(mmDirectoryMyMaps) Set mm = Nothing #End If       .deletedprocessedCheckBox.value = istrue("deleteprocessedtasks") .showstatsCheckBox.value = istrue("showstats") .trackskipsCheckBox.value = istrue("trackskips") .context1TextBox.value = gset("context1") .context2TextBox.value = gset("context2") .context3TextBox.value = gset("context3") .context4TextBox.value = gset("context4") .context5TextBox.value = gset("context5") .Context6TextBox.value = gset("context6") .Context7TextBox.value = gset("context7") .Context8TextBox.value = gset("context8") .Context9TextBox.value = gset("context9") .TrimSubjectCheckBox.value = istrue("trimsubject") .VersionLabel.Caption = "OutLinker" & " " & version .tagTextBox1.value = gset("tag1") .tagTextBox2.value = gset("tag2") .tagTextBox3.value = gset("tag3") .tagTextBox4.value = gset("tag4") .tagTextBox5.value = gset("tag5") .tagTextBox6.value = gset("tag6") .TagTextBox7.value = gset("tag7") .TagTextBox8.value = gset("tag8") .TagTextBox9.value = gset("tag9") .TagTextBox10.value = gset("tag10") .TagTextBox11.value = gset("tag11") .TagTextBox12.value = gset("tag12") .TagTextBox13.value = gset("tag13") .TagTextBox14.value = gset("tag14") .TagTextBox15.value = gset("tag15") .TagTextBox16.value = gset("tag16") .TagTextBox17.value = gset("tag17") .TagTextBox18.value = gset("tag18") .TagTextBox19.value = gset("tag19") .TagTextBox20.value = gset("tag20") On Error Resume Next If Val(gset("versioncheckfrequency")) > 0 Then .nextversioncheckLabel = Str(DateValue(gset("lastversioncheck")) + Val(gset("versioncheckfrequency"))) End If       On Error GoTo 0 .Show End With End Sub Sub olversioncheck(Optional force As Boolean) Dim ie As Object On Error Resume Next If Val(gset("versioncheckfrequency")) > 0 Or force Then If ((DateValue(gset("lastversioncheck")) + Val(gset("versioncheckfrequency"))) < Date) Or force Then If force Then Set ie = CreateObject("InternetExplorer.Application") ie.Visible = True ie.navigate "http://activityowner.com/installers/outlinkerversioncheck.php?installed=" & version Set ie = Nothing ElseIf MsgBox("Do you want to see if there is a new version of OutLinker available?", vbYesNo) = vbYes Then Set ie = CreateObject("InternetExplorer.Application") ie.Visible = True ie.navigate "http://activityowner.com/installers/outlinkerversioncheck.php?installed=" & version Set ie = Nothing End If              sset "lastversioncheck", Date End If   End If    On Error GoTo 0 Set ie = Nothing End Sub Function GetMsgEntryIDfromTask(ByRef obj As Object) As String 'extract the outlook entryid from a task created by outlinker Dim MsgEntryID As String MsgEntryID = obj.body MsgEntryID = Left(MsgEntryID, InStr(MsgEntryID, vbCrLf) - 1) MsgEntryID = Right(MsgEntryID, Len(MsgEntryID) - InStr(MsgEntryID, ":")) GetMsgEntryIDfromTask = MsgEntryID End Function Function TaskWasCreatedbyOutLinker(ByRef obj As Object) As Boolean TaskWasCreatedbyOutLinker = False On Error Resume Next TaskWasCreatedbyOutLinker = Left(obj.body, 8) = "Outlook:" If Not Err.Number = 0 Then MsgBox "Outlinker error: perhaps due to large message" Err.Clear End If   On Error GoTo 0 End Function Function isOutLinkerTask(ByRef obj As Object) As Boolean isOutLinkerTask = False On Error Resume Next If (obj.Class = olTask) Then If Left(obj.body, 8) = "Outlook:" Then isOutLinkerTask = True End If   End If    If Not Err.Number = 0 Then MsgBox "Outlinker error: perhaps due to large message" Err.Clear End If   On Error GoTo 0 End Function Function GetMsgFromTask(ByRef obj As Object) As Object On Error Resume Next Set GetMsgFromTask = Outlook.Application.GetNamespace("MAPI").GetItemFromID(GetMsgEntryIDfromTask(obj)) On Error GoTo 0 End Function Sub nextmsginthread(totalitems As Integer, i As Integer, obj As Object, ByRef lastentry As Object, ByRef jumpahead As Boolean) Dim j As Integer On Error Resume Next If totalitems > i Then For j = i + 1 To totalitems If Not gone(j) Then If objitems(j).ConversationTopic = obj.ConversationTopic Then Set lastentry = objitems(j) jumpahead = True Exit For End If            End If         Next End If   On Error GoTo 0 End Sub Sub prevmsginthread(totalitems As Integer, i As Integer, obj As Object, ByRef lastentry As Object, ByRef jumpahead As Boolean, ByRef gotoprev As Boolean) Dim j As Integer On Error Resume Next If totalitems > 1 Then For j = i - 1 To 1 Step -1 If Not gone(j) Then If objitems(j).ConversationTopic = obj.ConversationTopic Then Set lastentry = objitems(j) jumpahead = True gotoprev = True Exit For End If           End If        Next End If   On Error GoTo 0 End Sub Sub prevmsg(totalitems As Integer, i As Integer, obj As Object, ByRef lastentry As Object, ByRef jumpahead As Boolean, ByRef gotoprev As Boolean) Dim j As Integer On Error Resume Next If totalitems > 1 Then For j = i - 1 To 1 Step -1 If Not gone(j) Then Set lastentry = objitems(j) jumpahead = True gotoprev = True Exit For End If       Next End If   On Error GoTo 0 End Sub Sub threadzoom(ByRef obj As Object, ByRef iszoomed As Boolean) Dim j As Integer On Error Resume Next For j = 1 To totalitems If Not (objitems(j).ConversationTopic = obj.ConversationTopic) Then gone(j) = True End If   Next iszoomed = True On Error GoTo 0 End Sub Sub unthreadzoom(ByRef iszoomed As Boolean) Dim j As Integer totalitems = Application.ActiveExplorer.Selection.count For j = 1 To totalitems Set objitems(j) = Application.ActiveExplorer.Selection.Item(j) gone(j) = False Next iszoomed = False End Sub Sub setnextentry(i As Integer, ByRef nextentry As Object) Dim j As Integer If totalitems > 1 Then For j = i + 1 To totalitems If Not gone(j) Then Set nextentry = objitems(j) Exit For End If   Next End If End Sub Sub setoutlookcategories(ByRef obj As Object, ByRef nextaction As String) Dim i As Integer Dim cat As String Dim collecting As Boolean cat = "" collecting = False For i = 1 To Len(nextaction) If Mid(nextaction, i, 2) = "[*" Then collecting = True If Mid(nextaction, i, 1) = "]" Then collecting = False If collecting Then If Mid(nextaction, i, 1) = "*" Then If Not cat = "" Then cat = cat & "," Else cat = cat & Mid(nextaction, i, 1) End If           End If        End If    Next obj.Categories = cat End Sub Function getoutlookcategories(ByRef obj As Object) As String Dim i As Integer Dim cat As String Dim tmp As String Dim collecting As Boolean cat = obj.Categories tmp = "" If Not cat = "" Then tmp = "[*" For i = 1 To Len(cat) If Mid(cat, i, 1) = "," Then tmp = tmp & "][*" Else tmp = tmp & Mid(cat, i, 1) End If     Next tmp = tmp & "]" End If    getoutlookcategories = tmp End Function Sub setupSession(Optional dummy As Integer) sset "formleft", defaultformleft sset "formtop", "1" longmessagewarned = False avgcount = 0 avgprocess = 0 Set settings = CreateSettingsFolder("Outlinker Settings") UpgradeSettings settings ResetTodayCounter sset "sentitemsfolder", Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Name Set archivefolder1 = getarchivefolder1 Set outlooktasklist = gettasklist If archivefolder1 Is Nothing Then MsgBox "Archive Folder not Found" On Error Resume Next On Error GoTo 0 olversioncheck lastprompt = Now End Sub Sub Archive If settings Is Nothing Then setupSession If Application.ActiveExplorer.Selection.count > 1 Then If MsgBox("Archive messages?", vbOKCancel) = vbCancel Then Exit Sub End If   End If    If Not istrue("usearchive1") Then If istrue("usearchive2") Then Set archivefolder2 = getarchivefolder2 If MsgBox("Archive to " & archivefolder2.FolderPath & "?", vbOKCancel) = vbCancel Then Exit Sub Else If archivefolder2 Is Nothing Then Set archivefolder2 = getarchivefolder2 End If       End If        If istrue("usearchive3") Then Set archivefolder3 = getarchivefolder3 If MsgBox("Archive to " & archivefolder3.FolderPath & "?", vbOKCancel) = vbCancel Then Exit Sub Else If archivefolder3 Is Nothing Then Set archivefolder3 = getarchivefolder3 End If       End If        If istrue("usearchive4") Then Set archivefolder4 = getarchivefolder4 If MsgBox("Archive to " & archivefolder4.FolderPath & "?", vbOKCancel) = vbCancel Then Exit Sub Else If archivefolder4 Is Nothing Then Set archivefolder4 = getarchivefolder4 End If       End If        If istrue("usearchive5") Then Set archivefolder5 = getarchivefolder5 If MsgBox("Archive to " & archivefolder5.FolderPath & "?", vbOKCancel) = vbCancel Then Exit Sub Else If archivefolder5 Is Nothing Then Set archivefolder5 = getarchivefolder5 End If       End If    End If    For Each obj In Application.ActiveExplorer.Selection MoveToSaved obj IncrementProcessCounters "archivecount" Next End Sub

Sub Delete If settings Is Nothing Then setupSession If Application.ActiveExplorer.Selection.count > 1 Then If MsgBox("Delete messages?", vbOKCancel) = vbCancel Then Exit Sub End If   End If    For Each obj In Application.ActiveExplorer.Selection If Not InStr(obj.Parent.FolderPath, "@gmail.com") > 0 And InStr(obj.Parent.FolderPath, "\\") > 0 Then Debug.Print "not gmail" On Error Resume Next obj.Close olDiscard obj.Delete On Error GoTo 0 Else Set gmailtrash = getgmailtrashfolderfromobj(obj) If Not gmailtrash Is Nothing Then On Error Resume Next obj.Move gmailtrash obj.Close olDiscard On Error GoTo 0 Else On Error Resume Next obj.Delete On Error GoTo 0 MsgBox "gmail trash folder not found: deleting manually" End If        End If         IncrementProcessCounters "deletecount" Next End Sub

Sub plothistory(ByRef nlog As String, ByRef ylabel As String) Dim Excelapp As Excel.Application Dim exceldoc As Excel.Workbook Dim ndate As Double Dim nscore As Double Dim i As Integer Dim lastlen As Integer Dim sheet As Object Dim factor As Integer factor = 1 Set Excelapp = CreateObject("excel.application") Excelapp.Visible = True Set exceldoc = Excelapp.Workbooks.Add For i = 1 To exceldoc.Sheets.count - 1 exceldoc.Sheets(i).Delete Next Set sheet = exceldoc.Sheets.Add i = 0 lastlen = 0 While Len(nlog) > 0 And Not (Len(nlog) = lastlen) i = i + 1 lastlen = Len(nlog) On Error Resume Next ndate = DateValue(Left(nlog, InStr(nlog, ",") - 1)) + TimeValue(Left(nlog, InStr(nlog, ",") - 1)) nlog = Right(nlog, Len(nlog) - InStr(nlog, ",")) If InStr(nlog, vbCrLf) > 0 Then nscore = Val(Left(nlog, InStr(nlog, vbCrLf) - 1)) * factor nlog = Right(nlog, Len(nlog) - InStr(nlog, vbCrLf)) Else nscore = Val(nlog) * factor nlog = "" End If       If Not Err.Number = 0 Then Debug.Print "error parsing line " & Str(i) i = i - 1 Err.Clear Else sheet.Cells(i, 1).value = ndate If i = 1 Then sheet.Cells(i, 2).value = nscore Else sheet.Cells(i, 2).value = nscore + sheet.Cells(i - 1, 2).value End If       End If        On Error GoTo 0 If Len(nlog) = lastlen Then MsgBox ("stuck on line " & Str(i)) End If   Wend
 * 1) If UseExcel Then

If i > 1 Then With exceldoc.Charts.Add .ChartType = Excel.xlXYScatter .SetSourceData Source:=sheet.Range("A1:B" & Trim(Str(i))) .Name = ylabel .Axes(xlValue).HasTitle = True .Axes(xlValue).AxisTitle.Text = ylabel .Axes(xlCategory).HasTitle = True .Axes(xlCategory).AxisTitle.Text = "Date" .Axes(xlCategory).TickLabels.NumberFormat = "MMM-yyyy" .Axes(xlValue).MinimumScale = 0 With .SeriesCollection(1).Trendlines.Add .DisplayEquation = True End With .Legend.Delete End With End If   'sheet.Visible = False Set sheet = Nothing Set exceldoc = Nothing Set Excelapp = Nothing End Sub Public Sub ClearClipboard
 * 1) End If

Dim Ret Ret = OpenClipboard(0&) If Ret <> 0 Then Ret = EmptyClipboard CloseClipboard End Sub