Question

我有电子邮件的代码，我想连接到Excel中的列。触发宏时，应显示下拉列表，以便根据excel中的列表选择如何发送电子邮件。该列表是从其他excel生成的，它可以有2个全名或40个全名。列表在Sheet4中，名称在列L中，电子邮件地址在列Q中，文本在列P中。如果我从下拉列表中选择，名称在L2中，则应该从Q2中取出电子邮件地址，名称来自L2和来自P2的文本。这是我到现在为止所拥有的：

Sub email_to_one_person_from_the_list()
Dim OutApp As Object
Dim OutMail As Object
Dim xlApp As Object
Dim sourceWB As Object
Dim sourceWS As Object

    Set xlApp = CreateObject("Excel.Application")
    strFile = "C:\persons.xlsm" 

    Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
    Set sourceWH = sourceWB.Worksheets("Sheet4")
    sourceWB.Activate

sourceWH.Application.Run "Module2.FetchData3"

     On Error Resume Next
     Set OutApp = GetObject(, "Outlook.Application")
     If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
     On Error GoTo 0

     Set OutMail = OutApp.CreateItem(0)
     With OutMail
         .To = sourceWH.Range("Q2").Value
         .CC = ""
         .BCC = ""
         .Subject = "Dear " & sourceWH.Range("L2").Value
         .Display
         OutMail.HTMLBody = sourceWH.Range("P2").Value

   sourceWB.Close SaveChanges:=False
   xlApp.Quit

     Set OutMail = Nothing
     Set OutApp = Nothing

End Sub

和组合框：

Private Sub CancelButton_Click()
 Unload Me
 End
End Sub
Private Sub OKButton_Click()
    thelist1 = ComboBox1.ListIndex
    Unload Me
End Sub
Private Sub UserForm_Initialize()
With ComboBox1 
             ' the  excel list here
End With
End Sub

Answer 1

要将Outlook连接到Excel，首先必须添加对＆＃34; Microsoft Excel XX对象库＆＃34;的引用。其中XX是某个版本号（Extras-＆gt; References）

然后创建一个userform，我的样子如下：

请注意，我的组合框有2列（第一列的宽度为0，因此它不可见）

然后，当您加载表单时，添加代码以打开Excel实例并加载带有值的组合框以供选择：

Private Sub UserForm_Initialize()

'Define Excel-Variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet

'Create Excel Instance
Set xlApp = New Excel.Application

'Make it invisible
xlApp.Visible = False

'Open Workbook with Values
Set xlWB = xlApp.Workbooks.Open("PATH TO YOUR EXCEL FILE")

'Select the Sheet with Values
Set xlSheet = xlWB.Worksheets("sheet1")

Dim i As Integer

'Loop through the Values
For i = 1 To 30 Step 1

    'This Combobox has 2 Columns where 1 is the bound one
    'Add RowIndex to the first column(will be used to find the values later)
    Me.cboTest.AddItem i

    'Add the Name to the second Column
    Me.cboTest.List(Me.cboTest.ListCount - 1, 1) = xlSheet.Cells(i, 1).Value
Next i

'Clean up and close Excel
Set xlSheet = Nothing

xlWB.Close False

xlApp.Quit

Set xlWB = Nothing
Set xlApp = Nothing
End Sub

然后你需要在按钮上添加一些代码：

Private Sub cmdSend_Click（）

'variables for the values we are getting now
Dim name As String, email As String, text As String

'more excel variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet


Set xlApp = New Excel.Application

xlApp.Visible = False

Set xlWB = xlApp.Workbooks.Open("PATH TO EXCEL FILE")

Set xlSheet = xlWB.Worksheets("sheet1")


'access the rowindex from the first column of the combobox
'use it for the Cells() as row
'column may be edited as needed
name = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 1).Value
email = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 2).Value
text = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 3).Value

'excel cleanup
Set xlSheet = Nothing

xlWB.Close False

xlApp.Quit

Set xlWB = Nothing
Set xlApp = Nothing

'print output to console
'instead of this, write your email
Debug.Print "mailto:" & email & " name:" & name & " text: " & text
End Sub

然后，如果我们打开表单，我们可以从值中选择：

如果我们点击按钮，它将打开excel并获取我们选择的项目的相关值。

Name5的输出如下所示：

顺便说一句，我的excel示例列表如下所示：

Answer 2

在OP使用我的原始代码和进一步澄清之后

编辑

按照以下“规则”

进行完整的重构代码

Option Explicit语句

这迫使你声明所有变量

但是这一点额外的工作可以让你更好地控制你的写作，减少调试和/或维护工作
主要的“超级”代码分成许多单个Sub / Funcs

这有助于
- 具有更易读和可维护的代码
- 让Userforms和Applications从任何UserForm代码中加载和卸载调用，这些代码只能处理其实际工作：收集信息

将其放在Outlook模块中：

Option Explicit

Sub email_DP2()

Dim mailData As Variant

mailData = GetMailDataFromExcel("C:\persons.xlsm", _
                                      "Module2.FetchData3", _
                                      "Sheet4", _
                                      "L")
If mailData = Empty Then Exit Sub

With CreateItem(0)
    .SentOnBehalfOfName = ""
    .Importance = olImportanceHigh
    .To = mailData(1)
    .Subject = mailData(0)
    .GetInspector.WordEditor.Range.collapse 1
    .Display
    .HTMLBody = mailData(2)
    '.Paste 'what are you pasting from?
End With

End Sub


'-------------------------------------------------------
' Excel handling Subs and Funcs
'-------------------------------------------
Function GetMailDataFromExcel(strFile As String, fetchingModule As String, strSheet As String, colStrng As String) As Variant
    Dim xlApp As Excel.Application
    Dim closeExcel As Boolean
    Dim namesRng As Excel.Range

    Set xlApp = GetExcel(closeExcel)

    If Not xlApp Is Nothing Then
        Set namesRng = GetExcelRange(xlApp, strFile, fetchingModule, strSheet, colStrng) 'this will get the names range from given column of given worksheet of given workbook
        With UserForm14
            If namesRng.Count = 1 Then
                .ComboBox1.AddItem namesRng.Value
            Else
                .ComboBox1.List = xlApp.Transpose(namesRng)
            End If
            .Show
            With .ComboBox1
                If .ListIndex > -1 Then GetMailDataFromExcel = Array(.Value, _
                                             namesRng.Offset(, 5).Cells(.ListIndex + 1, 1).Value, _
                                             namesRng.Offset(, 6).Cells(.ListIndex + 1, 1).Value)
            End With
        End With
        Unload UserForm14
        Set namesRng = Nothing
        ReleaseExcel xlApp, closeExcel
    End If

End Function


Function GetExcelRange(xlApp As Excel.Application, strFile As String, fetchingModule As String, strSheet As String, colStrng As String) As Excel.Range
    With xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
        xlApp.Run fetchingModule
        With .Worksheets(strSheet)
            Set GetExcelRange = .Columns(colStrng).Resize(.Cells(.Rows.Count, colStrng).End(xlUp).Row)
        End With
    End With
End Function


Function GetExcel(closeExcel As Boolean) As Excel.Application
    On Error Resume Next
    Set GetExcel = GetObject(, "Excel.Application")
    If GetExcel Is Nothing Then
        Set GetExcel = CreateObject("Excel.Application")
        closeExcel = True
    End If
    If GetExcel Is Nothing Then
        MsgBox "Couldn't instantiate Excel!", vbCritical
    End If
End Function


Sub ReleaseExcel(xlApp As Excel.Application, closeExcel As Boolean)
    If closeExcel Then xlApp.Quit
    Set xlApp = Nothing
End Sub
'-------------------------------------------------------

将其放在UserForm14代码窗格

中

Option Explicit

Private Sub btnOK_Click()
    Me.Hide
End Sub

Private Sub CancelButton_Click()
    Me.Hide
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        Me.Hide
    End If
End Sub

在后者中我

添加了Option Explicit声明

虽然不是绝对必要（没有变量使用但是“内置”），但它建立在良好的习惯上
添加了UserForm_QueryClose事件处理程序

处理可能的用户单击UserForm“关闭”按钮
删除了End声明

我总是知道使用它是一个坏习惯，最好坚持使用Exit Sub / Exit Function个（可能适当混合If.. Then.. Else块）以达到同样的效果而不会造成任何伤害

Answer 3

@ user3598756

我用你的代码制作了配置：

userform14代码：“

Private Sub btnOK_Click()
Me.Hide
End Sub
Private Sub CancelButton_Click()
 Me.Hide
 End
End Sub
Private Sub UserForm_Click()
End Sub

和功能代码：

    Sub email_DP2()
    Dim name As String, email As String, text As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim olInsp As Object
    Dim oRng As Object
    Dim StrBdB As String

        Dim xlApp As Object
        Dim sourceWB As Object
        Dim sourceWS As Object
        Set xlApp = CreateObject("Excel.Application")
        strFile = "C:\persons.xlsm" 
        Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
        Set sourceWH = sourceWB.Worksheets("Sheet4")
        sourceWH.Application.Run "Module2.FetchData3"

    Dim pickedName As String, emailAddress As String, emailText As String
    Dim namesRng As Range

    With sourceWH '<== change "myWorkbookName" and "Sheet4" to your needs
        Set namesRng = .Range("L1:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
    End With
    With UserForm14 ' change it to whatever name your actual UserForm has
        .ComboBox1.List = xlApp.Transpose(namesRng)
        .Show
        With ComboBox1
             pickedName = .Value
             emailAddress = namesRng.Offset(, 5).Cells(.ListIndex + 1, 1).Value
             emailText = namesRng.Offset(, 6).Cells(.ListIndex + 1, 1).Value
        End With
    End With
Unload UserForm14
         On Error Resume Next
         Set OutApp = GetObject(, "Outlook.Application")
         If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
         On Error GoTo 0
         Set OutMail = OutApp.CreateItem(0)
         With OutMail
             OutMail.SentOnBehalfOfName = ""
             .Importance = olImportanceHigh
             .To = emailAddress  
             .Subject = pickedName 
             Set olInsp = .GetInspector
             Set wdDoc = olInsp.WordEditor
             Set oRng = wdDoc.Range
             oRng.collapse 1
             .Display
             OutMail.HTMLBody = emailText 
             oRng.Paste
         End With
         Set OutMail = Nothing
         Set OutApp = Nothing
         Set olInsp = Nothing
         Set wdDoc = Nothing
         Set oRng = Nothing
    End Sub

它提供了行selectedName = .Value所需的对象 - 如果我消除了它将在行EmailAddress = namesRng.Offset给出相同的...我的东西是与ComboBox1的问题 - 如果我消除，它将生成电子邮件但没有添加to，subject和文本。

从excel列的下拉列表中选择电子邮件主题

3 个答案: