Adaytay
05-12-2009, 06:26 AM
Hi all,
First off I'm posting this in the Access area as this will form part of an Access function.
Bottom line of what I'm trying to achieve is to create an automatic "ticketting" system from within Access (a bit like Spiceworks), where an email that is sent to a shared mailbox will be picked up by Access, processed, and then Access will be used to manage the progress of the "job".
Part of this is for me to check the inbox of a shared mailbox periodically, and if any new mails are detected, the system will record the information contained, and then needs to move the MESSAGE in the shared inbox into a subfolder contained therein.
I have the code to check for messages and import the same into my database. I have other code to deal with the message once it's been imported. I just need help with actually moving the message from the inbox to the "Processed" folder.
This is what I've cobbled together:
Public Function CheckforNewDocConMail()
'Firstly, disable security warnings
lngAccessVer = Application.SysCmd(acSysCmdAccessVer) ' - eg 12 is 2007, 11 is 2003, etc
Dim SecurityManager As New AddInExpress.OutlookSecurityManager, myOLApp As Outlook.Application
Dim shdMbx As String, strErrMsg As String
' Get Outlook Application ... if it's already open
Set myOLApp = GetObject(, "Outlook.application")
If Err.Number > 0 Then
Err.Clear
Set myOLApp = GetObject(, "Outlook.application.10")
End If
If Err.Number > 0 Then
Err.Clear
Set myOLApp = GetObject(, "Outlook.application.11")
End If
If Err.Number > 0 Then
Err.Clear
Set myOLApp = GetObject(, "Outlook.application.12")
End If
' If an error occurred, then it's not open ... create from scratch.
If Err.Number Then
Err.Clear
Set myOLApp = CreateObject("Outlook.application")
'If another error has occurred, then Outlook couldn't be opened.
' Inform user and abort.
If Err.Number > 0 Then
strErrMsg = "Could not open Outlook. " & vbCrLf & vbCrLf & _
"Either Outlook is not installed correctly, " & vbCrLf & _
"or there is a problem with the installation. " & vbCrLf & vbCrLf & _
"Try opening Outlook before running this utility. " & vbCrLf & _
"If that also fails, contact the IT Support Team."
MsgBox strErrMsg, vbCritical, "Outlook Failed to Open"
Exit Function
End If
End If
'Switch Security Warnings off...
SecurityManager.ConnectTo myOLApp
SecurityManager.DisableOOMWarnings = True
'Security warnings are off. Do code
shdMbx = "Mailbox - Temp Milbox" 'Replace this with the actual name of the mailbox...
Dim myFolders As Outlook.Folders, myFolder As Outlook.Folder
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Set myFolders = objNS.Folders
For Each myFolder In myFolders
If myFolder Is Nothing Then
MsgBox "Cannot get first Folder object"
Set myFolders = Nothing
Exit Function
End If
If shdMbx = myFolder.Name Then
Dim entryID, storeID
Dim i As Integer, Item As Outlook.MailItem
For i = 1 To myFolder.Folders.Count
If myFolder.Folders(i).Name = "Inbox" Then
If myFolder.Folders(i).Items.Count > 0 Then
'there are messages in the folder to process.
For Each Item In myFolder.Folders(i).Items
'This is where the case rules will apply...
Dim strRequestType As String
If Item.SenderEmailAddress = "noreply@xxxxxx.co.uk" Then
'Email is automated from xxxxx [removed]
Select Case Item.Subject
Case "Feedback Report", "Password Request", "Un-Cleansed Request", "Document Unavailable"
strRequestType = "EDMS Administration"
Case "Request for Information"
strRequestType = "Information Request"
Case "Request for Controlled Issue"
strRequestType = "Controlled Document Issue"
Case Else
strRequestType = "EDMS Administration"
End Select
Else
'Not an EDMS Job
strRequestType = "Admin"
End If
'Add the new tasks to the database
Dim strBody As String, strSubject As String, strSender As String, strRecipient As String
'lngReqType = tLookup("Item", "tblRequestType", "RequestType='" & strRequestType & "'")
With Item
If .SenderEmailType = "EX" Then
strSender = .SenderName 'It's internal, so get the sender's name, rather than the email address
Else
strSender = .SenderEmailAddress 'It's external, so use the address
End If
strBody = Replace(.Body, "'", "")
strSubject = .Subject
strRecipient = .To
Dim bnHasAttachments As Boolean
If .Attachments.Count >= 1 Then
bnHasAttachments = True
Else
bnHasAttachments = False
End If
End With
'Got the information. Need to record in database
Dim strSQL As String
strSQL = "INSERT INTO tblEmailMessages (Recipient, Sender, Subject, Body, Sent, RequestType, HasAttachments) VALUES ('" & strRecipient _
& "', '" & strSender & "', '" & strSubject & "', '" & strBody & "', #" & Now() & "#, '" & strRequestType & "', " & bnHasAttachments & ");"
CurrentDb.Execute strSQL
'Item processed - set the attributes and move to the correct folder
With Item
.Save
.UnRead = False
'It's this bit I'm not sure of...
.Move Application.GetNamespace("mapi").Folders("Pending")
End With
Next Item
End If
End If
Next
Exit Function
End If
Next
' Turn Outlook Warnings back on...
SecurityManager.DisableOOMWarnings = False
End Function
Any help would be appreciated - I understand how to move the message but all the examples I've seen ONLY do this and don't work on shared mailboxes!
Thanks in advance,
Adam
First off I'm posting this in the Access area as this will form part of an Access function.
Bottom line of what I'm trying to achieve is to create an automatic "ticketting" system from within Access (a bit like Spiceworks), where an email that is sent to a shared mailbox will be picked up by Access, processed, and then Access will be used to manage the progress of the "job".
Part of this is for me to check the inbox of a shared mailbox periodically, and if any new mails are detected, the system will record the information contained, and then needs to move the MESSAGE in the shared inbox into a subfolder contained therein.
I have the code to check for messages and import the same into my database. I have other code to deal with the message once it's been imported. I just need help with actually moving the message from the inbox to the "Processed" folder.
This is what I've cobbled together:
Public Function CheckforNewDocConMail()
'Firstly, disable security warnings
lngAccessVer = Application.SysCmd(acSysCmdAccessVer) ' - eg 12 is 2007, 11 is 2003, etc
Dim SecurityManager As New AddInExpress.OutlookSecurityManager, myOLApp As Outlook.Application
Dim shdMbx As String, strErrMsg As String
' Get Outlook Application ... if it's already open
Set myOLApp = GetObject(, "Outlook.application")
If Err.Number > 0 Then
Err.Clear
Set myOLApp = GetObject(, "Outlook.application.10")
End If
If Err.Number > 0 Then
Err.Clear
Set myOLApp = GetObject(, "Outlook.application.11")
End If
If Err.Number > 0 Then
Err.Clear
Set myOLApp = GetObject(, "Outlook.application.12")
End If
' If an error occurred, then it's not open ... create from scratch.
If Err.Number Then
Err.Clear
Set myOLApp = CreateObject("Outlook.application")
'If another error has occurred, then Outlook couldn't be opened.
' Inform user and abort.
If Err.Number > 0 Then
strErrMsg = "Could not open Outlook. " & vbCrLf & vbCrLf & _
"Either Outlook is not installed correctly, " & vbCrLf & _
"or there is a problem with the installation. " & vbCrLf & vbCrLf & _
"Try opening Outlook before running this utility. " & vbCrLf & _
"If that also fails, contact the IT Support Team."
MsgBox strErrMsg, vbCritical, "Outlook Failed to Open"
Exit Function
End If
End If
'Switch Security Warnings off...
SecurityManager.ConnectTo myOLApp
SecurityManager.DisableOOMWarnings = True
'Security warnings are off. Do code
shdMbx = "Mailbox - Temp Milbox" 'Replace this with the actual name of the mailbox...
Dim myFolders As Outlook.Folders, myFolder As Outlook.Folder
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Set myFolders = objNS.Folders
For Each myFolder In myFolders
If myFolder Is Nothing Then
MsgBox "Cannot get first Folder object"
Set myFolders = Nothing
Exit Function
End If
If shdMbx = myFolder.Name Then
Dim entryID, storeID
Dim i As Integer, Item As Outlook.MailItem
For i = 1 To myFolder.Folders.Count
If myFolder.Folders(i).Name = "Inbox" Then
If myFolder.Folders(i).Items.Count > 0 Then
'there are messages in the folder to process.
For Each Item In myFolder.Folders(i).Items
'This is where the case rules will apply...
Dim strRequestType As String
If Item.SenderEmailAddress = "noreply@xxxxxx.co.uk" Then
'Email is automated from xxxxx [removed]
Select Case Item.Subject
Case "Feedback Report", "Password Request", "Un-Cleansed Request", "Document Unavailable"
strRequestType = "EDMS Administration"
Case "Request for Information"
strRequestType = "Information Request"
Case "Request for Controlled Issue"
strRequestType = "Controlled Document Issue"
Case Else
strRequestType = "EDMS Administration"
End Select
Else
'Not an EDMS Job
strRequestType = "Admin"
End If
'Add the new tasks to the database
Dim strBody As String, strSubject As String, strSender As String, strRecipient As String
'lngReqType = tLookup("Item", "tblRequestType", "RequestType='" & strRequestType & "'")
With Item
If .SenderEmailType = "EX" Then
strSender = .SenderName 'It's internal, so get the sender's name, rather than the email address
Else
strSender = .SenderEmailAddress 'It's external, so use the address
End If
strBody = Replace(.Body, "'", "")
strSubject = .Subject
strRecipient = .To
Dim bnHasAttachments As Boolean
If .Attachments.Count >= 1 Then
bnHasAttachments = True
Else
bnHasAttachments = False
End If
End With
'Got the information. Need to record in database
Dim strSQL As String
strSQL = "INSERT INTO tblEmailMessages (Recipient, Sender, Subject, Body, Sent, RequestType, HasAttachments) VALUES ('" & strRecipient _
& "', '" & strSender & "', '" & strSubject & "', '" & strBody & "', #" & Now() & "#, '" & strRequestType & "', " & bnHasAttachments & ");"
CurrentDb.Execute strSQL
'Item processed - set the attributes and move to the correct folder
With Item
.Save
.UnRead = False
'It's this bit I'm not sure of...
.Move Application.GetNamespace("mapi").Folders("Pending")
End With
Next Item
End If
End If
Next
Exit Function
End If
Next
' Turn Outlook Warnings back on...
SecurityManager.DisableOOMWarnings = False
End Function
Any help would be appreciated - I understand how to move the message but all the examples I've seen ONLY do this and don't work on shared mailboxes!
Thanks in advance,
Adam