Outlook 2003 SP3
Here is my function:
Private Function GetOutlookData(strTicket As String) As String
' Look for first email in InBox with Ticket # in Subject
' Then extract 'to', 'cc' and 'body'
'------------------ problems --------------------
' When Outlook not open, opens and closes it ok.
' When Outlook open, opens a new window and leaves it open
'------------------------------------------------
On Error GoTo ER
Dim p As Integer, sw As Boolean
Dim objApp As Outlook.Application
Dim objMI As MailItem
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
On Error Resume Next
Set objApp = GetObject(, "Outlook.Application")
If Err.Number = 0 Then
MsgBox "Used existing Outlook application"
sw = False
Else
Set objApp = CreateObject("Outlook.Application")
MsgBox "Created Outlook application"
sw = True
End If
On Error GoTo ER
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
objFolder.Display
objFolder.Items.Sort "[ReceivedTime]", True 'Sort descending
For Each objMI In objFolder.Items
p = InStr(objMI.Subject, strTicket)
If p <> 0 Then
MsgBox objMI.SentOn & vbCrLf & objMI.ReceivedTime & vbCrLf & _
objMI.To & vbCrLf & objMI.CC & vbCrLf & objMI.BODY, ,
objMI.Subject
Exit For
End If
Next
If p = 0 Then
MsgBox "Ticket not found in Outlook Inbox", , "Ticket " & strTicket
End If
EX:
' Is leaving another instance of Outlook running (how close?)
If sw = True Then
objApp.Quit
MsgBox "Closed Outlook"
End If
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
Exit Function
ER:
Call ErrMsg(Err.Number, Err.Description, "GetOutlookData " & strTicket)
On Error Resume Next
Resume EX
End Function
-- Dorian
"Give someone a fish and they eat for a day; teach someone to fish and they
eat for a lifetime".
