Outlook

I’ve had this script for many years but currently I don’t have a use for it so I’m getting rid of it but putting it here for future reference in case I need it again.

It’s got code to retrieve data from a database and convert it to a tab delimited string. There’s more code which then parses this into tasks. The upshot of this is that I’ve used it in the past to take data from the clipboard (having come from excel).

The code has been anonymised which will have introduced a bug or two but the gist of it is valid.

Dim sqlUserList As String
Dim strConn As String
Dim strOutlookFolder As String
Dim strExternalOwner As String

'Entry point for macro
Sub UpdateData()
    'set global variables here
    sqlUserList = "'mrBob', 'mrBill', 'mrTed'"
    strConn = "Provider=SQLOLEDB;Data Source=myserver;Initial Catalog=mydatabase;User ID=myuser;Password=mypass;"
    strOutlookFolder = "Mailbox - My, Name\Folder Name"
    strExternalOwner = "TheOwner"
    
    Dim strClip As String
    Dim Lines() As String
    
    strClip = GetDataFromExternal()
    Lines = Split(strClip, vbCrLf)

    CreateTasks Lines
    CompleteTasks Lines
End Sub

Function GetDataFromExternal()
    'Define SQL
        strSQL = "SELECT data_1, data_2, data_3 From MyTable WHERE Owner IN (" & sqlUserList & ") ORDER BY data_1, data_2"
    
    'Declare variables'
        Dim objMyConn As ADODB.Connection
        Dim objMyRecordset As ADODB.Recordset

        Set objMyConn = New ADODB.Connection
        Set objMyRecordset = New ADODB.Recordset

    'Open Connection'
        objMyConn.ConnectionString = strConn
        objMyConn.Open

    'Open Recordset'
        objMyRecordset.Open strSQL, objMyConn
        
    'Gather data
        strOutput = ""
        Do Until objMyRecordset.EOF
            For I = 0 To objMyRecordset.Fields.Count - 1
                If I > 0 Then
                    strOutput = strOutput + vbTab
                End If
                strOutput = strOutput + Replace(Replace(CStr(objMyRecordset.Fields(I)), vbCrLf, ""), vbTab, "")
            Next
            strOutput = strOutput + vbCrLf
            objMyRecordset.MoveNext
        Loop
        
    'Clean up
        objMyRecordset.Close
        objMyConn.Close
        Set objMyConn = Nothing
        Set objMyRecordset = Nothing
    
    'Return data
        GetDataFromExternal = strOutput
End Function

Sub CreateTasks(SRLines() As String)
    Dim sr As String
    Dim SRCells() As String
    Dim objTask As Outlook.TaskItem
    Dim targetDate As Date
    Dim targetY As Integer
    Dim targetM As Integer
    Dim targetD As Integer
    
    For I = 0 To UBound(SRLines) - 1
        SRCells = Split(SRLines(I), vbTab)
        
        'search for existing task
        Set objTask = FindTask(SRCells(2), SRCells(0) & " - " & SRCells(5))
        If (objTask Is Nothing) Then
            'not found - raise it as new
            If (SRCells(8) <> "01/01/1753") Then
                targetY = Mid(SRCells(8), 7, 4)
                targetM = Mid(SRCells(8), 4, 2)
                targetD = Mid(SRCells(8), 1, 2)
                targetDate = DateSerial(targetY, targetM, targetD)
            Else
                targetDate = DateSerial(0, 0, 0)
            End If
            CreateTask SRCells(2), SRCells(0) & " - " & SRCells(5), SRCells(4) & vbCrLf & SRCells(7) & vbCrLf & SRCells(6), targetDate
        End If
    Next
End Sub

Sub CreateTask(strOwner As String, strSubject As String, strDescription As String, dtDue As Date)
    Dim olTask As Outlook.TaskItem
    Dim olApp As Outlook.Application
    Dim folder As MAPIFolder
    
    'create task in custom named task folder
    Set folder = GetFolder(strOutlookFolder)
    Set olTask = folder.Items.Add(olTaskItem)
    
    'using a custom property to track who the task is assigned to
    Set objProperty = olTask.UserProperties.Add(strExternalOwner, olText)
    If TypeName(objProperty) <> "Nothing" Then
        Select Case strOwner
            Case "MrBob"
                objProperty.Value = "Bob"
            Case "MrBill"
                objProperty.Value = "Bill"
            Case "MrTed"
                objProperty.Value = "Ted"
            Case Default
                objProperty.Value = strOwner
        End Select
    End If
    
    olTask.Body = strDescription
    olTask.Subject = strSubject
    olTask.Categories = "MyCategory"
    If (dtDue <> DateSerial(0, 0, 0)) Then
        olTask.DueDate = dtDue
    End If
    olTask.Save
    
End Sub

Sub CompleteTasks(SRLines() As String)
    Dim objFolder As Outlook.MAPIFolder
    
    Set objFolder = GetFolder(strOutlookFolder)
    CompleteFolderTasks SRLines, objFolder
End Sub

Sub CompleteFolderTasks(SRLines() As String, objFolder As Outlook.MAPIFolder)
    Dim objTasks As Outlook.Items
    Dim objTask As Outlook.TaskItem
    Dim objCategory As Outlook.Category
    Dim SRCells() As String
    Dim taskIsValid As Boolean

    Set objTasks = objFolder.Items
    For Each objTask In objTasks
        'first filter for INC
        If Left(objTask.Subject, 3) = "INC" Then
            'then double check category
            If (InStr(objTask.Categories, "Category") > 0) Then
                'now we have one we need to check if it's in the list of SRLines
                taskIsValid = False
                For I = 0 To UBound(SRLines) - 1
                    SRCells = Split(SRLines(I), vbTab)
                    If (objTask.Subject = SRCells(0) & " - " & SRCells(5)) Then
                        taskIsValid = True
                        Exit For
                    End If
                Next
                
                'found a missing one
                If (taskIsValid = False) Then
                    objTask.Categories = "Category Complete"
                    objTask.Save
                End If
            End If
        End If
    Next
End Sub


'Utility functions
Function FindTask(strOwner As String, strSubject As String)
    Dim objFolder As Outlook.MAPIFolder
    Dim objTasks As Outlook.Items
    Dim objTask As Outlook.TaskItem
    Dim strFind As String
    
    Set objFolder = GetFolder(strOutlookFolder)
    Set objTasks = objFolder.Items
    
    
    'escape special characters
    strSubject = Replace(strSubject, "'", "''")
    strSubject = Replace(strSubject, """", """""")
    
    strFind = "[Subject] = '" & strSubject & "'"
    Set objTask = objTasks.Find(strFind)
    Set FindTask = objTask
End Function


Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"

  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

Dim sqlUserList As String

Dim strConn As String

Dim strOutlookFolder As String

Dim strExternalOwner As String

'Entry point for macro

Sub UpdateData()

'set global variables here

sqlUserList = "'mrBob', 'mrBill', 'mrTed'"

strConn = "Provider=SQLOLEDB;Data Source=myserver;Initial Catalog=mydatabase;User ID=myuser;Password=mypass;"

strOutlookFolder = "Mailbox - My, Name\Folder Name"

strExternalOwner = "TheOwner"

Dim strClip As String

Dim Lines() As String

strClip = GetDataFromExternal()

Lines = Split(strClip, vbCrLf)

CreateTasks Lines

CompleteTasks Lines

End Sub

Function GetDataFromExternal()

'Define SQL

strSQL = "SELECT data_1, data_2, data_3 From MyTable WHERE Owner IN (" & sqlUserList & ") ORDER BY data_1, data_2"

'Declare variables'

Dim objMyConn As ADODB.Connection

Dim objMyRecordset As ADODB.Recordset

Set objMyConn = New ADODB.Connection

Set objMyRecordset = New ADODB.Recordset

'Open Connection'

objMyConn.ConnectionString = strConn

objMyConn.Open

'Open Recordset'

objMyRecordset.Open strSQL, objMyConn

'Gather data

strOutput = ""

Do Until objMyRecordset.EOF

For I = 0 To objMyRecordset.Fields.Count - 1

If I > 0 Then

strOutput = strOutput + vbTab

End If

strOutput = strOutput + Replace(Replace(CStr(objMyRecordset.Fields(I)), vbCrLf, ""), vbTab, "")

strOutput = strOutput + vbCrLf

objMyRecordset.MoveNext

Loop

'Clean up

objMyRecordset.Close

objMyConn.Close

Set objMyConn = Nothing

Set objMyRecordset = Nothing

'Return data

GetDataFromExternal = strOutput

End Function

Sub CreateTasks(SRLines() As String)

Dim sr As String

Dim SRCells() As String

Dim objTask As Outlook.TaskItem

Dim targetDate As Date

Dim targetY As Integer

Dim targetM As Integer

Dim targetD As Integer

For I = 0 To UBound(SRLines) - 1

SRCells = Split(SRLines(I), vbTab)

'search for existing task

Set objTask = FindTask(SRCells(2), SRCells(0) & " - " & SRCells(5))

If (objTask Is Nothing) Then

'not found - raise it as new

If (SRCells(8) <> "01/01/1753") Then

targetY = Mid(SRCells(8), 7, 4)

targetM = Mid(SRCells(8), 4, 2)

targetD = Mid(SRCells(8), 1, 2)

targetDate = DateSerial(targetY, targetM, targetD)

Else

targetDate = DateSerial(0, 0, 0)

End If

CreateTask SRCells(2), SRCells(0) & " - " & SRCells(5), SRCells(4) & vbCrLf & SRCells(7) & vbCrLf & SRCells(6), targetDate

End If

End Sub

Sub CreateTask(strOwner As String, strSubject As String, strDescription As String, dtDue As Date)

Dim olTask As Outlook.TaskItem

Dim olApp As Outlook.Application

Dim folder As MAPIFolder

'create task in custom named task folder

Set folder = GetFolder(strOutlookFolder)

Set olTask = folder.Items.Add(olTaskItem)

'using a custom property to track who the task is assigned to

Set objProperty = olTask.UserProperties.Add(strExternalOwner, olText)

If TypeName(objProperty) <> "Nothing" Then

Select Case strOwner

Case "MrBob"

objProperty.Value = "Bob"

Case "MrBill"

objProperty.Value = "Bill"

Case "MrTed"

objProperty.Value = "Ted"

Case Default

objProperty.Value = strOwner

End Select

End If

olTask.Body = strDescription

olTask.Subject = strSubject

olTask.Categories = "MyCategory"

If (dtDue <> DateSerial(0, 0, 0)) Then

olTask.DueDate = dtDue

End If

olTask.Save

End Sub

Sub CompleteTasks(SRLines() As String)

Dim objFolder As Outlook.MAPIFolder

Set objFolder = GetFolder(strOutlookFolder)

CompleteFolderTasks SRLines, objFolder

End Sub

Sub CompleteFolderTasks(SRLines() As String, objFolder As Outlook.MAPIFolder)

Dim objTasks As Outlook.Items

Dim objTask As Outlook.TaskItem

Dim objCategory As Outlook.Category

Dim SRCells() As String

Dim taskIsValid As Boolean

Set objTasks = objFolder.Items

For Each objTask In objTasks

'first filter for INC

If Left(objTask.Subject, 3) = "INC" Then

'then double check category

If (InStr(objTask.Categories, "Category") > 0) Then

'now we have one we need to check if it's in the list of SRLines

taskIsValid = False

For I = 0 To UBound(SRLines) - 1

SRCells = Split(SRLines(I), vbTab)

If (objTask.Subject = SRCells(0) & " - " & SRCells(5)) Then

taskIsValid = True

Exit For

End If

'found a missing one

If (taskIsValid = False) Then

objTask.Categories = "Category Complete"

objTask.Save

End If

End Sub

'Utility functions

Function FindTask(strOwner As String, strSubject As String)

Dim objFolder As Outlook.MAPIFolder

Dim objTasks As Outlook.Items

Dim objTask As Outlook.TaskItem

Dim strFind As String

Set objFolder = GetFolder(strOutlookFolder)

Set objTasks = objFolder.Items

'escape special characters

strSubject = Replace(strSubject, "'", "''")

strSubject = Replace(strSubject, """", """""")

strFind = "[Subject] = '" & strSubject & "'"

Set objTask = objTasks.Find(strFind)

Set FindTask = objTask

End Function

Public Function GetFolder(strFolderPath As String) As MAPIFolder

' strFolderPath needs to be something like

' "Public Folders\All Public Folders\Company\Sales" or

' "Personal Folders\Inbox\My Folder"

Dim objApp As Outlook.Application

Dim objNS As Outlook.NameSpace

Dim colFolders As Outlook.Folders

Dim objFolder As Outlook.MAPIFolder

Dim arrFolders() As String

Dim I As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")

arrFolders() = Split(strFolderPath, "\")

Set objApp = Application

Set objNS = objApp.GetNamespace("MAPI")

Set objFolder = objNS.Folders.Item(arrFolders(0))

If Not objFolder Is Nothing Then

For I = 1 To UBound(arrFolders)

Set colFolders = objFolder.Folders

Set objFolder = Nothing

Set objFolder = colFolders.Item(arrFolders(I))

If objFolder Is Nothing Then

Exit For

End If

Set GetFolder = objFolder

Set colFolders = Nothing

Set objNS = Nothing

Set objApp = Nothing

End Function

Blue Phone Box

A personal site of tech, games, rpg's, pi and stuff

Creating tasks in Outlook from an external data source