Сохраняйте форматирование при вставке содержимого из документа Word в почту Outlook - PullRequest
Новая
       31

Сохраняйте форматирование при вставке содержимого из документа Word в почту Outlook

0 голосов
/ 12 июня 2019

Я пытаюсь запустить макрос в Excel, чтобы скопировать содержимое из документа Word, вставить его в Outlook с форматированием, как в документе Word, и отправить на адрес электронной почты в ячейке Excel.

Я пробовал DataObj.GetText и Content.Paste, но не смог заставить их работать. 

Sub send_email()

    Dim olApp As Object
    Dim olMailItm As Object
    Dim iCounter As Integer
    Dim Dest As Variant
    Dim SDest As String
    Dim doc As Object
    Dim wd As Object
    Dim editor As Object
    Dim strPaste  As Variant
    Dim DataObj As MSForms.DataObject

    Set DataObj = New MSForms.DataObject

    Set wd = CreateObject("Word.Application")
    Set doc = wd.documents.Open(Filename:="C:\Users\Username\Documents\toEmail.docx", ReadOnly:=False)
    doc.Content.Copy
    DataObj.GetFromClipboard
    strPaste = DataObj.GetText(1)
    If strPaste = False Then Exit Sub

    doc.Close
    Set wd = Nothing

    ' Subject
    strSubj = "Important Credentials"
    On Error GoTo dbg

    ' Create a new Outlook object
    Set olApp = CreateObject("Outlook.Application")
    For iCounter = 1 To WorksheetFunction.CountA(Columns(1))

    ' Create a new item (email) in Outlook
    Set olMailItm = olApp.CreateItem(0)
    strBody = ""
    useremail = Cells(iCounter, 1).Value
    FullUsername = Cells(iCounter, 2).Value
    statLvl = Cells(iCounter, 3).Value
    Status = Cells(iCounter, 5).Value
    pwdchange = Cells(iCounter, 4).Value

    'Make the body of an email
    strBody = "Dear " & FullUsername & vbCrLf
    strBody = strBody & "Your status of " & statLvl & " is in " & Status & " state" & vbCrLf
    strBody = strBody & "The date and time of the last password change is " & pwdchange & vbCrLf

    olMailItm.To = FullUsername
    olMailItm.Subject = strSubj
    olMailItm.BodyFormat = 1

    olMailItm.Body = strPaste
    olMailItm.Send
    Set olMailItm = Nothing
    Next iCounter
    Set olApp = Nothing
dbg:
    'Display errors, if any
    If Err.Description <> "" Then MsgBox Err.Description

End Sub

Нет сообщений об ошибках, он не сохраняет исходное форматирование при вставке.

...