powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / VBA -> Outlook 2003 -> Получение SMTP-адреса с использованием CDO -> WARNING
3 сообщений из 3, страница 1 из 1
VBA -> Outlook 2003 -> Получение SMTP-адреса с использованием CDO -> WARNING
    #35157371
Наваял такую функцию:

Код: plaintext
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.
Private Sub TestCDO()
  Private Const PR_SMTP_ADDRESS = &H39FE001E
  Private Const PR_EMS_AB_PROXY_ADDRESSES = &H800F101E

  Dim olMail As Object
  Dim objSession As MAPI.Session
  Dim objMessage As MAPI.Message
  Dim objField As MAPI.Field
  Dim FlagVal As String
  Dim FVal As Variant
  
  Set objSession = CreateObject("MAPI.Session")
  objSession.Logon "", "", False, False,  0 
  
  For Each olMail In Application.ActiveExplorer.Selection
    If LCase(TypeName(olMail)) = "mailitem" Then
      Set objMessage = objSession.GetMessage(olMail.EntryID)
      Debug.Print (objMessage.Subject)

      FlagVal = ""
      If LCase(objMessage.Sender.Type) = "smtp" Then
        FlagVal = objMessage.Sender.Address
      Else
        For Each objField In objMessage.Sender.Fields
          If (objField.ID = PR_SMTP_ADDRESS) And (FlagVal = "") Then FlagVal = objField.Value
          If (objField.ID = PR_EMS_AB_PROXY_ADDRESSES) And (FlagVal = "") Then
            For Each FVal In objField.Value
              If InStr( 1 , LCase(FVal), "smtp:") >  0  Then FlagVal = Right(FVal, Len(FVal) - InStr( 1 , LCase(FVal), "smtp:") -  4 )
            Next
          End If
        Next
      End If
      Debug.Print (FlagVal)
    End If
  Next
End Sub

Всё замечательно работает, но при обращении к объекту Sender возникает сообщение: "Программа пытается получить доступ к адресам электронной почты, хранящимся в Outlook. Разрешить это действие?". И такое повторяется каждый раз при запуске функции. Как предотвратить появление этого сообщения? Проект VBA подписан цифровой подписью, все требования безопасности соблюдены.. Что где подкрутить/прижечь?
...
Рейтинг: 0 / 0
VBA -> Outlook 2003 -> Получение SMTP-адреса с использованием CDO -> WARNING
    #35159025
Фотография Игорь Горбонос
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
> Автор: Юрий Буравцов
> Наваял такую функцию:
> Private Sub TestCDO()
....
> End Sub
> Всё замечательно работает, но при обращении к объекту Sender
> возникает сообщение: "Программа пытается получить доступ к адресам
> электронной почты, хранящимся в Outlook. Разрешить это действие?". И такое
> повторяется каждый раз при запуске функции. Как предотвратить появление
> этого сообщения? Проект VBA подписан цифровой подписью, все требования
> безопасности соблюдены.. Что где подкрутить/прижечь?

Может антивирус проявляет заботу, а может птица влияет "Предупреждать, если
приложения пытаются отправить почту от моего имени"? Кто его знает :(

Posted via ActualForum NNTP Server 1.4
...
Рейтинг: 0 / 0
VBA -> Outlook 2003 -> Получение SMTP-адреса с использованием CDO -> WARNING
    #35159621
Проверялось на двух ЭВМ, на одной нортон антивирус 2005, на другой касперыч... Да и проблема оказалась известной , однако победить её мне так и не удалось... Впрочем, там ещё упоминалось про Outlook Redemption, вот его-то я и заюзал:

Код: plaintext
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.
Private Sub TestRDO()
  Const PR_SMTP_ADDRESS = &H39FE001E
  Const PR_EMS_AB_PROXY_ADDRESSES = &H800F101E
  Dim olMail As Object
  Dim objSession As RDOSession
  Dim objMessage As RDOMail
  Dim FlagVal As String
  
  Set objSession = CreateObject("Redemption.RDOSession")
  objSession.MAPIOBJECT = Application.Session.MAPIOBJECT

  For Each olMail In Application.ActiveExplorer.Selection
    If LCase(TypeName(olMail)) = "mailitem" Then
      Set objMessage = objSession.GetMessageFromID(olMail.EntryID)
      Debug.Print (objMessage.Subject)

      FlagVal = ""
      If LCase(objMessage.Sender.Type) = "smtp" Then
        FlagVal = objMessage.Sender.Address
      Else
        FlagVal = objMessage.Sender.Fields(PR_SMTP_ADDRESS)
        If FlagVal = "" Then FlagVal = objMessage.Sender.Fields(PR_EMS_AB_PROXY_ADDRESSES)
      End If
      Debug.Print (FlagVal)
    End If
  Next
End Sub
...
Рейтинг: 0 / 0
3 сообщений из 3, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / VBA -> Outlook 2003 -> Получение SMTP-адреса с использованием CDO -> WARNING
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]