Code tweak for non-default mailbox

[Fred Blogs]

Hi there,

I am not an experienced coder in any way, but have pulled together from various code snippets around the internet a VBA macro which automatically saves incoming emails to the hard drive. This has been working well for over a year but I now need it to work on a non-default mailbox and can't work out how to change the code. Here is the key extract from the macro with the two lines I need to change highlighted with red text:-

Private Sub Application_Startup()

Dim Ns As Outlook.NameSpace

Set Ns = Application.GetNamespace("MAPI")

Set Items = Ns.GetDefaultFolder(olFolderInbox).Items

Dim objSent As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")

Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items

Set objNS = Nothing

End Sub

The red lines needs to refer to a specific mailbox (say "abc at xyz dot com" *) and the "Inbox" and "Sent Items" folders contained therein. I have spent hours, days even, scouring the web and found loads of "non default folder" VBA information in forums etc, however, if I read them correctly (and I repeat I am not an experienced coder) they seem to suggest I need 30-40 lines of code to achieve what I seek and this seems unlikely.

Is there a way to replace the "GetDefaultFolder" bits in the two lines above with the specific mailbox name (eg "abc at xyz dot com" *) and the "olFolderxxxxxxx" bits with their specific folder names (ie "Inbox" and "Sent Items")?

Thanks for reading and for any advice you can provide. Apologies is this is covered by an existing post - I did look first though.

* NB Forum won't let me post this as correctly formatted email address, but I'm sure you understand what I mean.

Regards
Fred

PS I have another (very minor) tweak I am looking for assistance with. Is there a (simple) way of limiting the length of the string to the first 20 characters returned by this line of code?

sName = oMail.Subject

Some emails contain VERY long subject lines and this can cause a filename length error when saving.

[gmayor]

See if

Dim oAccount As Account
Dim oItems As Items
Dim oSentItems As Items
Dim NS As Outlook.NameSpace
    Set NS = Application.GetNamespace("MAPI")
    For Each oAccount In NS.Accounts
        If oAccount.DisplayName = "abc@def.com" Then
            Set oItems = oAccount.DeliveryStore.GetRootFolder.folders("Inbox").Items
            Set oSentItems = oAccount.DeliveryStore.GetRootFolder.folders("Sent Items").Items
            Exit For
        End If
    Next oAccount

works for you

sName = Left(oMail.Subject,20)
sName = CleanFileName(strName)

will restrict to 20 characters and check, using the following code, for illegal filename characters.

Private Function CleanFileName(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
    'Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    'Remove any illegal filename characters
    CleanFileName = strFileName
    For lng_Index = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
    Next lng_Index
lbl_Exit:
    Exit Function
End Function

[Fred Blogs]

Dear gmayor,

Many thanks for taking the time to read/respond. The 20x character bit works perfectly (and so simply too) and I already had an illegal character routine so have stuck with that as I know it works for me. Unfortunately the main code bit doesn't work I'm afraid. I note you used "oSentItems" rather than "objSentItems" and similar, but don't think this is the issue as I've tried all with/without - I've also set security/trust to minimum to test. I've pasted the whole thing below (----------- have been added to this list to represent the code chunk segments and I've removed the email/path info for security + unfortunately it's stripped the indents, sorry) and was wondering whether you can see where the problem is. Once again I thank you in advance for any assistance you're able to offer.

Regards
Freed

Private WithEvents Items As Outlook.Items
Private WithEvents objSentItems As Items
----------------
Private Sub Application_Startup()
Dim oAccount As Account
Dim oItems As Items
Dim oSentItems As Items
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
For Each oAccount In NS.Accounts
If oAccount.DisplayName = "EMAILACCOUNTHERE" Then
Set oItems = oAccount.DeliveryStore.GetRootFolder.Folders("Inbox").Items
Set oSentItems = oAccount.DeliveryStore.GetRootFolder.Folders("Sent Items").Items
Exit For
End If
Next objAccount
End Sub
-------------
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveMailAsFile Item
End If
End Sub
-------------
Private Sub SaveMailAsFile(oMail As Outlook.MailItem)
Dim dtDate As Date
Dim sName As String
Dim sSender As String

sName = Left(oMail.Subject, 20)
sSender = oMail.SenderEmailAddress
ReplaceCharsForFileName sName, "_"

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & "" & Format(dtDate, "mm", vbUseSystemDayOfWeek, _
vbUseSystem) & "" & Format(dtDate, "dd hhnn ", _
vbUseSystemDayOfWeek, vbUseSystem) & sSender & " " & sName & ".msg"

sPath = "MYPATHHERE"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End Sub
-------------
Private Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim dtDate As Date
Dim sName As String
Dim sPath As String

sName = Left(Item.Subject, 20)
ReplaceCharsForFileName sName, "_"

dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & "" & Format(dtDate, "mm", vbUseSystemDayOfWeek, _
vbUseSystem) & "" & Format(dtDate, "dd hhnn ", _
vbUseSystemDayOfWeek, vbUseSystem) & sName & ".msg"

sPath = "MYPATHHERE"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End Sub
-------------
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "!", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
sName = Replace(sName, Chr(42), sChr)
End Sub

[gmayor]

Without access to your system, I can only guess, however, the following macro should reveal the account names and their root folders, which you can substitute in the code.

Sub testaccounts()
Dim oAccount As Account
Dim NS As Outlook.NameSpace
Dim oFolder As Folder
    Set NS = Application.GetNamespace("MAPI")
    For Each oAccount In NS.Accounts
Debug.Print vbCr & "Account: " & oAccount.DisplayName
        For Each oFolder In oAccount.DeliveryStore.GetRootFolder.folders
Debug.Print oFolder.Name
        Next oFolder
    Next oAccount
End Sub