Nhờ anh chị giúp đỡ VBA : code auto save khi nhận mail mới

[nguyennpa]

Chào các anh chị
Mình có xin một đoạn code tự động lưu khi có mail mới nhờ các anh chị thêm giúp em phần :]sender , ngày , sub , receiver. Cám ơn


Private WithEvents InboxItems As Outlook.Items

Sub Application_Startup()

Dim xNameSpace As Outlook.NameSpace

Set xNameSpace = Outlook.Application.Session

Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items

End Sub


Private Sub InboxItems_ItemAdd(ByVal objItem As Object)

Dim FSO

Dim xMailItem As Outlook.MailItem

Dim xFilePath As String

Dim xRegEx

Dim xFileName As String

On Error Resume Next

xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)

xFilePath = xFilePath & "\MyEmails"

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(xFilePath) = False Then

FSO.CreateFolder (xFilePath)

End If

Set xRegEx = CreateObject("vbscript.regexp")

xRegEx.Global = True

xRegEx.IgnoreCase = False

xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"

If objItem.Class = olMail Then

Set xMailItem = objItem

xFileName = xRegEx.Replace(xMailItem.Subject, "")

xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMSG

End If

Exit Sub

End Sub