Outlook VBA

[phan913]

This code is from a forum in here a while back. I am trying to have outlook automatically save the email into txt format or attachment into the harddrive. I was not able to get this to work for the default Inbox but I need it really to watch another folder and download as new emails come in. I was trying to have it check email folder I made "Phan" and download any new emails. Any help would be appreciated.


Thank you,




Private Sub Application_NewMail()

On Error GoTo Application_NewMail_Error

'Get a reference to the first item in the inbox
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()

'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.Subject, "test") > 0 Then


'Set the path to your desktop folder here
Const DesktopFolder = "C:\Users\Pnguyen\Desktop\phantest"

'Save the email to some destination
olObject.SaveAs DesktopFolder & olObject.Subject & ".txt", olTXT

'save out attachments
Dim olAttachment As Outlook.Attachment
For Each olAttachment In olObject.Attachments
olAttachment.SaveAsFile DesktopFolder & olAttachment.DisplayName
Next olAttachment





Else
End If

Exit Sub



Application_NewMail_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Application_NewMail of VBA Document ThisOutlookSession"

End Sub

[skatonni]

You are missing a path separator at the end of this path.


Const DesktopFolder = "C:\Users\Pnguyen\Desktop\phantest\"

To check the folder "Phan" use ItemAdd. http://www.outlookcode.com/article.aspx?id=62


Option Explicit

Private WithEvents olPhanItems As Items

Private Sub Application_Startup()
Dim objNS As Namespace
Set objNS = Application.GetNamespace("MAPI")
' instantiate objects declared WithEvents
Set olPhanItems = objNS.GetDefaultFolder(olFolderInbox).Folders("Phan").Items
Set objNS = Nothing
End Sub

Private Sub olPhanItems_ItemAdd(ByVal olObject As Object)

If Not TypeOf olObject Is Outlook.mailitem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

If InStr(olObject.subject, "test") > 0 Then

'Set the path to your desktop folder here
Const DesktopFolder = "C:\Users\Pnguyen\Desktop\phantest\"
'Save the email to some destination
olObject.SaveAs DesktopFolder & olObject.subject & ".txt", olTXT

'save out attachments
Dim olAttachment As Outlook.attachment
For Each olAttachment In olObject.Attachments
olAttachment.SaveAsFile DesktopFolder & olAttachment.DisplayName
Next olAttachment
End If

ProgramExit:
Set olObject = Nothing
Exit Sub

olPhanItems_ItemAdd_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure olPhanItems_ItemAdd of VBA Document ThisOutlookSession"
Resume ProgramExit

End Sub

[phan913]

Thanks for the quick reply. When I added path seperator the default folder work but when I tried the code you created for "Phan" folder it does not save the email. Is this because I have a rule that moves emails to the "Phan" folder from the Inbox?

Thanks again,

Phan

[westconn1]

Option Explicit

Private WithEvents olPhanItems As Items

Private Sub Application_Startup()
Dim objNS As Namespace
Set objNS = Application.GetNamespace("MAPI")
' instantiate objects declared WithEvents
Set olPhanItems = objNS.GetDefaultFolder(olFolderInbox).Folders("Phan").Items
Set objNS = Nothing
End Sub this part of the code requires outlook to be restarted, or the application_startup to be run manually

[phan913]

Thank you. It worked. My outlook at work has several mailboxes. I have my personal Inbox and a couple of group email Inbox. How can I get it to point to my other group inbox? Also is there a way to add date and time to the file name so that the file don't overwrite each other? Thanks again.

[skatonni]

Thank you. It worked. My outlook at work has several mailboxes. I have my personal Inbox and a couple of group email Inbox. How can I get it to point to my other group inbox? Also is there a way to add date and time to the file name so that the file don't overwrite each other? Thanks again.

If the question has been answered. You may mark "Solved".

In your new question you can describe your folder structure.

[phan913]

12235 here is something similar to mine so my question is how to get to second inbox also how to add date and time to file name so it does not overwrite? Do I need to start new thread for this question?

Thank you,


Phan

[westconn1]

olAttachment.SaveAsFile DesktopFolder & olAttachment.DisplayName
displayname might not be a valid filename as it may not include the file extension


to save with current date and time try like

myfile = split(olAttachment.fileName, ".")
olAttachment.SaveAsFile DesktopFolder & myfile(0) & format(now, "yyyymmdd hhnnss") & "." & myfile(1)change date format to suit, but do not use / character etc


to try getting the second inbox

Set root = GetNamespace("mapi").GetDefaultFolder(olFolderInbox).Parent.Parent
For Each f In root.Folders
Debug.Print f.Name
Next
from the list printed in the immediate window, note the name of the desired folder and insert into next line

set myfolder = GetNamespace("mapi").GetDefaultFolder(olFolderInbox).Parent.Parent.folders("nameofFolder") then substitute myfolder in the other code

not knowing the names of your folders, i try finding the top level folder, above each mailbox, from the default inbox, no promise this will work

[phan913]

I was able to add date and time to filename but was unable to change to the other mailbox. I can't seem to reference the other mailbox. Appreciate the help with adding date on filename.

[gmayor]

If you want to save the messages as they arrive, then the folder they are to arrive to shouldn't matter. That only becomes an issue if you want to process messages that have already arrived. The following script, when run from a rule to identify the messages to be processed will save the message as text and the attachments with their original filenames (plus the date and time) in the Windows folder ("C:\Users\Pnguyen\Desktop\phantest\") indicated. That folder must exist as I haven't included a check for it.

I have included a test macro (Test1) to enable you to test the process with a selected message. Put all the functions in a new ordinary module and run the 'script'
SaveMessagesAndAttachments
from the rule. The messages selected by the rule will be processed as they arrive. The process is fast so it will not noticeably interrupt mail delivery.


Option Explicit
Sub SaveMessagesAndAttachments(olItem As Outlook.MailItem)
Dim olAtt As Attachment
Dim strFilename As String
Const fPath As String = "C:\Users\Pnguyen\Desktop\phantest\"
SaveMessage olItem, fPath
If olItem.Attachments.Count > 0 Then
For Each olAtt In olItem.Attachments
strFilename = fPath & Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM - ") & _
olAtt.Filename
olAtt.SaveAsFile strFilename
Next olAtt
End If
End Sub

Private Sub SaveMessage(olItem As MailItem, strPath As String)
Dim fName As String

fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
fName = Replace(fName, Chr(58) & Chr(41), "")
fName = Replace(fName, Chr(58) & Chr(40), "")
fName = Replace(fName, Chr(34), "-")
fName = Replace(fName, Chr(42), "-")
fName = Replace(fName, Chr(47), "-")
fName = Replace(fName, Chr(58), "-")
fName = Replace(fName, Chr(60), "-")
fName = Replace(fName, Chr(62), "-")
fName = Replace(fName, Chr(63), "-")
fName = Replace(fName, Chr(124), "-")
SaveUnique olItem, strPath, fName
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFilename As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFilename)
Do While FileExists(strPath & strFilename & ".txt") = True
strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFilename & ".txt", olTXT
End Function

Sub Test1()
Dim olmsg As MailItem
On Error Resume Next
Set olmsg = ActiveExplorer.Selection.Item(1)
SaveMessagesAndAttachments olmsg
End Sub

[phan913]

Thank you everyone for your help. I learned a lot from this. Gmayor, the code you provided is exactly what I was looking for. I was finally able to get it to work after modifying the code. I will probably remove the date and time stamp since you add a code that changes the filename so they don't overwrite. Thanks again everyone.