Outlinker.bas

From ActivityOwnerWiki
Revision as of 19:16, 25 August 2011 by Activityowner (Talk | contribs) (add "waiting for next week" outlook task generator)

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search
'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,
#Const usemm = True
#Const UseExcel = False  'if set true, you need to add excel x.0 object library reference -- this enables history graphing
'Language codes - set english=false if you customize

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 UseExcel Then
  If MsgBox("Do you want excel charts?", vbYesNo) = vbYes Then
    plothistory getnote(settings, "dailyprocessed"), "Daily Processed"
  End If
#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

    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
#If usemm Then
    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
#End If
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


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
#If usemm Then
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
#End If
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

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

#If UseExcel Then
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

    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
#End If
 
 
 Public Sub ClearClipboard()

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