vba_email_send

于 2021-09-17 14:43:55 发布
阅读量290 收藏
点赞数
分类专栏： VBA 文章标签： vba
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/fuchouqiong/article/details/120331854
版权 
Sub SendEM()

If [a1] = "" And [a2] = "" Then
 Columns("A:A").Delete
 End If
 
On Error Resume Next

ActiveSheet.Name = "1-20 Email Address"

'SHANDIAO ssc.krexportdocs@cma-cgm.com 无效公邮



For X1 = 2 To Sheets("1-20 Email Address").Range("F65536").End(xlUp).ROW

If Sheets("1-20 Email Address").Cells(X1, "F") = "ssc.krexportdocs@cma-cgm.com" Then
Sheets("1-20 Email Address").Cells(X1, "F").ClearContents

End If
Next X1

For X2 = 2 To Sheets("1-20 Email Address").Range("G65536").End(xlUp).ROW

If Sheets("1-20 Email Address").Cells(X2, "G") = "ssc.krexportdocs@cma-cgm.com" Then
Sheets("1-20 Email Address").Cells(X2, "G").ClearContents

End If
Next X2

Dim dic

Set dic = CreateObject("scripting.dictionary")

For x = 2 To Sheets("1-20 Email Address").Range("a65536").End(xlUp).ROW


dic(Sheets("1-20 Email Address").Cells(x, "a").Value) = dic(Sheets("1-20 Email Address").Cells(x, "a").Value) & Sheets("1-20 Email Address").Cells(x, "f").Value & ";"

Next x



Sheets("1-20 Email Address").Range("h2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets("1-20 Email Address").Range("i2").Resize(dic.Count) = Application.Transpose(dic.Items)



For Y = 2 To Sheets("1-20 Email Address").Range("h65536").End(xlUp).ROW

Sheets("1-20 Email Address").Cells(k + 2, "j") = Sheets("Page1_1").Range("A:A").Find(Sheets("1-20 Email Address").Cells(Y, "h")).Offset(0, 9).Value
Sheets("1-20 Email Address").Cells(k + 2, "k") = Sheets("Page1_1").Range("K:K").Find(Sheets("1-20 Email Address").Cells(Y, "h").Value).Offset(0, 4).Value

k = k + 1

Next Y

Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "Missing CNEE's email address for BL#"
subjecttext1 = "    *Arrival-Notice Sending Purpose*    ETA:"
subjecttext2 = "   DPcode:"
bodytext = "Dear POL Colleague,"
bodytext1 = "Please provide CEE's email address for sending AN, thanks."
bodytext2 = "BL:"



'kaishixunhuan

For i = 2 To Sheets("1-20 Email Address").Range("H65536").End(xlUp).ROW

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets("1-20 Email Address").Cells(i, "H")
ETA = Sheets("1-20 Email Address").Cells(i, "J")
T = Sheets("1-20 Email Address").Cells(i, "I")
DPc = Sheets("1-20 Email Address").Cells(i, "k")


With outlookitem

.Display


.To = T
.CC = "gsc.northchinaimport@cma-cgm.com;bob.fu@apl.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing

End Sub




Sub AMEmailSend()

Dim i, BL, CN, PC, PN, SD, POL As String
SD = "bob.fu@apl.com"


Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "LARA US-NO EMAIL FOR AN BL:"
bodytext = "APL.Customer.Care,"
bodytext1 = "Please kindly provide email address of "
bodytext2 = " for sending AN & invoice, and also contact customer the AN sent failed due to no email, thanks."
bodytext3 = "BL:"
bodytext4 = "Partner Code:"
bodytext5 = "Contact Name: "
bodytext6 = "POL:"




'kaishixunhuan

For i = 2 To Range("b65536").End(xlUp).ROW


receiver = "APL.Customer.Care;"

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Cells(i, "b")
CN = Cells(i, "i")
PC = Cells(i, "j")
PN = Cells(i, "k")
POL = Cells(i, "d")




With outlookitem

.Display

.To = receiver
.CC = SD
.Subject = subjecttext & BL
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & CN & bodytext2 & "<br/><br/>" & bodytext3 & BL & "<br/><br/>" & bodytext6 & POL & "<br/><br/>" & bodytext4 & PC & "<br/><br/>" & bodytext5 & PN & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing

End Sub


Sub NoAnNoEmial()

On Error Resume Next
ActiveSheet.Name = "1-20 Email Address"

Dim dic
Set dic = CreateObject("scripting.dictionary")

For x = 2 To Sheets("1-20 Email Address").Range("a65536").End(xlUp).ROW


dic(Sheets("1-20 Email Address").Cells(x, "a").Value) = dic(Sheets("1-20 Email Address").Cells(x, "a").Value) & Sheets("1-20 Email Address").Cells(x, "f").Value & ";"

Next x


Sheets("1-20 Email Address").Range("h2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets("1-20 Email Address").Range("M2").Resize(dic.Count) = Application.Transpose(dic.Items)

For Y = 2 To Sheets("1-20 Email Address").Range("h65536").End(xlUp).ROW

Sheets("1-20 Email Address").Cells(k + 2, "I") = Sheets("Page1_1").Range("B:B").Find(Sheets("1-20 Email Address").Cells(Y, "h")).Offset(0, 4).Value
Sheets("1-20 Email Address").Cells(k + 2, "J") = Sheets("Page1_1").Range("B:B").Find(Sheets("1-20 Email Address").Cells(Y, "h").Value).Offset(0, 6).Value
Sheets("1-20 Email Address").Cells(k + 2, "L") = Date + 3

k = k + 1

Next Y


'查找code

    Set conn = CreateObject("adodb.connection")
    Set rst = CreateObject("ADODB.recordset")
 
    conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & "\\Cngscapl-spf302\IB\AM Team\01 IB - LARA\15 Personal Folder\bOB\SHA Email Ask Atuo\DP Code.xlsx"
    
  
  
  rst.Open "select *  from [Sheet1$]", conn, adOpenKeyset, adLockOptimistic
  
    On Error Resume Next
For z = 2 To Sheets("1-20 Email Address").Range("h65536").End(xlUp).ROW

If Len(Sheets("1-20 Email Address").Cells(z, "I")) > 6 Then

Cells(z, "K") = rst.Fields(Sheets("1-20 Email Address").Cells(z, "J") & Right(Sheets("1-20 Email Address").Cells(z, "I").Value, 2))

Else

Cells(z, "K") = rst.Fields(Sheets("1-20 Email Address").Cells(z, "J") & "MA")


End If

Next z
  On Error GoTo 0



Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "Missing CNEE's email address for BL#"
subjecttext1 = "    *Arrival-Notice Sending Purpose*    ETA:"
subjecttext2 = "   DPcode:"
bodytext = "Dear POL Colleague,"
bodytext1 = "Please provide CEE's email address for sending AN, thanks."
bodytext2 = "BL:"



'kaishixunhuan

For i = 2 To Sheets("1-20 Email Address").Range("H65536").End(xlUp).ROW

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets("1-20 Email Address").Cells(i, "H")
ETA = Sheets("1-20 Email Address").Cells(i, "l")
T = Sheets("1-20 Email Address").Cells(i, "M")
DPc = Sheets("1-20 Email Address").Cells(i, "K")


With outlookitem

.Display


.To = T
.CC = "GSC.BFU@cma-cgm.com;gsc.northchinaimport@cma-cgm.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing

End Sub



Sub email_s()


Call FINDStatus

'SHANDIAO ssc.krexportdocs@cma-cgm.com 无效公邮



For X1 = 2 To Sheets(1).Range("a65536").End(xlUp).ROW

If LCase(Sheets(1).Cells(X1, "g").Value) = "ssc.krexportdocs@cma-cgm.com" Or LCase(Sheets(1).Cells(X1, "g").Value) = "twn.booking@cma-cgm.com" _
Or LCase(Sheets(1).Cells(X1, "g").Value) = "ssc.indexportdocs@cma-cgm.com" Then 'ssc.indexportdocs@cma-cgm.com
Sheets(1).Cells(X1, "g").ClearContents

End If
Next X1

For X2 = 2 To Sheets(1).Range("a65536").End(xlUp).ROW

If LCase(Sheets(1).Cells(X2, "h").Value) = "ssc.krexportdocs@cma-cgm.com" Or LCase(Sheets(1).Cells(X2, "h").Value) = "twn.booking@cma-cgm.com" _
Or LCase(Sheets(1).Cells(X2, "h").Value) = "ssc.indexportdocs@cma-cgm.com" Then
Sheets(1).Cells(X2, "h").ClearContents

End If
Next X2


Dim dic

Set dic = CreateObject("scripting.dictionary")

For x = 2 To Sheets(1).Range("a65536").End(xlUp).ROW


dic(Sheets(1).Cells(x, "a").Value) = dic(Sheets(1).Cells(x, "a").Value) & Sheets(1).Cells(x, "g").Value & ";"

Next x



Sheets(1).Range("I2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets(1).Range("J2").Resize(dic.Count) = Application.Transpose(dic.Items)


Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "Missing CNEE's email address for BL#"
subjecttext1 = "    *Arrival-Notice Sending Purpose*    ETA:"
subjecttext2 = "   DPcode:"
bodytext = "Dear POL Colleague,"
bodytext1 = "Please provide CEE's email address for sending AN, thanks."
bodytext2 = "BL:"



'kaishixunhuan

For i = 2 To Sheets(1).Range("A65536").End(xlUp).ROW

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets(1).Cells(i, "I")
ETA = Sheets(1).Cells(i, "F")
T = Sheets(1).Cells(i, "J")
DPc = Sheets(1).Cells(i, "E")


With outlookitem

.Display


.To = T
.CC = "gsc.northchinaimport@cma-cgm.com;bob.fu@apl.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing


End Sub

fuchouqiong
关注
  • 0
    点赞
  • 踩
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
专栏目录
word合并邮件无法发送html,Word邮件合并批量发送带附件的邮件
weixin_33091939的博客
06-27 2074
应张老师的需求，修改制作了一个可以批量发送带附件的电子邮件VBA。目的：给N多人发送电子邮件，而不是抄送模式，并带有对方的称谓。实现：用到Word的邮件合并功能，以及调用Outlook发送邮件。不过VBA我不太懂，只能用现有的改，有点繁琐。步骤：1.Word建立一个表，第一列为表头，下面为每个人的记录，从第四列开始为附件列，需要加几个附件，就添加几个列，可以留空，像第五列一样：NameTitleE...
使用Excel和OutLook实现自动发送邮件
热门推荐
paul50060049的专栏
01-25 7万+
问题的产生 我们在平时工作中可能会遇到要批量发送邮件的工作，例如财务部根据每个人的工资情况发放工资条到个人的邮箱，因为邮件因人而异，所以需要完成大量而细致的工作，工作繁琐，重复劳动多，非常适合批量发送。因此研究如何利用电子表格建立数据，利用OutLook来发送这些数据，要求发送具有表格格式的工资条。 使用工具 Excel及VBA技术 OutLook 数据准备 新建一个工作簿，保
activex控件 新对象 ocx 初始化_Excel教学VBA知识，ActiveX控件介绍，命令按钮常用属性与代码...
weixin_39792472的博客
11-02 549
在前面的课程里，咱们给大家详细的介绍过标签控件，文本框控件，窗体控件，这次咱们给大家说一下VBA的另外常用控件，命令按钮(Commandbutton)控件．命令按钮控件的实质作用其实就是一种VBA代码触发的起动机制,即通过以左键单击的方式来执行相关的代码.在这里所说的起动机制是单击,而单击也是最常见的方法(或者叫做动作),但并不局限于单击,双击也是可以的,鼠标右键的单击亦然,但最常见的是左键的单击...
学以致用——使用VBA发送邮件（Send Email with VBA）
预见未来to50的专栏
06-14 3万+
第一次使用VBA自动发送邮件，酷！示例代码：Sub 邮件发送() Dim cm As New CDO.Message 'Set cm = CreateObject("CDO.Message") '创建对象 '引用路径：C:\Windows\system32\cdosys.dll cm.From = "1234567@qq.com" '设置发信人的邮箱" cm.To = "649725266@qq....
在VBA中实现通过Outlook发送邮件
weixin_33734785的博客
05-08 619
1.添加引用Microsoft Outlook 11.0 Object Library。（这里用的是Microsoft Outlook 2003）   2.定义发送邮件过程。 Public Sub SendEmail(Receiver As String, SubjectText As String, BodyText As String, AttachedObj...
VBA_SQL.rar_vba_SQL
09-19
一个构造SQL语句的vba程序（含源码），适合初学者学习。
PSR.zip_VBa_access vba_psr
09-24
用于记录生产线上发生故障的数据库信息系统，VBA在access中的应用
outlooksaveattchenment.rar_Email客户端_VBA_
08-12
保存outlook 附件 保存outlook 附件 保存outlook 附件
VBA.rar_VBa_vba help
09-21
关于数据库考试的VBA总结，很实用有帮助的
vba_ExcelVBA_
10-02
删除excel表中，指定列中某行为空值的行。
Outlook 发送 查找邮件
码农, 农民工的程序人生
06-19 3682
对outlook的操作。对于用微软提供的Lib来发并查找已经打开的邮件大家可能并不陌生，但是如何从我们的Outlook[邮件存在但是没有单独打开]里查找我们想要的Mail怎么办？如何确定我们点了发送按钮？类库里似乎没有提供相应的解决办法。    using OutLook = Microsoft.Office.Interop.Outlook;   1.      Send mail:普通的
VBA发送email
Rainbow
11-06 1874
通过VBA代码发送邮件 Sub SendEmail() Dim App As Object Dim Email As Object Set App = CreateObject("Outlook.Application") Set Email = App.CreateItem(0) With Email .Subject = "M...
VBA使用Outlook自动发送邮件
Smilecoc的博客
06-28 1万+
利用VBA使用Outlook自动发送邮件，代码及注释如下： Sub send_mail() Dim ObjOL As Object Dim itmNewMail As Outlook.MailItem Dim mailaddress As String '引用Microsoft Outlook 对象 Set ObjOL = CreateObject("Outlook.Application") Set itmNewMail = ObjOL.CreateItem(olMailItem) '******输入
操作系统期末复习笔记！
06-13
操作系统期末复习笔记
pyzmq-22.0.0-cp38-cp38-manylinux2010_i686.whl
06-13
Python库是一组预先编写的代码模块，旨在帮助开发者实现特定的编程任务，无需从零开始编写代码。这些库可以包括各种功能，如数学运算、文件操作、数据分析和网络编程等。Python社区提供了大量的第三方库，如NumPy、Pandas和Requests，极大地丰富了Python的应用领域，从数据科学到Web开发。Python库的丰富性是Python成为最受欢迎的编程语言之一的关键原因之一。这些库不仅为初学者提供了快速入门的途径，而且为经验丰富的开发者提供了强大的工具，以高效率、高质量地完成复杂任务。例如，Matplotlib和Seaborn库在数据可视化领域内非常受欢迎，它们提供了广泛的工具和技术，可以创建高度定制化的图表和图形，帮助数据科学家和分析师在数据探索和结果展示中更有效地传达信息。
pyzmq-25.1.1b2-cp37-cp37m-win_amd64.whl
最新发布
06-13
Python库是一组预先编写的代码模块，旨在帮助开发者实现特定的编程任务，无需从零开始编写代码。这些库可以包括各种功能，如数学运算、文件操作、数据分析和网络编程等。Python社区提供了大量的第三方库，如NumPy、Pandas和Requests，极大地丰富了Python的应用领域，从数据科学到Web开发。Python库的丰富性是Python成为最受欢迎的编程语言之一的关键原因之一。这些库不仅为初学者提供了快速入门的途径，而且为经验丰富的开发者提供了强大的工具，以高效率、高质量地完成复杂任务。例如，Matplotlib和Seaborn库在数据可视化领域内非常受欢迎，它们提供了广泛的工具和技术，可以创建高度定制化的图表和图形，帮助数据科学家和分析师在数据探索和结果展示中更有效地传达信息。
香港某银行-CRYPTO业务资料
06-13
香港某银行--CRYPTO业务资料
基于判断发送邮件VBA代码
05-10
.Send End With MsgBox "Email sent successfully!", vbInformation Else ' Email address is not valid MsgBox "Invalid email address!", vbCritical End If Set OutlookMail = Nothing Set OutlookApp...

“相关推荐”对你有帮助么？

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值