Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 10.03.2021, 10:40   #1
Sergey_29ar
Новичок
Джуниор
 
Регистрация: 26.10.2016
Сообщений: 2
По умолчанию Как добавить стандартную подпись в сообщение Outlook

Всем добрый день!
Использую данный код при создании писем в Outlook через VBA с форматированием для таблиц.

Код:
Option Explicit

Sub Send_Mail()
    Dim oOutlApp As Object, objMail As Object
    Dim sTo As String, sCC As String, sSubject As String, sBody As String, sTblBody As String, sAttachment As String
    Dim rDataR As Range
    Dim IsOultOpen As Boolean
 
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Set oOutlApp = GetObject(, "Outlook.Application")
    If Err = 0 Then
        IsOultOpen = True
    Else
        Err.Clear
        Set oOutlApp = CreateObject("Outlook.Application")
    End If
    oOutlApp.Session.Logon
    Set objMail = oOutlApp.CreateItem(0)
    
    If Err.Number <> 0 Then Set oOutlApp = Nothing: Set objMail = Nothing: Exit Sub
    
    With ActiveWorkbook.Sheets("Ëèñò2")
        sTo = .Range("P30").value
        sCC = .Range("P31").value
        sSubject = .Range("P33").value
        sBody = .Range("P32").value
        sAttachment = .Range("P35").value
    
        sBody = Replace(sBody, Chr(10), "<br />")
        sBody = Replace(sBody, vbNewLine, "<br />")
        sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"
    
        Set rDataR = .Range("B1:K28")
        sTblBody = ConvertRngToHTM(rDataR)

        sBody = Replace(sBody, "{TABLE}", sTblBody)
    End With
    
    

    With objMail
        .To = sTo
        .CC = sCC
        .Subject = sSubject
        .BodyFormat = 2
        .HTMLBody = sBody
        If sAttachment <> "" Then
            .Attachments.Add sAttachment
        End If
        .display
    End With
    
    If IsOultOpen = False Then oOutlApp.Quit
    Set oOutlApp = Nothing: Set objMail = Nothing
    DoEvents
End Sub

Function ConvertRngToHTM(rng As Range)
    Dim fso As Object, ts As Object
    Dim sF As String, resHTM As String
    Dim wbTmp As Workbook
 
    sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set wbTmp = Workbooks.Add(1)
    With wbTmp.Sheets(1)
        .Cells(1).PasteSpecial xlPasteColumnWidths
        .Cells(1).PasteSpecial xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        '------------------------------------------
    End With
    With wbTmp.PublishObjects.Add( _
         SourceType:=xlSourceRange, Filename:=sF, _
         Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
    resHTM = ts.ReadAll
    ts.Close
    ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
    wbTmp.Close False
    Kill sF
    Set ts = Nothing: Set fso = Nothing
    Set wbTmp = Nothing
End Function

Function RangeToTextTable(rng As Range)
    Dim lr As Long, lc As Long, arr
    Dim res As String, rh()
    Dim lSpaces As Long, s As String
     
    arr = rng.value
    If Not IsArray(arr) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rng.value
    End If
    ReDim rh(1 To UBound(arr, 2))
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            If Len(arr(lr, lc)) > rh(lc) Then
                rh(lc) = Len(arr(lr, lc))
            End If
        Next
    Next
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            s = arr(lr, lc)
            lSpaces = rh(lc) - Len(s)
            If lSpaces > 0 Then
                s = s & Space(lSpaces)
            End If
            If lc = 1 Then
                res = res & s
            Else
                res = res & vbTab & s
            End If
        Next
        res = res & vbNewLine
    Next
    RangeToTextTable = res
End Function
Подскажите как в VBA добавить стандартную подпись при создании сообщения.
В приложенном примере, подпись добавляется с ячейки B13, мне нужно чтобы стандартная подпись добавлялась автоматически с Outlook.

Нашел следующий код для создания сообщения с подписью, но самому не получается добавить в первый код.

Код:
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Mysig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Заранее спасибо!
Вложения
Тип файла: xls Tips_Macro_RangeToMail.xls (74.0 Кб, 2 просмотров)
Sergey_29ar вне форума Ответить с цитированием
Старый 10.03.2021, 11:28   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

1. добавить в свой код функцию
Код:
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
2. в свой SendMail перед
Код:
With objMail
вставить

Код:
Dim SigString As String
    Dim Signature As String
    
    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\ХХХХХХХХХХХХХХ.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
3. заменить в коде ХХХХХХХХХХХХХХ.htm на имя своей подписи из
c:\Users\<USERNAME>\AppData\Roaming \Microsoft\Signatures\

4. изменить в SendMail
Код:
.HTMLBody = sBody
на
Код:
.HTMLBody = sBody & vbNewLine & Signature
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 10.03.2021, 11:44   #3
Sergey_29ar
Новичок
Джуниор
 
Регистрация: 26.10.2016
Сообщений: 2
По умолчанию

Aleksandr H., Спасибо большое! Все работает
Sergey_29ar вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
VBA Outlook: сделать в инспекторе "Сообщение - Действия - Изменить сообщение" vamosss Фриланс 1 13.02.2017 14:02
VBA Outlook: Как открыть сообщение для редактирования через объектную модель Word? vamosss Microsoft Office Word 5 13.02.2017 13:52
Подпись в outlook Trespass Microsoft Office Excel 0 13.01.2017 21:04
Что означает сообщение Outlook? Olya1985 Софт 1 26.04.2013 18:07
Как отправить Access-ом сообщение по Outlook? ИгнатАлт Microsoft Office Access 2 23.11.2007 18:47