Private WithEvents InboxItems As Outlook.ItemsSub Application_Startup()Dim xNameSpace As Outlook.NameSpaceSet xNameSpace = Outlook.Application.SessionSet InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).ItemsEnd Sub Private Sub InboxItems_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMSGEnd IfExit SubEnd Sub
Private WithEvents InboxItems As Outlook.Items....Set OutboxItems = xNameSpace.GetDefaultFolder(olFolderOutbox).ItemsPrivate Sub OutboxItems_ItemAdd(ByVal objItem As Object)
Private WithEvents OutboxItems As Outlook.ItemsSub Application_Startup()Dim xNameSpace As Outlook.NameSpaceSet xNameSpace = Outlook.Application.SessionSet OutboxItems = xNameSpace.GetDefaultFolder(olFolderSentMail).ItemsEnd Sub Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfExit SubEnd Sub
Private WithEvents OutboxItems As Outlook.ItemsPrivate WithEvents InboxItems As Outlook.ItemsSub Application_Startup()Dim xNameSpace As Outlook.NameSpaceSet xNameSpace = Outlook.Application.SessionSet OutboxItems = xNameSpace.GetDefaultFolder(olFolderSentMail).ItemsSet InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).ItemsEnd SubPrivate Sub OutboxItems_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfExit SubEnd SubPrivate Sub InboxItems_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfExit SubEnd Sub
Sub Application_Startup()Dim xNameSpace As Outlook.NameSpaceDim oIncomingOut As ObjectDim oIncomingIn As ObjectSet xNameSpace = Outlook.Application.SessionSet oIncomingOut = xNameSpace.GetDefaultFolder(5)Set oIncomingIn = xNameSpace.GetDefaultFolder(6)Set OutboxItems = oIncomingOut.ItemsSet InboxItems = oIncomingIn.ItemsEnd Sub
Private Sub Application_NewMail()On Error Resume Next'Get a reference to the first item in the inboxDim olObject As ObjectSet 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 anywayIf olObject Is Nothing Then Exit Sub'Exit the sub if it's not a mail item or appointment itemIf Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub'Set the path to your desktop folder heresFolder = "C:\Users\s1200134\Documents\MyEmails\"'Save the email to some destinationolObject.SaveAs sFolder & Format(Now(), "yyyy-mm-dd hh_NN_ss") & ".msg", olMsgSet olObject = NothingExit SubEnd Sub
Option ExplicitPrivate WithEvents inboxItems As Outlook.ItemsPrivate Sub Application_Startup() Dim outlookApp As Outlook.Application Dim objectNS As Outlook.NameSpace Set outlookApp = Outlook.Application Set objectNS = outlookApp.GetNamespace("MAPI") Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).ItemsEnd SubPrivate Sub inboxItems_ItemAdd(ByVal Item As Object)On Error GoTo ErrorHandlerDim Msg As Outlook.MailItemDim MessageInfoDim ResultIf TypeName(Item) = "MailItem" Then MessageInfo = "" & _ "Sender : " & Item.SenderEmailAddress & vbCrLf & _ "Sent : " & Item.SentOn & vbCrLf & _ "Received : " & Item.ReceivedTime & vbCrLf & _ "Subject : " & Item.Subject & vbCrLf & _ "Size : " & Item.Size & vbCrLf & _ "Message Body : " & vbCrLf & Item.Body Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")End IfExitNewItem: Exit SubErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ExitNewItemEnd Sub
Sub Items_DoSomthing(Item As MailItem) On Error GoTo ErrorHandler Dim Msg As Outlook.MailItem Dim MessageInfo Dim Result If TypeName(Item) = "MailItem" Then MessageInfo = "" & _ "Sender : " & Item.SenderEmailAddress & vbCrLf & _ "Sent : " & Item.SentOn & vbCrLf & _ "Received : " & Item.ReceivedTime & vbCrLf & _ "Subject : " & Item.Subject & vbCrLf & _ "Size : " & Item.Size & vbCrLf & _ "Message Body : " & vbCrLf & Item.Body Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received") End If ExitNewItem: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ExitNewItem End Sub
Private Sub Application_NewMail()Call Items_DoSomthingEnd SubSub Items_DoSomthing(Item As MailItem)On Error GoTo ErrorHandlerDim Msg As Outlook.MailItemDim MessageInfoDim ResultIf TypeName(Item) = "MailItem" Then MessageInfo = "" & _ "Sender : " & Item.SenderEmailAddress & vbCrLf & _ "Sent : " & Item.SentOn & vbCrLf & _ "Received : " & Item.ReceivedTime & vbCrLf & _ "Subject : " & Item.Subject & vbCrLf & _ "Size : " & Item.Size & vbCrLf & _ "Message Body : " & vbCrLf & Item.Body Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")End IfExitNewItem: Exit SubErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ExitNewItemEnd Sub
Private WithEvents OutboxItems As Outlook.ItemsPrivate WithEvents InboxItems As Outlook.ItemsPrivate WithEvents InboxItems2 As Outlook.ItemsSub Application_Startup()Dim xNameSpace As Outlook.NameSpaceDim oIncomingOut As ObjectDim oIncomingIn As ObjectDim oIncomingIn2 As ObjectSet xNameSpace = Outlook.Application.SessionSet oIncomingOut = xNameSpace.GetDefaultFolder(5)Set oIncomingIn = xNameSpace.GetDefaultFolder(6)Set oIncomingIn2 = xNameSpace.GetDefaultFolder(6).Folders("Руководитель")Set OutboxItems = oIncomingOut.ItemsSet InboxItems = oIncomingIn.ItemsSet InboxItems2 = oIncomingIn2.ItemsEnd SubPrivate Sub OutboxItems_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = "Исх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfFor j = 1 To xMailItem.Attachments.Count x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .FilenameNext j Dim s As String Dim ff'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение s = xFilePath & "\" & xFileName & ".msg" & vbTab _ & xMailItem.SentOn & vbTab _ & xMailItem.ReceivedTime & vbTab _ & xMailItem.Sender.Name & vbTab _ & xMailItem.To & vbTab _ & xMailItem.CC & vbTab _ & xMailItem.Subject & vbTab _ & Replace(x, "image001.png; image002.jpg; ", "") & vbTab _ & Replace(xMailItem.Body, Chr(13) + Chr(10), " ") ff = FreeFile 'Открываем текстовый файл 'если файла нет - он будет создан Open xFilePath & "\Архив.txt" For Append As #ff 'записываем значение строки в файл Print #ff, s Close #ff ' Закрываем файл Exit SubEnd SubPrivate Sub InboxItems_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = "Вх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfFor j = 1 To xMailItem.Attachments.Count x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .FilenameNext j Dim s As String Dim ff'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение s = xFilePath & "\" & xFileName & ".msg" & vbTab _ & xMailItem.SentOn & vbTab _ & xMailItem.ReceivedTime & vbTab _ & xMailItem.Sender.Name & vbTab _ & xMailItem.To & vbTab _ & xMailItem.CC & vbTab _ & xMailItem.Subject & vbTab _ & Replace(x, "image001.png; image002.jpg; ", "") & vbTab _ & Replace(xMailItem.Body, Chr(13) + Chr(10), " ") ff = FreeFile 'Открываем текстовый файл 'если файла нет - он будет создан Open xFilePath & "\Архив.txt" For Append As #ff 'записываем значение строки в файл Print #ff, s Close #ff ' Закрываем файл Exit SubEnd SubPrivate Sub InboxItems2_ItemAdd(ByVal objItem As Object)Dim FSODim xMailItem As Outlook.MailItemDim xFilePath As StringDim xRegExDim xFileName As StringOn Error Resume NextxFilePath = CreateObject("WScript.Shell").SpecialFolders(16)xFilePath = xFilePath & "\MyEmails"Set FSO = CreateObject("Scripting.FileSystemObject")If FSO.FolderExists(xFilePath) = False ThenFSO.CreateFolder (xFilePath)End IfSet xRegEx = CreateObject("vbscript.regexp")xRegEx.Global = TruexRegEx.IgnoreCase = FalsexRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"If objItem.Class = olMail ThenSet xMailItem = objItemxFileName = "Вх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileNamexMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfFor j = 1 To xMailItem.Attachments.Count x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .FilenameNext j Dim s As String Dim ff'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение s = xFilePath & "\" & xFileName & ".msg" & vbTab _ & xMailItem.SentOn & vbTab _ & xMailItem.ReceivedTime & vbTab _ & xMailItem.Sender.Name & vbTab _ & xMailItem.To & vbTab _ & xMailItem.CC & vbTab _ & xMailItem.Subject & vbTab _ & Replace(x, "image001.png; image002.jpg; ", "") & vbTab _ & Replace(xMailItem.Body, Chr(13) + Chr(10), " ") ff = FreeFile 'Открываем текстовый файл 'если файла нет - он будет создан Open xFilePath & "\Архив.txt" For Append As #ff 'записываем значение строки в файл Print #ff, s Close #ff ' Закрываем файл Exit SubEnd Sub