Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Visual Basic Новый топик    Ответить
 Отправка письма через определенную учетку  [new]
Rfdshir
Member

Откуда:
Сообщений: 4
Здравствуйте.
Проблема следующая: у пользователей в аутлуке по 2 учетки: Exchange - для почты внутри предприятия, и внешняя. Надстройка для аутлука должна отсылать письмо именно через Exchange,
вне зависимости от того, какая учетка используется по умолчанию.

Пытался решить двумя способами:

1) Использование sendusingaccount и отправка с помощью redemption.safemailitem.
Письмо помещается в "черновики", с пометкой "письмо будет отправлено с учетной записи user@pmp.local" (все правильно, это учетка Exchange), но после нажатия "отправить и получить" - отправляется с учетки по умолчанию.
Соответственно, если по умолчанию стоит внешняя учетка - письмо никуда не доходит.

Public Sub sbSendEmail()
        
        Dim olApp As Outlook.Application
        Dim objMsg As Outlook.MailItem
        Dim objSafeMsg As Redemption.SafeMailItem
        Dim acc As Outlook.Account
        Dim j As Long
        Dim fa As Boolean = False

        olApp = CreateObject("Outlook.Application")

        'ищем учетку
        If olApp.Session.Accounts.Count > 0 Then
            For j = 1 To olApp.Session.Accounts.Count
                If olApp.Session.Accounts.Item(j).AccountType = Outlook.OlAccountType.olExchange Then
                    'нашли учетку Exchange
                    acc = olApp.Session.Accounts(j)
                    fa = True
                    Exit For
                End If
            Next j
        Else
            MsgBox("нет учеток")
        End If

        If (fa) Then
'если учетка Exchange существует - отправляем письмо
objMsg = olApp.CreateItem(Outlook.OlItemType.olMailItem)
            objMsg.Subject = "primer"
            objMsg.Body = "primer body"
            'objSafeMsg = CreateObject("Redemption.SafeMailItem")
            ''objSafeMsg.sendUsingAccount = acc
            'objSafeMsg.Item = objMsg
            'objSafeMsg.Recipients.Add("printrequest@pmp.local")
            'objSafeMsg.Recipients.ResolveAll()
            'objSafeMsg.Send()
            'objMsg = Nothing
            'objSafeMsg = Nothing
            'olApp = Nothing
else 
msgbox ("Не найдена учетная запись Exchange")
end if
end sub

2) Отправка письма через cdo с прямым указанием адреса отправителя. Но в этом случае для аутентификации на сервере требуется логин и пароль, без них - не работает. Логин и пароль используются от доменной учетки пользователя винды. Как я понимаю, вытащить пароль с помощью VB - нереально...

public sub sendemail()

Dim oMSG As Object
            Dim oConfig As Object
            Dim CFields As Object
            Dim strBody As String

            oMSG = CreateObject("CDO.Message")
            oConfig = CreateObject("CDO.Configuration")
            CFields = oConfig.Fields
            oMSG.Configuration = oConfig

            CFields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            CFields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.pmp.local"
            CFields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            CFields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            CFields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "userlogin" 
            CFields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "userpassword" 
            CFields.Update()

            oMSG.To = "printrequest@pmp.local"
            oMSG.From = "userlogin@pmp.local"
            oMSG.Subject = "primer"
            oMSG.BodyPart.Charset = "windows-1251"
            oMSG.TextBody = "primer body"
            oMSG.Send()

end sub

В коде обильно успользуются примеры с форума sql.ru, за что большое-пребольшое спасибо!

Конечно, можно определить, каков тип учетки по умолчанию, и если не Exchange - уведомить пользователя, чтоб сам переключил.
Но, может, кто-нибудь сможет подсказать нормальный вариант решения?
27 авг 10, 03:30    [9334354]     Ответить | Цитировать Сообщить модератору
 Re: Отправка письма через определенную учетку  [new]
Rfdshir
Member

Откуда:
Сообщений: 4
Извините, в первом примере кода комменты случайно не убрал.

 
objSafeMsg = CreateObject("Redemption.SafeMailItem")
            objSafeMsg.sendUsingAccount = acc
            objSafeMsg.Item = objMsg
            objSafeMsg.Recipients.Add("printrequest@pmp.local")
            objSafeMsg.Recipients.ResolveAll()
            objSafeMsg.Send()
            objMsg = Nothing
            objSafeMsg = Nothing
            olApp = Nothing
27 авг 10, 03:35    [9334356]     Ответить | Цитировать Сообщить модератору
 Re: Отправка письма через определенную учетку  [new]
Rfdshir
Member

Откуда:
Сообщений: 4
В общем, так и не найдя ответа, сделал следующее: завел отдельную учетку на серваке, пусть все письма(заявки) уходят через нее, с помощью CDO. Плюс перед Redemption очевиден - письма уходят сразу, не тусуясь в "черновиках", пока пользователь не нажмет "отправить и получить", да и redemption ставить юзерам не придется.

Правда, при таком раскладе в текст письма приходится добавлять адрес отправителя, и при ответе (программным же способом) - выдирать его обратно...
30 авг 10, 09:38    [9347214]     Ответить | Цитировать Сообщить модератору
Между сообщениями интервал более 1 года.
 Re: Отправка письма через определенную учетку  [new]
controlgate
Member

Откуда:
Сообщений: 1
Sub Mail_()
'Only working in Office 2007-2016
'Don't forget to set a reference to Outlook in the VBA editor
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)

    strbody = "Hi there" & vbNewLine & vbNewLine & _
              "This is line 1" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"

    On Error Resume Next
    With OutMail
        .To = "d.medvedev@controlgate.ru"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = strbody

        'SendUsingAccount is new in Office 2007
        'Change Item(1)to the account number that you want to use
        .SendUsingAccount = OutApp.Session.Accounts.Item(1)

        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Ещё для .SendUsingAccount надо достучаться до объектов Outlook.
Tools->refrences-> Microsoft Outlook xx.x Object Library
19 мар 19, 18:15    [21837651]     Ответить | Цитировать Сообщить модератору
Все форумы / Visual Basic Ответить