Excel VBA - 发送Outlook电子邮件

问题描述：

在单元格A中，我有名称，例如，约翰史密斯
在细胞B我有一个标准 - 到期/未到期。
我需要以某种方式修改下面的代码执行以下操作：
生成从小区A邮件，格式[email protected] 然后发送了电子邮件提醒，但只有唯一的电子邮件在一个电子邮件。到目前为止，这是我：Excel VBA - 发送Outlook电子邮件

Sub SendEmail() 

    Dim OutlookApp As Outlook.Application 
    Dim MItem As Outlook.MailItem 
    Dim cell As Range 
    Dim Subj As String 
    Dim EmailAddr As String 
    Dim Recipient As String 
    Dim Msg As String 

    'Create Outlook object 
    Set OutlookApp = New Outlook.Application 

    'Loop through the rows 
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible) 
     If cell.Value Like "*@*" And _ 
      LCase(Cells(cell.Row, "B").Value) = "Due" _ 
      Then 
      EmailAddr = EmailAddr & ";" & cell.Value 
     End If 
    Next 

    Msg = "Please review the following message." 
    Subj = "This is the Subject Field" 

    'Create Mail Item and view before sending 
    Set MItem = OutlookApp.CreateItem(olMailItem) 
    With MItem 
     .To = EmailAddr 
     .Subject = Subj 
     .Body = Msg 
     .Display 
    End With 

End Sub

我无法得到更进一步，很遗憾。任何人都可以帮助我吗？

除了@MacroMan引发的问题，你的代码看起来不错。究竟是什么问题。你没有说明你的**没有工作。 –

在A列中，我有一个姓名和姓氏列表，我不知道如何将循环（即John Smith转换为[email protected]）并发送到一封电子邮件中。此外，我以某种方式需要过滤掉并发送给唯一的电子邮件，有时人重复... – warfo09

是每个公司的名称相同吗？或者是在另一个单元格或其他地方定义的？ –

答

全范围的答案在这里。我在我添加/编辑的现有代码的各个方面发表了评论。

Sub SendEmail() 

    Dim OutlookApp As Outlook.Application 
    Dim MItem As Outlook.MailItem 
    Dim cell As Range 
    Dim Subj As String 
    Dim EmailAddr As String 
    Dim Recipient As String 
    Dim Msg As String 

    'Create Outlook object 
    Set OutlookApp = New Outlook.Application 

    'Loop through the rows 
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible) 
     If cell.Value Like "*@*" And _ 
      LCase(Cells(cell.Row, "B").Value) = "due" Then 
      'first build email address 
      EmailAddr = LCase$(Replace(cell.Value, " ", ".")) & "@company.com" 
      'then check if it is in Recipient List build, if not, add it, otherwise ignore 
      If InStr(1, Recipient, EmailAddr) = 0 Then Recipient = Recipient & ";" & EmailAddr 
     End If 
    Next 

    Recipient = Mid(Recipient, 2) 'get rid of leaing ";" 

    Msg = "Please review the following message." 
    Subj = "This is the Subject Field" 

    'Create Mail Item and view before sending 
    Set MItem = OutlookApp.CreateItem(olMailItem) 
    With MItem 
     .To = Recipient 'full recipient list 
     .Subject = Subj 
     .Body = Msg 
     .Display 
    End With 

End Sub

谢谢，它对你有用吗？我的Outlook电子邮件附带空的“收件人：”字段使用此方法.... – warfo09

好吧，我发现这个问题。如果cell.Value像“* @ *”和_ 这不适用了。 – warfo09

对不起，我遇到了您的方法问题...出于某种原因，我仍然收到重复的电子邮件...？ – warfo09

答

LCase(Cells(cell.Row, "B").Value) = "Due"

这将始终返回false，因为LCase()整个字符串转换为大号奥尔情况下和你比较它"Due"它有一个大写"D"

要么，改变你的比较字符串"due"：

LCase(Cells(cell.Row, "B").Value) = "due"

或者（不REC ommended，但是示出了教育的目的）您的字符串操作更改为正确的大小写：

StrConv(Cells(cell.Row, "B").Value, vbProperCase) = "Due"

谢谢，无论如何，我可以转换“约翰史密斯”为“[email protected]”EmailAddr在单元格A？ – warfo09

'emailAdd = LCase $（替换（cell.value，“”，“。”）和“@ company.com”） –

答

也许这样吗？

Sub SendEmail() 

Dim OutlookApp As Outlook.Application 
Dim MItem As Outlook.MailItem 
Dim cell As Range 
Dim Subj As String 
Dim EmailAddr As String 
Dim Recipient As String 
Dim Msg As String 

'Create Outlook object 
Set OutlookApp = New Outlook.Application 

'Loop through the rows 
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible) 
    If cell.Value Like "*@*" And _ 
     LCase(Cells(cell.Row, "B").Value) = "due" _ 
     Then 
     EmailAddr = cell.Value 
    End If 


    Msg = "Please review the following message." 
    Subj = "This is the Subject Field" 

    'Create Mail Item and view before sending 
    Set MItem = OutlookApp.CreateItem(olMailItem) 
    With MItem 
     .To = EmailAddr 
     .Subject = Subj 
     .Body = Msg 
     .Display 
    End With 

    EmailAddr = "" 

Next 

End Sub

我所做的是：附上的MailItem进入循环的建立，并显示邮件后

另外，我更新了宏满他的建议代码重置变量EMAILADDR。

Excel VBA - 发送Outlook电子邮件

相关推荐