在Outlook邮件中按正常顺序粘贴剪贴板内容

Question

在Outlook邮件中按正常顺序粘贴剪贴板内容

3

我有5个用户表单用于发送电子邮件。工作流程如下：

create new email

userform1.show
user selects the fields
automatic printscreen is inserted in the text

userform2.show
user selects the fields
automatic printscreen is inserted in the text

userform3.show
user selects the fields
automatic printscreen is inserted in the text

userform4.show
user selects the fields
automatic printscreen is inserted in the text

userform5.show
user selects the fields
automatic printscreen is inserted in the text

我的问题是最终的邮件会看起来像这样：

userform1 selected fields
userform2 selected fields
userform3 selected fields
userform4 selected fields
userform5 selected fields

print screen 5
print screen 4
print screen 3
print screen 2
print screen 1

有没有办法让打印屏幕以正确的顺序出现？

这是复制第一个用户窗体的剪贴板的代码（打印屏幕来自另一个应用程序）

Dim olInsp As Object
Dim oRng As Object
Dim wdDoc As Object

With objItem

         Set olInsp = .GetInspector
         Set wdDoc = olInsp.WordEditor
         Set oRng = wdDoc.Range
         oRng.collapse 1
         objItem.Display
         objItem.Visible = True
         objItem.HtmlBody = "<br><br>" & objItem.HtmlBody

         On Error Resume Next
         oRng.Paste

         objItem.HtmlBody = "<br>" & objItem.HtmlBody

         Dim myOutlook As Object
         Set myOutlook = GetObject(, "Outlook.Application")
         myOutlook.ActiveExplorer.Activate

End With

我让光标移动到邮件的末尾，但粘贴根本无效。

Dim objCurrentMail As Outlook.MailItem
Dim objWordDocument As Word.Document
Dim objWordRange As Word.Range
Dim VarPosition As Variant

    'Only work if the current email is using word editor
    Set objCurrentMail = Outlook.Application.ActiveInspector.CurrentItem
    Set objWordDocument = objCurrentMail.GetInspector.WordEditor


       VarPosition = objWordDocument.Range.End - 1000
       Set objWordRange = objWordDocument.Range(VarPosition, VarPosition)
       objWordRange.Select

    keybd_event VK_DOWN, 0, 0, 0
    keybd_event VK_DOWN, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_CONTROL, 0, 0, 0
    keybd_event VK_V, 0, 0, 0
    keybd_event VK_CONTROL, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_V, 0, KEYEVENTF_KEYUP, 0

- wittman

1

你能添加将打印屏幕复制到电子邮件中的代码吗？ - David Rushton

你可能需要将光标从objItem的开头移动到结尾。使用Word VBA来定位光标。可以参考以下链接：https://word.tips.net/T000120_Jumping_to_the_Start_or_End_of_a_Document.html 和 http://software-solutions-online.com/word-vba-move-cursor-to-end-of-document/，但要避免使用Sendkeys方法，具体可参考此链接：https://stackoverflow.com/questions/36775872/email-how-do-i-place-cursor-at-the-end-of-the-body-text。 - niton

我让光标移动到邮件的末尾，但粘贴根本不起作用。 - wittman

你知道 oRng.collapse 1 将选择移动到 oRng 的开头吗？ Const wdCollapseStart = 1，Const wdCollapseEnd = 0 -- 我会先尝试使用 wdCollapseEnd。 - Andre

4个回答

1

请尝试这个方法

如果不起作用，请点击电子邮件窗口并按下Ctrl-V粘贴剪贴板的内容

Sub testPaste()

    Dim outMail As Outlook.MailItem
    Set outMail = Application.CreateItem(olMailItem)
    outMail.Display (False)                      ' modeless

    Dim wd As Document
    Set wd = outMail.GetInspector.WordEditor

    WordBasic.SendKeys "{prtsc}"   ' do screenshot  may or may not work on your pc
    wd.Range.Paste                 ' paste from clipboard

    Set wd = Nothing
    Set outMail = Nothing
End Sub

- jsotola

0

请尝试一下这个。

这是一种“概念证明”。

希望它适用于您。

在“addTextToMessage”中有一个程序停止的地方，

然后你截屏，按F5继续。

该程序还会从文件夹插入图片（设置路径以适合您的系统）。

Const uf1 = "userform1 selected fields"          ' sample userform text
Const uf2 = "userform2 selected fields"
Const uf3 = "userform3 selected fields"
Const uf4 = "userform4 selected fields"
Const uf5 = "userform5 selected fields"

Sub fillEmail()

    Dim outMail As Outlook.MailItem
    Set outMail = Application.CreateItem(olMailItem)

    outMail.To = "example@example.com"
    outMail.Subject = "Testing inline images"
    outMail.Display (False)                      ' modeless

    Dim wordDoc As Document
    Set wordDoc = Application.ActiveInspector.WordEditor
    Set wordDoc = outMail.GetInspector.WordEditor

    wordDoc.Paragraphs.Space1                    ' format paragraph
    wordDoc.Paragraphs.SpaceBefore = 0           ' single-spaced ... etc
    wordDoc.Paragraphs.SpaceAfter = 0

    addTextToMessage wordDoc, uf1                ' these simulate the
    addTextToMessage wordDoc, uf2                ' five userforms boxes
    addTextToMessage wordDoc, uf3                ' you could pass the wordDoc reference
    addTextToMessage wordDoc, uf4                ' to each userform and have the userform
    addTextToMessage wordDoc, uf5                ' call the "addTextToMessage"

    Set wordDoc = Nothing
    Set outMail = Nothing


End Sub


Sub addTextToMessage(wd As Document, uf As String)

'    Debug.Print "------------------------------------------------"
'    Debug.Print "                 uf : " & uf
'    Debug.Print "wd.Paragraphs.Count : " & wd.Paragraphs.Count
'    Debug.Print " wd.Sentences.Count : " & wd.Sentences.Count
'    Debug.Print "wd.Characters.Count : " & wd.Characters.Count
'    Debug.Print "       wd.Range.End : " & wd.Range.End
'    Debug.Print "------------------------------------------------"

    wd.Range.InsertAfter (uf)
    wd.Range.InsertParagraphAfter
    wd.Range.InsertParagraphAfter
    wd.Range.InsertParagraphAfter

    Stop

' ------------------------------
' do screenshot here then hit F5
' ------------------------------
    wd.Characters.Last.Paste
    wd.Range.InsertParagraphAfter

' this inserts a picture from folder
' the userforms could place pictures in a folder

    wd.Characters.Last.InlineShapes.AddPicture _
    FileName:="C:\Users\js\AppData\Local\Temp\picture.png", _
    LinkToFile:=False, SaveWithDocument:=True

    wd.Range.InsertParagraphAfter


'    Debug.Print "wd.Paragraphs.Count : " & wd.Paragraphs.Count
'    Debug.Print " wd.Sentences.Count : " & wd.Sentences.Count
'    Debug.Print "       wd.Range.End : " & wd.Range.End


End Sub

- jsotola

你好，虽然你的代码很不错，但我还是无法理解它。它只在50%的情况下有效 - 我不知道为什么...感谢你的时间。 - wittman

0

这里是更新的代码

创建一个带有五个按钮的用户窗体

将此粘贴到表单代码中

它代表了您提到的五个用户窗体

您可以按任意顺序点击按钮，但生成的电子邮件始终按顺序排列

注意：在点击按钮之前，请截屏或将某些图形复制到剪贴板中

' test userForm code

Private Sub CommandButton1_Click()
    ' extra "demo" code in this sub
    ' see CommandButton2_Click sub for simplest code needed

    Dim rng As word.Range
    Set rng = emailTables(1).Cell(1, 1).Range

'    rng.Select                               ' debug

    rng.InsertAfter "1st line of response from userForm #1" & vbCrLf
    rng.InsertAfter "2nd line of response from userForm #1" & vbCrLf

    Set rng = emailTables(2).Cell(1, 1).Range

'    rng.Select                               ' debug

    rng.InsertAfter "screenshot from" & vbCrLf
    rng.InsertAfter "userForm #1" & vbCrLf
    rng.InsertAfter vbCrLf & vbCrLf

'    rng.Words(rng.Words.Count).Select        ' debug
'    rng.Words(rng.Words.Count - 1).Select    ' debug

    rng.Words(rng.Words.Count - 1).Paste     ' paste screenshot

'   insert picture from disk
'   emailTables(2).Cell(1, 1).Range.InlineShapes.AddPicture FileName:="C:\Users\js135001\AppData\Local\Temp\F4C97A0.png", LinkToFile:=False, SaveWithDocument:=True

    Set rng = Nothing

End Sub
'

Private Sub CommandButton2_Click()

    emailTables(1).Cell(2, 1).Range.InsertAfter "response from userForm #2"
    emailTables(2).Cell(2, 1).Range.Paste      ' paste screenshot

End Sub
'

Private Sub CommandButton3_Click()

    emailTables(1).Cell(3, 1).Range.InsertAfter "response from userForm #3"
    emailTables(2).Cell(3, 1).Range.Paste      ' paste screenshot

End Sub
'

Private Sub CommandButton4_Click()

    emailTables(1).Cell(4, 1).Range.InsertAfter "response from userForm #4"
    emailTables(2).Cell(4, 1).Range.Paste      ' paste screenshot

End Sub
'

Private Sub CommandButton5_Click()

    emailTables(1).Cell(5, 1).Range.InsertAfter "response from userForm #5"
    emailTables(2).Cell(5, 1).Range.Paste      ' paste screenshot

End Sub
'

Private Sub UserForm_Initialize()
    UserForm1.Caption = "do a screenshot before clicking buttons"
    CommandButton1.Caption = "UserForm1 response"
    CommandButton2.Caption = "UserForm2 response"
    CommandButton3.Caption = "UserForm3 response"
    CommandButton4.Caption = "UserForm4 response"
    CommandButton5.Caption = "UserForm5 response"
End Sub

将这段代码放入一个模块中并运行它。

' main code

Public emailTables As word.Tables                ' parameter passing to UserForms
'

Sub testEmail()                                  ' run me

    Dim outMail As Outlook.MailItem
    Set outMail = Application.CreateItem(olMailItem)
    outMail.Display (False)                      ' modeless

    Dim wd As Document
    Set wd = outMail.GetInspector.WordEditor

    For i = 0 To 9                               ' anchors for placing the two tables
        wd.Range.InsertAfter vbCrLf
    Next

    ' at this point, here is what the document contains:
    ' 1 Section / 11 Paragraphs / 1 Sentence / 11 Words / 11 Characters

    ' replace 4th character with a table ... same with 8th character

    ' place 2nd table first, because the 8th character would fall in the middle of the first table (if the 1st table was placed first)

    wd.Tables.Add Range:=wd.Characters(8), NumRows:=5, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
    wd.Tables.Add Range:=wd.Characters(4), NumRows:=5, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed

    MsgBox "please acquire a screenshot before clicking any of the buttons"

    Set emailTables = wd.Tables
    UserForm1.Show

    Set wd = Nothing
    Set outMail = Nothing
End Sub

享受

- jsotola

你好，你的代码只适用于剪贴板中的文本，而不支持剪贴板中的图像。感谢你花费时间和努力。 - wittman

如果我的剪贴板中有文本，则它会为我粘贴文本...请确保您的剪贴板中有图像...按PrintScreen键...或启动MS Paint，绘制一些内容，然后复制图像的一部分...然后单击五个按钮之一。 - jsotola

请尝试运行我提供的代码片段（testPaste）。 - jsotola

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- niton · Accepted Answer

这里有代码可以把光标移动到结尾 http://www.vboffice.net/en/developers/determine-cursor-position/

Public Sub SetCursor()
    Dim Ins As Outlook.Inspector
    Dim Doc As Word.Document
    Dim range As Word.range
    Dim pos As Long

    Set Ins = Application.ActiveInspector
    Set Doc = Ins.WordEditor
    If Not Doc Is Nothing Then
        pos = Doc.range.End - 1
        Set range = Doc.range(pos, pos)
        range.Select
    End If
End Sub

你的代码可能是这样的：

Option Explicit

Sub pasteAtEnd()

Dim olInsp As Object
Dim oRng As Object
Dim wdDoc As Object

Dim pos As Long
Dim objItem As Object

Set objItem = ActiveInspector.currentItem

With objItem

    Set olInsp = .GetInspector
    Set wdDoc = olInsp.WordEditor
    Set oRng = wdDoc.range

    objItem.Display
    'objItem.HTMLBody = "<br><br>" & objItem.HTMLBody
    objItem.HTMLBody = objItem.HTMLBody & "<br><br>"

    pos = wdDoc.range.End - 1
    Set oRng = wdDoc.range(pos, pos)
    oRng.Select

    MsgBox "Cursor should be at end of the mail body."

    'On Error Resume Next ' Use proper error handling
    oRng.Paste

End With

End Sub