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

我有电子邮件的代码,我想连接到一个Excel中的列。 当macros被触发时,应该出现一个下拉菜单,这样我可以根据Excel中的列表select如何发送电子邮件。 该列表是从其他excel生成的,它可以有2个全名或40个全名。 该列表在表4中,名称在列L中,电子邮件地址在列Q中,并且列P中的文本。如果从下拉列表中selectL2中的名称,则应该从Q2中select电子邮件地址,名称从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 

和combobox:

 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 

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

这里遵循一个完整的重构代码,按照以下“规则”

  • Option Explicit语句

    这迫使你声明所有的variables

    但是这个小小的额外工作却能让您更好地控制您的写作,减lessdebugging和/或维护工作

  • 主要的“巨型”代码分解成许多单独的Sub / Funcs

    这有助于

    • 有更可读和可维护的代码

    • 保持用户表单和应用程序加载和卸载任何用户窗体代码,而这些代码只能照顾其实际工作:收集信息

将其放置在您的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语句

    虽然不是严格必要的(没有variables的使用,但“内置”的),它build立在一个好习惯

  • 添加了一个UserForm_QueryClose事件处理程序

    处理可能的用户单击UserForm“closures”button

  • 擦除了End语句

    我总是学会使用它的坏习惯,并且更好地坚持Exit Sub / Exit Function (可能适当地混合If.. Then.. Else块)以达到相同的效果而没有任何伤害

要将Outlook连接到Excel,首先必须添加对“Microsoft Excel XX对象库”的引用,其中XX是一些版本号(Extras-> References)

然后创build一个用户窗体,我的看起来像这样: 例如用户表单

请注意,我的combobox有2列(第一个宽度为0,所以它是不可见的)

然后,当您加载窗体时,添加代码以打开一个Excel实例并加载值的combobox以从中select:

 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 

然后你需要添加一些代码到button:

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 

那么,如果我们打开表单,我们可以从值中select: 选择例子

如果我们再点击button,就会打开excel并获取我们所选项目的相关值。

Name5的输出如下所示: 控制台输出

顺便说一下,我的Excel示例列表如下所示:

exel示例列表

@ user3598756

我用你的代码做了configuration:

userform14代码:“

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

在这里输入图像说明

和function码:

  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 

它提供了对象所需的线pickName = .Value – 如果我消除线,它会给在线emailAddress = namesRng.Offset …我用With ComboBox1的问题 – 如果我消除,它会生成一个电子邮件但没有to,主题和文字添加到它。