Outlook VBA 脚本将文本从自定义表单移动到邮件正文

Question

我从未使用过 Outlook VBA (2010)，但我的经理要求我创建一个发送 IT 请求和 IS 请求的用户表单。我创建了自定义表单，在其中收集所有文本字段并将文本打印到单个文本框中。

此操作均在Sub CommandButton1_Click() 中定义，以Send() 结尾。在 sub 中，我对所有文本框都有类似的内容：

 Set Sj =Item.GetInspector.ModifiedFormPages("P.2").Controls("Subject_Text")
 Set YNbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("YNBox")
 Set Rbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("ReasonBox")

我想知道如何将“P.2”中的文本粘贴到“消息”页面的消息区域？

这里是打印到单个文本框的代码 sn-p：

FinalBox.Text = "Subject: " & Sj.Text & vbCrLf & _
vbCrLf & "Can work around the issue?: " & YNbox.Text & _
vbCrLf & "Reason For Ticketing: " & Rbox.Text & _
vbCrLf & "Department: " & Dbox.Text & _
vbCrLf & "Impact: " & Ibox.Text & _
vbCrLf & "Urgency: " & Ubox.Text & _
vbCrLf & "System/Machine Number: " & Mbox.Text & _
vbCrLf & "Was trying to accomplish: " & Abox.Text & _
vbCrLf & "Has it occured before?: " & Bbox.Text & _
vbCrLf & "First Noticed: " & Tbox.Text & _
vbCrLf & "Others affected by the issue: " & Affbox.Text & _
vbCrLf & "Additonal Comments: " & Addbox.Text

那么，我该如何获取这个并将其附加到消息页面中的实际消息字段中？

.

非常感谢！！

附：我一直遇到MailItem.body 的问题，每当我创建一个对象时，例如：

Dim objMsg As Object,

我收到一条错误消息，提示“预期语句结束”...我了解 VB 和 VBA 不同，但我认为它不会让我这么头疼。

编辑：

您好 dbMitch 和 Tony Dallimore，感谢您帮助我澄清我的问题。就像我提到的，我只是 VBA 的初学者，我只是想

`Sub Commandbutton
 Set Sj = Item.GetInspector.ModifiedFormPages("P.2").Controls("Subject_Text")
 Set YNbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("YNBox")
 Set Rbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("ReasonBox")
 Set Dbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("DepartmentDropbox")
 Set Mbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("MachineBox")
 Set Ibox = Item.GetInspector.ModifiedFormPages("P.2").Controls("ImpactBox")
 Set Ubox = Item.GetInspector.ModifiedFormPages("P.2").Controls("UrgencyBox")
 Set Abox = Item.GetInspector.ModifiedFormPages("P.2").Controls("AccomplishBox")
 Set Bbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("BeforeText")
 Set Tbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("Timebox")
 Set Affbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("AffectedBox")
 Set Addbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("AdditionalBox")
 Set Tbox8 = Item.GetInspector.ModifiedFormPages("P.2").Controls("TextBox8")
 Set MESBOX = Item.GetInspector.ModifiedFormPages("Message").Controls("Message")

 Tbox8.Text = "Subject: " & Sj.Text & vbCrLf & _
    vbCrLf & "Can work around the issue?: " & YNbox.Text & _
    vbCrLf & "Reason For Ticketing: " & Rbox.Text & _
    vbCrLf & "Department: " & Dbox.Text & _
    vbCrLf & "Impact: " & Ibox.Text & _
    vbCrLf & "Urgency: " & Ubox.Text & _
    vbCrLf & "System/Machine Number: " & Mbox.Text & _
    vbCrLf & "Was trying to accomplish: " & Abox.Text & _
    vbCrLf & "Has it occured before?: " & Bbox.Text & _
    vbCrLf & "First Noticed: " & Tbox.Text & _
    vbCrLf & "Others affected by the issue: " & Affbox.Text & _
    vbCrLf & "Additonal Comments: " & Addbox.Text
 Send
End Sub
`

我在网上找到的 Sub 假设要获取一个项目并将文本附加到消息正文中。每次我尝试声明对象的类型时似乎都会出现错误（例如 ____ As _____）。我不知道如何修改它以使其适合我的代码，但错误是在Dim objItem As Object 引发的，上面写着

预期语句结束

Sub TestAppendText()
Dim objItem As Object
Dim thisMail As Outlook.MailItem
'On Error Resume Next

Set objItem = Application.ActiveExplorer.Selection(1)
If Not objItem Is Nothing Then
    If objItem.Class = olMail Then
        Set thisMail = objItem
        Call AppendTextToMessage(thisMail, "Some text added at " & Now())
    End If
End If

Set objItem = Nothing
Set thisMail = Nothing
End Sub

Sub AppendTextToMessage(ByVal objMail As Outlook.MailItem, ByVal strText As String)
    Dim objCDO As MAPI.Session
    Dim objMsg As MAPI.Message
    Dim objField As MAPI.Field

    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False

    If Not objMail.EntryID = "" Then
        Set objMsg = objCDO.GetMessage(objMail.EntryID, _
                                   objMail.Parent.StoreID)
        objMsg.Text = objMsg.Text & vbCrLf & strText
        objMsg.Update True, True
        Set objField = objMsg.Fields(CdoPR_RTF_COMPRESSED)
        If Not objField Is Nothing Then
            objField.Delete
            objMsg.Update True, True
        End If
        Set objField = Nothing
        Set objField = objMsg.Fields(CdoPR_RTF_SYNC_BODY_COUNT)
        If Not objField Is Nothing Then
            objField.Delete
            objMsg.Update True, True
        End If
     Else
        strMsg = "You must save the item before you add text. " & _
                 "Do you want to save the item now?"
        intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Append Text to Message")
        If intAns = vbYes Then
            Call AppendTextToMessage(objMail, strText)
        Else
            Exit Sub
        End If
    End If

    Set objMsg = Nothing
    objCDO.Logoff
    Set objCDO = Nothing
End Sub

我也尝试过使用 CDO 对象，但它给了我一个错误，上面写着

ActiveX 组件无法创建对象：'CDONTS.NewMail'

Set Item1 = Item.MessageClass
Set objCDONTS = CreateObject ("CDONTS.NewMail")
objCDONTS.Body = Tbox8.Text

Item1.Message = "Hi"

如果这对其他人来说似乎很简单，我深表歉意。我在 VBA/VBScript 和 Outlook 设计方面只有 0 经验。这就是我在这里学习的原因！

Answer 1

请不要再问这样的问题。我确实理解告诉经理你缺乏完成任务的背景的困难。典型的反应似乎是：“这很容易：只需在互联网上查找即可。”从某种意义上说，这是真的。以下答案中没有您在其他答案中找不到的内容。您缺乏的是识别您需要的功能并将它们组合在一起以创建解决方案的背景。 VBA 不是一门难学的语言，但它与其他语言有许多显着差异，这会使刚接触 VBA 的有经验的程序员感到困惑。 Outlook 对象模型需要时间来掌握。

有很多在线 Excel VBA 和 Outlook VBA 教程。我认为 Excel VBA 教程更好。如果你被要求再次执行类似的任务，你必须坚持先有时间学习。我的这些答案可能会有所帮助：

• Update excel sheet based on outlook mail

• How to copy Outlook mail message into excel using VBA or Macros

我想创建一个完整的解决方案，因为我不相信另一个 sn-p 会有所帮助。你需要：“这行得通。逐步调整到您的确切要求。”

我不熟悉自定义表单，也找不到任何可以说明它们比适用于所有版本的 VBA 的用户表单的优势。我不想花时间研究自定义表单，特别是因为我有用户表单的代码，我可以轻松地根据您的要求进行调整。如果您的自定义表单效果令您满意，请替换我的解决方案的那部分。

我的解决方案有五个部分：

1. 用户表单。
2. 子例程SendTicket() 的第一部分，它加载用户表单并调用它以从用户那里获取数据。
3. 用户表单代码中的子例程UserForm_Initialize() 使用SendTicket() 提供的参数构建表单。
4. 子例程CommandButton1_Click() 对用户数据执行最低限度的验证并将其存储为SendTicket()。
5. 子例程 SendTicket() 的第二部分，它根据用户数据构建电子邮件并将其发送给 IT 部门。

1.用户表单

我插入了一个新的用户表单，调整了它的大小并添加了控件。如果您不知道如何执行此操作，请查看介绍用户表单的教程之一。

如果我将标签控件添加到用户表单并将其命名为 X，我可以，例如：

• 通过更改 X.Top 来移动它。
• 通过更改X.Caption显示一些文本。

用户表单包含一个名为Controls 的Collection。集合是大多数语言所称的未排序列表。在Controls 中，表单上的每个控件（标签、文本框、命令按钮等）都会有一个条目。如果标签 X 是用户表单上的第一个控件，我可以访问其属性为Controls(0).Top 和Controls(0).Caption。这意味着我可以拥有特定于标签 X 的代码，通过名称引用它，或者我可以拥有通用代码，通过它们在 Controls 中的位置来处理所有或选定的标签。对于您的要求，我相信通用代码会更容易，所以这就是我提供的。

我创建了一个标签控件和一个文本框控件。我保留了默认名称，但更改了一些属性：

              LABEL                  TEXT BOX
* Name        Label1                 TextBox1
  Caption     Prompt/Name
  Font        Tahoma 10              Tahoma 10
  Height      12                     18
  Left        12                     230
* Multiline                          True
* Scrollbars                         2 - frmScrollBarsVertical 
  TextAlign   3 – frmTextAlighRight  1 – frmTextAlignLegt
  Text/Value                         abcdefghijklmnopqrstuvwyz
* Visible     False                  False
  Width       200                    400
* Word wrap   True                   True

以“*”开头的属性很重要。其他是因为我喜欢它们影响表单外观的方式。

在英国，“Label1”和“TextBox1”是第一个标签和文本框的默认名称。对于 Excel，默认名称因当地语言而异；我不知道这是否适用于 Outlook。在代码中，它会告诉您如何在必要时更改默认名称。

我的代码假定标签的标题将适合单行，但输入到文本框中的文本可能需要多行。

创建标准标签和文本框后，我选择它们、复制它们、粘贴它们，然后移动副本，使它们正好位于第一对之下。我用四个控件重复了这个，然后是八个控件，最后是十六个控件。我以一列十六个标签和一列十六个文本框结束。我不关心控件的垂直位置；我稍后处理。如果任一列未完全对齐，您可以选择一列并为整个组设置 Left 属性。我已经创建了具有数百个性能可接受的控件的表单，因此如果您愿意，可以添加更多。

我创建了一个命令按钮。我将它与文本框对齐，但使字体更大。我保留了默认名称和标题。

通过最后创建命令按钮，控件处于正确的 Tab 键顺序。表单打开时光标位于第一个（顶部）字段中，每个选项卡将光标移至下一个字段，然后移至按钮。

最后，我设置了表单的宽度，使其比控件宽一点。我设置了高度，使其接近笔记本电脑上大约 560 的屏幕高度。可以从系统获取屏幕高度，但这超出了此答案的范围。我将标题设置为“报告问题”。我将它命名为 P2，这是我能找到的最接近您的名字（P.2 是用户表单的无效名称）。结果是：

** 2.子程序SendTicket()的第1部分**

宏不能直接向用户表单发送参数或接收返回值。它必须使用全局变量。 P2Params 是我用来将数据传递给用户表单的全局变量，我使用 P2Values 将数据传回。

P2Params = Array("Subject", …) 是使用参数加载P2Params 的语句。前三个参数是"Subject", 18, True，它们指定了第一个文本框。提示/名称为“主题”，高度为 18 且为必填项。每进一步的三个参数集定义另一个文本框。

我本可以在表单中定义所有这些信息，但要让这样的表单看起来像你想要的那样可能会非常麻烦，特别是如果你改变了对文本框高度的看法，所以必须移动所有较低的文本框下。使用这种方法，您可以轻松更改文本框的高度或更改顺序或添加新字段。注意：height 定义了分配给控件的高度。在我的笔记本电脑和我选择的字体上，54 就足够四行了。如果用户键入第五行，滚动条将出现在相关控件上，以便用户可以看到所有行。您可以根据一些平均或典型工单指定每个文本框的高度，但如果用户想要输入比您预期更多的文本并不重要。

Load P2 将表单加载到内存中并调用UserForm_Initialize() 来初始化表单。 .Show vbModal 将控制权传递给表单。在用户执行某些操作以返回控制权之前，不会返回控制权。在这种情况下，如果输入的值通过验证码，单击命令按钮将返回控制。

3.子程序 UserForm_Initialize()

我不打算对这个子程序多说。代码中的注释充分解释了代码的作用，下图显示了结果：

如果你往下看P2Params中的参数。您可以看到此布局的来源。这种方法的美妙之处在于，使用不同的参数集，可以产生非常不同的形式。导入文本值列表的要求并不少见，因此我之前使用过此代码的变体，并将再次使用。

4.子程序 CommandButton1_Click()

用户可以在需要的文本框中输入值。一旦它们正确，用户点击被子程序SendTicket()的第一部分重新命名为“发送”的命令按钮。

此例程验证所有必填字段是否都有值。我已经实施了允许的范围和其他验证，但这足以满足您的要求。如果字段值是可接受的，则例程将输入的值加载到数组P2Values 中。正如我所说，只有将值存储在全局变量中，用户表单才能将值返回给调用者。

5.子程序SendTicket()的第二部分

此代码从P2Values 获取值构建电子邮件并发送它。我已向实验性 Gmail 帐户发送电子邮件。您需要将收件人替换为您的 IT 部门的地址。

总结

这里有很多事情要考虑。慢慢地完成它，如有必要，请回来提出问题

SendTicket()

Option Explicit

  Public Type FieldDtl
    CtrlLabel As Long
    CtrlTextBox As Long
    Height As Long
    Mandatory As Boolean
    Prompt As String
  End Type

Public P2Params As Variant
Public P2Values() As String
Sub SendTicket()

  Dim InxFld As Long
  Dim InxPrm As Long
  Dim MailItemCrnt As MailItem

  P2Params = Array("Subject", 18, True, _
                   "Can you work around the issue?", 18, True, _
                   "Reason For Ticketing", 30, True, _
                   "Department", 18, False, _
                   "Impact", 18, True, _
                   "Urgency", 18, True, _
                   "System/Machine Number", 18, True, _
                   "Was trying to accomplish", 54, True, _
                   "Has it occured before?", 18, True, _
                   "First Noticed", 18, False, _
                   "Others affected by the issue", 42, True, _
                   "Additional Comments", 54, True)

  ' Used to test total height of control exceeding height of screen
  'P2Params = Array("Subject", 50, True, _
  '                 "Can you work around the issue?", 50, True, _
  '                 "Reason For Ticketing", 50, True, _
  '                 "Department", 50, False, _
  '                 "Impact", 50, True, _
  '                 "Urgency", 50, True, _
  '                 "System/Machine Number", 50, True, _
  '                 "Was trying to accomplish", 54, True, _
  '                 "Has it occured before?", 50, True, _
  '                 "First Noticed", 50, False, _
  '                 "Others affected by the issue", 54, True, _
  '                 "Additional Comments", 54, True)

  Load P2
  With P2
    .CommandButton1.Caption = "Send"
    .Show vbModal
  End With

 ' The bounds of P2Values are 1 to number of fields
 ' The bounds of P2Params could be 1 to NumberOfFields*3 but is almost
 ' certainly 0 to NumberOfFields*3-1

 Set MailItemCrnt = CreateItem(olMailItem)
 With MailItemCrnt
   .BodyFormat = olFormatPlain
   .Recipients.Add "AbbeyRuins33@gmail.com"
   .Subject = P2Values(1)           ' Assumes subject is first field
   .Body = P2Params(LBound(P2Params) + 3) & ": " & P2Values(2)
   InxFld = 3
   For InxPrm = LBound(P2Params) + 6 To UBound(P2Params) Step 3
     .Body = .Body & vbCrLf & P2Params(InxPrm) & ": " & P2Values(InxFld)
     InxFld = InxFld + 1
   Next
   .Display
   ' .Send
 End With
 Set MailItemCrnt = Nothing

End Sub 

用户表单代码

Option Explicit

' In UK, the default name for a label is "LabelN" and the default name for a text box
' is "TextBoxN".  In case the default name is different is non-English speaking
' countries, I use constants for these values. Change the value of these constants
' as necessary.
Const NameLabel As String = "Label"
Const NameTextBox As String = "TextBox"

' This code assumes there are N labels named NameLabel & 1 to NameLabel & N and
' N text boxes named NameTextBox & 1 to NameTextBox & N.  NameLabelX is used to
' label TextBoxX which is used to obtain the Xth value from the user.

' User type FieldDtl is defined in the SendTicket module
Dim Fields() As FieldDtl
Private Sub CommandButton1_Click()

  Dim ErrMsg As String
  Dim InxFld As Long

  ' Check values have been entered for mandatory fields
  ErrMsg = ""
  For InxFld = 1 To UBound(Fields)
    If Fields(InxFld).Mandatory And Controls(Fields(InxFld).CtrlTextBox).Text = "" Then
      If ErrMsg <> "" Then
        ErrMsg = ErrMsg & vbLf
      End If
      ErrMsg = ErrMsg & "Please enter a value for " & Fields(InxFld).Prompt
    End If
  Next

  ' No value entered for one or more mandatory fields
  If ErrMsg <> "" Then
    Call MsgBox(ErrMsg, vbOKOnly)
    Exit Sub
  End If

  ' Save values for caller
  ReDim P2Values(1 To UBound(Fields))
  For InxFld = 1 To UBound(Fields)
    P2Values(InxFld) = Controls(Fields(InxFld).CtrlTextBox).Text
  Next

  Unload Me

End Sub
Private Sub UserForm_Initialize()

  Const GapBetweenCtrls As Long = 5

  Dim InxCtrl As Long
  Dim InxFld As Long
  Dim InxPrm As Long
  Dim NumFields As Long
  Dim NumParams As Long
  Dim TopNext As Long

  ' Note: LBound(P2Params) can be zero or one but will almost certainly be zero.
  ' This code allows for either possibility.
  NumParams = UBound(P2Params) - LBound(P2Params) + 1
  Debug.Assert NumParams Mod 3 = 0

  NumFields = NumParams / 3
  ReDim Fields(1 To NumFields)

  ' Import values from P2Params
  ' P2Params must contain 3N paramerers where N is the number of values
  ' to be obtained from the user.  The three values are:
  '   Prompt/Name for value.
  '   Height of value (so control can be sized for multi-line values).
  '   Mandatory? (True is a value must be entered)
  InxFld = 1
  For InxPrm = LBound(P2Params) To UBound(P2Params) Step 3
    Fields(InxFld).Prompt = P2Params(InxPrm)
    Fields(InxFld).Height = P2Params(InxPrm + 1)
    Fields(InxFld).Mandatory = P2Params(InxPrm + 2)
    InxFld = InxFld + 1
  Next

  ' Controls can be accessed by name (for example Label1.Caption) or
  ' by position within the collection Controls (for example
  ' Controls(1).Caption).  Add control numbers to Fields().
  For InxCtrl = 0 To Controls.Count - 1
    If Left$(Controls(InxCtrl).Name, Len(NameLabel)) = NameLabel Then
      ' Extract number at end of name
      InxFld = CLng(Mid(Controls(InxCtrl).Name, Len(NameLabel) + 1))
      If InxFld <= NumFields Then
        ' This control will be used
        Fields(InxFld).CtrlLabel = InxCtrl
      End If
    ElseIf Left$(Controls(InxCtrl).Name, Len(NameTextBox)) = NameTextBox Then
      InxFld = CLng(Mid(Controls(InxCtrl).Name, Len(NameTextBox) + 1))
      If InxFld <= NumFields Then
        ' This control will be used
        Fields(InxFld).CtrlTextBox = InxCtrl
      End If
    End If
  Next

  '  For InxFld = 1 To NumFields
  '    Debug.Print Fields(InxFld).Name & " " & Fields(InxFld).Height & " " & _
  '                Fields(InxFld).Mandatory & " " & Fields(InxFld).CtrlLabel & _
  '                " " & Fields(InxFld).CtrlTextBox
  '  Next

  ' Now have information necessary to build form.

  ' This code assumes/relies on:
  '   * All  properties of the textbox controls being correct
  '     except for Top and Height.
  '   * All  properties of the label controls being correct except for Top.
  '   * The Height of the label controls being less than the Height of any
  '     Textbox control.
  '   * The Visible property of the label and textbox controls being false.
  '   * The Multiline property of the textbox controls being true
  '   * The Scrollbars property of the textbox controls being
  '     2 = frmScrollBarsVertical
  '   * The Width of the label property being such that all captions fit.

  TopNext = GapBetweenCtrls

  For InxFld = 1 To NumFields
    With Controls(Fields(InxFld).CtrlLabel)
      .Top = TopNext
      .Caption = Fields(InxFld).Prompt
      .Visible = True
    End With
    With Controls(Fields(InxFld).CtrlTextBox)
      .Top = TopNext
      .Height = Fields(InxFld).Height
      .Text = ""
      .Visible = True
    End With
    TopNext = TopNext + Fields(InxFld).Height + GapBetweenCtrls
  Next

  With CommandButton1
    .Top = TopNext
    TopNext = TopNext + .Height + GapBetweenCtrls
  End With

  ' Set scroll height so if total height of controls exceeds height
  ' of form, user can scroll from top to bottom.
  ScrollHeight = TopNext

End Sub