Manuel Jr
11-23-2009, 04:59 AM
I may this vba code to save a mgs in to the drive "c:\temp" and then move the msg to Folder "teste". The problem is this code only work on "ThisOutlookSession" as a makro and i need to put this as script to rule.
Could some help me !
Thank you
"Vba Code"
On Error GoTo Application_NewMail_Error
'Get a reference to the last item in the inbox
Dim olObject As Object
Dim data As Date
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetLast()
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("Teste")
'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub
'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub
If InStr(olObject.Body, "alterados com efeito ās 00:00 horas do dia ") > 0 Then
' Extract the date from the msg
data = Mid(olObject.Body, InStr(olObject.Body, "alterados com efeito ās 00:00 horas do dia ") + 43, 10)
'Set the path to your desktop folder here
Const DesktopFolder = "C:\temp\"
olObject.Subject = Replace(olObject.Subject, ":", "")
olObject.SaveAs DesktopFolder & data & ".html", olHTML
'delete the email
'olObject.Delete
'Put the mgs as read
olObject.UnRead = False
'Move the msg to the folder "teste"
olObject.Move myDestFolder
'Set olAttachment = Nothing
Set olObject = Nothing
On Error GoTo 0
Else
End If
Exit Sub
Application_NewMail_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Application_NewMail of VBA Document ThisOutlookSession"
Could some help me !
Thank you
"Vba Code"
On Error GoTo Application_NewMail_Error
'Get a reference to the last item in the inbox
Dim olObject As Object
Dim data As Date
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetLast()
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("Teste")
'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub
'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub
If InStr(olObject.Body, "alterados com efeito ās 00:00 horas do dia ") > 0 Then
' Extract the date from the msg
data = Mid(olObject.Body, InStr(olObject.Body, "alterados com efeito ās 00:00 horas do dia ") + 43, 10)
'Set the path to your desktop folder here
Const DesktopFolder = "C:\temp\"
olObject.Subject = Replace(olObject.Subject, ":", "")
olObject.SaveAs DesktopFolder & data & ".html", olHTML
'delete the email
'olObject.Delete
'Put the mgs as read
olObject.UnRead = False
'Move the msg to the folder "teste"
olObject.Move myDestFolder
'Set olAttachment = Nothing
Set olObject = Nothing
On Error GoTo 0
Else
End If
Exit Sub
Application_NewMail_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Application_NewMail of VBA Document ThisOutlookSession"