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