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 jx = Replace(x, "image001.png;", "")x = Replace(x, "image002.png;", "")x = Replace(x, "image003.png;", "")x = Replace(x, "image004.png;", "")x = Replace(x, "image005.png;", "")x = Replace(x, "image006.png;", "")x = Replace(x, "image007.png;", "")x = Replace(x, "image008.png;", "")x = Replace(x, "image009.png;", "")x = Replace(x, "image001.jpg;", "")x = Replace(x, "image002.jpg;", "")x = Replace(x, "image003.jpg;", "")x = Replace(x, "image004.jpg;", "")x = Replace(x, "image005.jpg;", "")x = Replace(x, "image006.jpg;", "")x = Replace(x, "image007.jpg;", "")x = Replace(x, "image008.jpg;", "")x = Replace(x, "image009.jpg;", "")x = Replace(x, "image001.jpeg;", "")x = Replace(x, "image002.jpeg;", "")x = Replace(x, "image003.jpeg;", "")x = Replace(x, "image004.jpeg;", "")x = Replace(x, "image005.jpeg;", "")x = Replace(x, "image006.jpeg;", "")x = Replace(x, "image007.jpeg;", "")x = Replace(x, "image008.jpeg;", "")x = Replace(x, "image009.jpeg;", "")x = Replace(x, "image001.gif;", "")x = Replace(x, "image002.gif;", "")x = Replace(x, "image003.gif;", "")x = Replace(x, "image004.gif;", "")x = Replace(x, "image005.gif;", "")x = Replace(x, "image006.gif;", "")x = Replace(x, "image007.gif;", "")x = Replace(x, "image008.gif;", "")x = Replace(x, "image009.gif;", "")x = Replace(x, " ", "")x = Replace(x, ";", "; ") 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 _ & x & 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 jx = Replace(x, "image001.png;", "")x = Replace(x, "image002.png;", "")x = Replace(x, "image003.png;", "")x = Replace(x, "image004.png;", "")x = Replace(x, "image005.png;", "")x = Replace(x, "image006.png;", "")x = Replace(x, "image007.png;", "")x = Replace(x, "image008.png;", "")x = Replace(x, "image009.png;", "")x = Replace(x, "image001.jpg;", "")x = Replace(x, "image002.jpg;", "")x = Replace(x, "image003.jpg;", "")x = Replace(x, "image004.jpg;", "")x = Replace(x, "image005.jpg;", "")x = Replace(x, "image006.jpg;", "")x = Replace(x, "image007.jpg;", "")x = Replace(x, "image008.jpg;", "")x = Replace(x, "image009.jpg;", "")x = Replace(x, "image001.jpeg;", "")x = Replace(x, "image002.jpeg;", "")x = Replace(x, "image003.jpeg;", "")x = Replace(x, "image004.jpeg;", "")x = Replace(x, "image005.jpeg;", "")x = Replace(x, "image006.jpeg;", "")x = Replace(x, "image007.jpeg;", "")x = Replace(x, "image008.jpeg;", "")x = Replace(x, "image009.jpeg;", "")x = Replace(x, "image001.gif;", "")x = Replace(x, "image002.gif;", "")x = Replace(x, "image003.gif;", "")x = Replace(x, "image004.gif;", "")x = Replace(x, "image005.gif;", "")x = Replace(x, "image006.gif;", "")x = Replace(x, "image007.gif;", "")x = Replace(x, "image008.gif;", "")x = Replace(x, "image009.gif;", "")x = Replace(x, " ", "")x = Replace(x, ";", "; ") 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 _ & x & 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 jx = Replace(x, "image001.png;", "")x = Replace(x, "image002.png;", "")x = Replace(x, "image003.png;", "")x = Replace(x, "image004.png;", "")x = Replace(x, "image005.png;", "")x = Replace(x, "image006.png;", "")x = Replace(x, "image007.png;", "")x = Replace(x, "image008.png;", "")x = Replace(x, "image009.png;", "")x = Replace(x, "image001.jpg;", "")x = Replace(x, "image002.jpg;", "")x = Replace(x, "image003.jpg;", "")x = Replace(x, "image004.jpg;", "")x = Replace(x, "image005.jpg;", "")x = Replace(x, "image006.jpg;", "")x = Replace(x, "image007.jpg;", "")x = Replace(x, "image008.jpg;", "")x = Replace(x, "image009.jpg;", "")x = Replace(x, "image001.jpeg;", "")x = Replace(x, "image002.jpeg;", "")x = Replace(x, "image003.jpeg;", "")x = Replace(x, "image004.jpeg;", "")x = Replace(x, "image005.jpeg;", "")x = Replace(x, "image006.jpeg;", "")x = Replace(x, "image007.jpeg;", "")x = Replace(x, "image008.jpeg;", "")x = Replace(x, "image009.jpeg;", "")x = Replace(x, "image001.gif;", "")x = Replace(x, "image002.gif;", "")x = Replace(x, "image003.gif;", "")x = Replace(x, "image004.gif;", "")x = Replace(x, "image005.gif;", "")x = Replace(x, "image006.gif;", "")x = Replace(x, "image007.gif;", "")x = Replace(x, "image008.gif;", "")x = Replace(x, "image009.gif;", "")x = Replace(x, " ", "")x = Replace(x, ";", "; ") 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 _ & x & 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
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 StringDim s 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, "") 'xFileNames = GetAtchName(xFilePath & "\" & xFileName & ".msg")xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfFor j = 1 To xMailItem.Attachments.Count x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .FilenameNext jx = Replace(x, "image001.png;", "")x = Replace(x, "image002.png;", "")x = Replace(x, "image003.png;", "")x = Replace(x, "image004.png;", "")x = Replace(x, "image005.png;", "")x = Replace(x, "image006.png;", "")x = Replace(x, "image007.png;", "")x = Replace(x, "image008.png;", "")x = Replace(x, "image009.png;", "")x = Replace(x, "image001.jpg;", "")x = Replace(x, "image002.jpg;", "")x = Replace(x, "image003.jpg;", "")x = Replace(x, "image004.jpg;", "")x = Replace(x, "image005.jpg;", "")x = Replace(x, "image006.jpg;", "")x = Replace(x, "image007.jpg;", "")x = Replace(x, "image008.jpg;", "")x = Replace(x, "image009.jpg;", "")x = Replace(x, "image001.jpeg;", "")x = Replace(x, "image002.jpeg;", "")x = Replace(x, "image003.jpeg;", "")x = Replace(x, "image004.jpeg;", "")x = Replace(x, "image005.jpeg;", "")x = Replace(x, "image006.jpeg;", "")x = Replace(x, "image007.jpeg;", "")x = Replace(x, "image008.jpeg;", "")x = Replace(x, "image009.jpeg;", "")x = Replace(x, "image001.gif;", "")x = Replace(x, "image002.gif;", "")x = Replace(x, "image003.gif;", "")x = Replace(x, "image004.gif;", "")x = Replace(x, "image005.gif;", "")x = Replace(x, "image006.gif;", "")x = Replace(x, "image007.gif;", "")x = Replace(x, "image008.gif;", "")x = Replace(x, "image009.gif;", "")x = Replace(x, " ", "")x = Replace(x, ";", "; ") Dim k As String Dim ff'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение k = xFilePath & "\" & xFileName & ".msg" & vbTab _ & xMailItem.SentOn & vbTab _ & xMailItem.ReceivedTime & vbTab _ & xMailItem.Sender.Name & vbTab _ & xMailItem.To & vbTab _ & xMailItem.CC & vbTab _ & xMailItem.Subject & vbTab _ & x & vbTab _ & Replace(xMailItem.Body, Chr(13) + Chr(10), " ") ff = FreeFile 'Открываем текстовый файл 'если файла нет - он будет создан Open xFilePath & "\Архив.txt" For Append As #ff 'записываем значение строки в файл Print #ff, k 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, "") 'xFileNames = GetAtchName(xFilePath & "\" & xFileName & ".msg")xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfFor j = 1 To xMailItem.Attachments.Count x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .FilenameNext jx = Replace(x, "image001.png;", "")x = Replace(x, "image002.png;", "")x = Replace(x, "image003.png;", "")x = Replace(x, "image004.png;", "")x = Replace(x, "image005.png;", "")x = Replace(x, "image006.png;", "")x = Replace(x, "image007.png;", "")x = Replace(x, "image008.png;", "")x = Replace(x, "image009.png;", "")x = Replace(x, "image001.jpg;", "")x = Replace(x, "image002.jpg;", "")x = Replace(x, "image003.jpg;", "")x = Replace(x, "image004.jpg;", "")x = Replace(x, "image005.jpg;", "")x = Replace(x, "image006.jpg;", "")x = Replace(x, "image007.jpg;", "")x = Replace(x, "image008.jpg;", "")x = Replace(x, "image009.jpg;", "")x = Replace(x, "image001.jpeg;", "")x = Replace(x, "image002.jpeg;", "")x = Replace(x, "image003.jpeg;", "")x = Replace(x, "image004.jpeg;", "")x = Replace(x, "image005.jpeg;", "")x = Replace(x, "image006.jpeg;", "")x = Replace(x, "image007.jpeg;", "")x = Replace(x, "image008.jpeg;", "")x = Replace(x, "image009.jpeg;", "")x = Replace(x, "image001.gif;", "")x = Replace(x, "image002.gif;", "")x = Replace(x, "image003.gif;", "")x = Replace(x, "image004.gif;", "")x = Replace(x, "image005.gif;", "")x = Replace(x, "image006.gif;", "")x = Replace(x, "image007.gif;", "")x = Replace(x, "image008.gif;", "")x = Replace(x, "image009.gif;", "")x = Replace(x, " ", "")x = Replace(x, ";", "; ") Dim k As String Dim ff'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение k = xFilePath & "\" & xFileName & ".msg" & vbTab _ & xMailItem.SentOn & vbTab _ & xMailItem.ReceivedTime & vbTab _ & xMailItem.Sender.Name & vbTab _ & xMailItem.To & vbTab _ & xMailItem.CC & vbTab _ & xMailItem.Subject & vbTab _ & x & vbTab _ & Replace(xMailItem.Body, Chr(13) + Chr(10), " ") ff = FreeFile 'Открываем текстовый файл 'если файла нет - он будет создан Open xFilePath & "\Архив.txt" For Append As #ff 'записываем значение строки в файл Print #ff, k 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, "") 'xFileNames = GetAtchName(xFilePath & "\" & xFileName & ".msg")xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsgEnd IfFor j = 1 To xMailItem.Attachments.Count x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .FilenameNext jx = Replace(x, "image001.png;", "")x = Replace(x, "image002.png;", "")x = Replace(x, "image003.png;", "")x = Replace(x, "image004.png;", "")x = Replace(x, "image005.png;", "")x = Replace(x, "image006.png;", "")x = Replace(x, "image007.png;", "")x = Replace(x, "image008.png;", "")x = Replace(x, "image009.png;", "")x = Replace(x, "image001.jpg;", "")x = Replace(x, "image002.jpg;", "")x = Replace(x, "image003.jpg;", "")x = Replace(x, "image004.jpg;", "")x = Replace(x, "image005.jpg;", "")x = Replace(x, "image006.jpg;", "")x = Replace(x, "image007.jpg;", "")x = Replace(x, "image008.jpg;", "")x = Replace(x, "image009.jpg;", "")x = Replace(x, "image001.jpeg;", "")x = Replace(x, "image002.jpeg;", "")x = Replace(x, "image003.jpeg;", "")x = Replace(x, "image004.jpeg;", "")x = Replace(x, "image005.jpeg;", "")x = Replace(x, "image006.jpeg;", "")x = Replace(x, "image007.jpeg;", "")x = Replace(x, "image008.jpeg;", "")x = Replace(x, "image009.jpeg;", "")x = Replace(x, "image001.gif;", "")x = Replace(x, "image002.gif;", "")x = Replace(x, "image003.gif;", "")x = Replace(x, "image004.gif;", "")x = Replace(x, "image005.gif;", "")x = Replace(x, "image006.gif;", "")x = Replace(x, "image007.gif;", "")x = Replace(x, "image008.gif;", "")x = Replace(x, "image009.gif;", "")x = Replace(x, " ", "")x = Replace(x, ";", "; ") Dim k As String Dim ff'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение k = xFilePath & "\" & xFileName & ".msg" & vbTab _ & xMailItem.SentOn & vbTab _ & xMailItem.ReceivedTime & vbTab _ & xMailItem.Sender.Name & vbTab _ & xMailItem.To & vbTab _ & xMailItem.CC & vbTab _ & xMailItem.Subject & vbTab _ & x & vbTab _ & Replace(xMailItem.Body, Chr(13) + Chr(10), " ") ff = FreeFile 'Открываем текстовый файл 'если файла нет - он будет создан Open xFilePath & "\Архив.txt" For Append As #ff 'записываем значение строки в файл Print #ff, k Close #ff ' Закрываем файл Exit SubEnd SubFunction GetAtchName(ByVal s As String) Dim s1 As String, s2 As String, sEx As String Dim lu As Long, lp As Long s1 = s lp = InStrRev(s, ".", -1, 1) If lp Then sEx = Mid(s, lp) s1 = Mid(s, 1, lp - 1) End If s2 = s lu = 0 Do While (Dir(s2, 16) <> "") lu = lu + 1 s2 = s1 & "(" & lu & ")" & sEx Loop GetAtchName = s2End Function