Добрый день Уважаемые!
Есть 2 скрипта для outlook 2016.
1-й скрипт работает в автомате и создает папку для отправителя и перемещает письмо в созданную или существующую папку. Тут все отлично пока не приходит письмо от почты exchange. И создается папка вида /O=домен/OU=EXCHANGE и тд.
2-й скрипт по нажатию на письмо показывает адрес отправителя. И он корректно отображает почту от сервера exchange.
Что надо добавить и как из 2-го скрипта в 1-й. Не силен в программировании. Помогите пожалуйста)
1-й скрипт:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
' set object reference to default Inbox
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim SenderEmailAddress As String
' don't do anything for non-Mailitems
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
' move received email to target folder based on sender name
SenderEmailAddress = Msg.SenderEmailAddress
If CheckForFolder(SenderEmailAddress) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(SenderEmailAddress)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = _
objNS.GetDefaultFolder(olFolderInbox).Folders(SenderEmailAddress)
End If
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
2-й скрипт:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
' Outlook VBA Script that gets SMTP Address of the Currently Selected Email
' This script can convert an Exchange address into an SMTP address
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher, http://www.GregThatcher.com
Option Explicit
Public Sub GetSmtpAddressOfCurrentEmail()
Dim Session As Outlook.NameSpace
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim currentItem As Object
Dim currentMail As MailItem
Dim smtpAddress As String
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
'for all items do...
For Each currentItem In Selection
If currentItem.Class = olMail Then
Set currentMail = currentItem
smtpAddress = GetSmtpAddress(currentMail)
MsgBox "SMTP Address is " & smtpAddress
End If
Next
End Sub
Public Function GetSmtpAddress(mail As MailItem)
On Error GoTo On_Error
GetSmtpAddress = ""
Dim Report As String
Dim Session As Outlook.NameSpace
Set Session = Application.Session
If mail.SenderEmailType <> "EX" Then
GetSmtpAddress = mail.SenderEmailAddress
Else
Dim senderEntryID As String
Dim sender As AddressEntry
Dim PR_SENT_REPRESENTING_ENTRYID As String
PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
senderEntryID = mail.PropertyAccessor.BinaryToString( _
mail.PropertyAccessor.GetProperty( _
PR_SENT_REPRESENTING_ENTRYID))
Set sender = Session.GetAddressEntryFromID(senderEntryID)
If sender Is Nothing Then
Exit Function
End If
If sender.AddressEntryUserType = olExchangeUserAddressEntry Or _
sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Dim exchangeUser As exchangeUser
Set exchangeUser = sender.GetExchangeUser()
If exchangeUser Is Nothing Then
Exit Function
End If
GetSmtpAddress = exchangeUser.PrimarySmtpAddress
Exit Function
Else
Dim PR_SMTP_ADDRESS
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
GetSmtpAddress = sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End If
End If
Exiting:
Exit Function
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Function
