Question

我发现了将图表从excel粘贴到堆栈{out of flow}上的Outlook here的代码。

这可以正常工作，但问题是创建新电子邮件的Outlook和粘贴过程正在屏幕上显示。有什么方法可以禁用它或使其成为背景吗？

Sub Mail_Range()
    Dim Sht As Excel.Worksheet
    Set Sht = ThisWorkbook.ActiveSheet

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

    Dim rng As Range
    Set rng = Sht.Range("A5:W20")
        rng.Copy

    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

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


    Dim OutMail As Object
    Set OutMail = OutApp.CreateItem(0)

    Dim vInspector As Object
    Set vInspector = OutMail.GetInspector

    Dim wEditor As Object
    Set wEditor = vInspector.WordEditor

    With OutMail
        .TO = "xxx.xxx.com"
        .CC = ""
        .Subject = Sht.Range("A5").Value
        .GetInspector
         wEditor.Paragraphs(1).Range.Text = "This is an auto generated e-mail" & vbCr
         wEditor.Paragraphs(2).Range.Paste
        .send
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    Application.CutCopyMode = False

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

当我使用

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

创建Outlook应用程序后，我的粘贴代码不起作用。我收到没有内容的电子邮件。

Answer 1

Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")

With Application  <<<---- change to OutApp
    .ScreenUpdating = False
    .EnableEvents = False
End With

Answer 2

如果您的问题是您不希望看到邮件的整个过程，但是将ScreenUpdating设置为false会显示空白图像，这是我处理此问题的代码：

            Call AhorroMemoria(False)
            Imagen.CopyPicture xlScreen, xlBitmap
            With wsM.ChartObjects.Add(Imagen.Left - Imagen.Left * 0.15, Imagen.Top - Imagen.Top * 0.15, _
            Imagen.Width - Imagen.Width * 0.15, Imagen.Height - Imagen.Height * 0.15)
                .Activate
                wsM.Shapes("Gráfico 1").Line.Visible = msoFalse
                .Chart.Paste
                .Chart.Export wb.Path & "\" & Servicio & Contador & ".jpg", "JPG"
            End With
            Call AhorroMemoria(True)

Call AhorroMemoria(False)打开了所有功能，包括屏幕更新，启用事件等等。我只是在复制图像时这样做，就像在代码中看到的那样，然后我再次在Call AhorroMemoria(True)上将其全部关闭。

希望有帮助。

Answer 3

谢谢大家的帮助。您的所有代码都以某种方式提供了帮助。但是我发现了来自Microsoft here的更简单的代码。我不确定哪个版本将支持此功能，并且还有其他挑战。目前，这在 Office 2016 中对我有效。

我在excel中获得了短时间的电子邮件信封，但是没有问题，因为这种方法无法进行意外编辑。在原始方法中，粘贴功能运行期间可能会意外编辑。

此代码还可以无缝地将电子邮件发送到excel工作表中。

Option Explicit    
Sub Send_Range()

       ' Select the range of cells on the active worksheet.
       ActiveSheet.Range("A1:B5").Select

       ' Show the envelope on the ActiveWorkbook.
       ActiveWorkbook.EnvelopeVisible = True

       ' Set the optional introduction field thats adds
       ' some header text to the email body. It also sets
       ' the To and Subject lines. Finally the message
       ' is sent.
       With ActiveSheet.MailEnvelope
          .Introduction = "This is a sample worksheet."
          .Item.To = "E-Mail_Address_Here"
          .Item.Subject = "My subject"
          .Item.Send
       End With
    End Sub

Answer 4

我认为您不能通过调用Word Editor方法来禁止显示电子邮件创建屏幕。如果您查看过以前的SO帖子和经验丰富的专家的评论，就会清楚地知道您不能禁止显示电子邮件创建屏幕。

为了完全禁用电子邮件创建屏幕显示，请参考roundebruin中的程序的参考，该程序涵盖了不显示电子邮件创建屏幕而发送电子邮件的所有类型。如果有人发现它对类似情况有用，这是对我有用并已发布的代码的一个细微变化。

Public Sub Emails()
Dim str As String
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

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

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
str = ws1.Range("A5").Value
With newEmail
    .To = "xxx.xxx.com"
    .CC = ""
    .BCC = ""
    .Subject = str
    .body = ""
    .display

    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor

   'Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    ws1.Range("A5").Copy
    pageEditor.Application.Selection.Paste xlValues
    ws1.Range("A5:W20").Copy
    pageEditor.Application.Selection.Paste xlValues

    .send
    Set pageEditor = Nothing
    Set xInspect = Nothing
End With

Set newEmail = Nothing
Set outlook = Nothing
With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

从Excel粘贴到Outlook-Outlook屏幕更新

4 个答案: