Автоподбор в Outlook Excel MailEnvelope - PullRequest
Новая
       68

Автоподбор в Outlook Excel MailEnvelope

1 голос
/ 23 сентября 2019

я пытаюсь отправить почту, используя Mail MailEnvelope, но содержимое отправляется после отправки письма, как показано на картинке ниже.

enter image description here

с моим кодом IЯ могу отправлять письма с помощью MailEnvelope.но содержимое Excel и таблица упаковываются, как показано на картинке ниже ...

, пожалуйста, помогите мне исправить то же самое, любая помощь очень ценится ... заранее 

Sub Sample_MailEnvelope()

Application.ScreenUpdating = False

Sheets("Mail").Visible = True
Dim foliorange As Range

Set foliorange = Sheets("Countsheet").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

For Each mycell In foliorange

Worksheets("Mail").Unprotect (".")

Sheets("Mail").Range("A7:B7") = mycell.Offset(0, 2).Value
Sheets("Mail").Range("C7:D7") = mycell.Offset(0, 3).Value
Sheets("Mail").Range("E7:F7") = mycell.Offset(0, 4).Value


  Dim Sendrng As Range

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


Sheets("Mail").Activate
Range("A1").Select

     Set Sendrng = Selection

    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

 ''.Introduction = "Hi," & vbNewLine & vbNewLine & "Kindly note that we have received the following transactions from you today." & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine
 .Introduction = ""

            With .Item
                .To = mycell.Offset(0, 6).Value    '"email@email.com"
                .CC = mycell.Offset(0, 7).Value
                .BCC = ""
                .Subject = "OCBC - IUTA CONFIRMATION"
                .Display
                .send

            End With
        End With
    End With
StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
   ActiveWorkbook.EnvelopeVisible = fasle
Next mycell
Worksheets("Mail").Protect "."
Sheets("Mail").Visible = False
Application.ScreenUpdating = True

End Sub

Пожалуйстапомогите мне с кодом или любой идеей, как преодолеть эту проблему с переносом

Я пытаюсь прикрепить мой пример файла макроса, но я не нашел никакой возможности прикрепить файлы здесь.

1 Ответ

0 голосов
/ 25 сентября 2019

Попробуйте что-то подобное ниже, измените при необходимости 

Option Explicit
Public Sub Exampple()
    Dim olApp As Object
    Dim Email As Object
    Dim Sht As Excel.Worksheet
    Dim wdDoc As Word.Document

    Set Sht = ActiveWorkbook.Sheets("Mail")

    Dim rng As Range
    Set rng = Sht.Range("A7:E7")
        rng.Copy 'Picture Appearance:=xlScreen, Format:=xlPicture

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set Email = olApp.CreateItem(0)
    Set wdDoc = Email.GetInspector.WordEditor

    With Email
        .To = "email@email.com"
        .Subject = "OCBC - IUTA CONFIRMATION"
        .Attachments.Add ""
        .Display

         wdDoc.Paragraphs(1).Range.PasteAndFormat Type:=wdChartPicture

         wdDoc.Paragraphs(1).SpaceAfter = 30

'         if need setup inlineshapes hight & width
         With wdDoc.InlineShapes(1)
            .ScaleHeight = 113
            .ScaleWidth = 114
         End With

'        .Display

        .Send   'or use .Display
    End With

    Set wdDoc = Nothing
    Set Email = Nothing
    Set olApp = Nothing
End Sub

Обязательно обратитесь к библиотеке объектов Microsoft Word xx.x

https://stackoverflow.com/a/42662697/4539709

...