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
