我有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
答案 0 :(得分：3)
这里有代码将光标移动到末尾http://www.vboffice.net/en/developers/determine-cursor-position/
$sql = 'SELECT * FROM `usermeta` WHERE `user_id` = 2';
$stmt = $pdo->prepare($sql);
$stmt->execute();
$rows = $stmt->fetchAll(PDO::FETCH_UNIQUE);
var_dump($rows);
您的代码可能如下所示：
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
答案 1 :(得分：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
答案 2 :(得分：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
答案 3 :(得分：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
享受