一下如何用VBA实现网络编程，比如实现发邮件的功能

Sub EMAIL()

Dim cm As Variant

Set cm = CreateObject("CDO.Message") '创建对象

cm.From = "ylmylm12@126.com" '设置发信人的邮箱

cm.To = "ylmylm12@126.com" '设置收信人的邮箱

cm.Subject = "主题:邮件发送试验" '设定邮件的主题

cm.TextBody = "宝坻一中信息中心/" '使用文本格式发送邮件

cm.HtmlBody = "123456789000" '使用html格式发送邮件

cm.AddAttachment "D:\张红\调号.xls"

stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址

With cm.Configuration.Fields

.Item(stUl & "smtpserver") = "smtp.126.com" 'SMTP服务器地址

.Item(stUl & "smtpserverport") = 25 'SMTP服务器端口

.Item(stUl & "sendusing") = 2 '发送端口

.Item(stUl & "smtpauthenticate") = 1 '

.Item(stUl & "sendusername") = "ylmylm12 " '发送方邮箱名称

.Item(stUl & "sendpassword") = "********" '发送方邮箱密码

.Update

End With

cm.Send '最后当然是执行发送了

Set cm = Nothing '发送成功后即时释放对象

End Sub

自己按说明改一下。

要从两个方面考虑：

1、如何把现有文档中的图片导出？这个代码片断可以参考一下：

Set ImageStream = CreateObject("ADODB.Stream")

With ImageStream

.Type = 1

.Open

.Write ActiveDocument.InlineShapes(1).Range.EnhMetaFileBits

.SaveToFile "d:\Temp\Output.bmp"

.Close

End With

Set ImageStream = Nothing

2、如何把已经到处的图片导入到新文档中？这个函数调用可以参考一下：

ActiveDocument.InlineShapes.AddPicture

如果还是不明白的话，请补充提问。

_____

补充：

请问楼主你运行那个代码片断得到的*完整*错误信息是什么？报错的时候，系统一般会把光标移动到出错的那行代码上，你看到的是哪一行代码出错呢？

我看你贴上来的代码应该是没有什么语法上的错误，“Exit For”的确是不应该要的，但那也不是语法错误啊。

仔细看了一下，原来的代码的确有些问题，这个是我现在用的，我一次只能发不超过15封邮件，否则邮件网关（单位自有邮件服务器）会阻止我。延迟发送是我加的，没有测试。

我下面的代码是在如下情况下使用（很有必要说清楚）。

就我自用来说。

首先，我有一个excel文件，其中存放的是的待发送人员的姓名以及邮件地址。

其次，我会将网络断开，使用word的邮件功能，并使用上述excel中的邮件地址，合并，并批量生成邮件。

之后，因为网络断开，本来要通过outlook发送的邮件，都会因为发送失败出现在发件箱中。出于方便 *** 作和手动控制发送节奏的目的，将发件箱中所有发送失败的邮件拷贝到草稿箱。

最后，重新连接网络，使用上述代码手动一次发个10封左右的邮件，我是发一次歇一会。发送邮件通过vba添加附件。（你所要求的延迟，是我临时加的，没有经过测试）如果加了延迟，你可以修改vba中，一次复制到发件箱邮件的个数，控制时间间隔。（也可以一次复制完毕，我出于测试的目的，第一次通常会用程序从草稿箱移动2个邮件发送，然后检查看有无错误，以免错误过大难以控制）

希望对你有帮助，附现在用的代码。

Option Explicit

'将草稿箱中的邮件发送出去

Const strAttachmentPath = "" '附件路径E:\办公\科研处\国家基金要点提示\2014自然基金模板及简明指南摘要.rar

Const intMailCount = 10 '单次发送邮件数

Sub subSendEmail()

'On Error Resume Next

Dim fld_OutBox AsOutlook.MAPIFolder

Dim objItemsAs Outlook.Items

Dim myItem As Object

Dim myItems() As Object

Dim iIndex As Integer '延迟技术器

Dim intervalMinute As Integer '延迟分钟数

Dim objMail As Outlook.MailItem

iIndex = 1

Dim n As Integer

If MsgBox("附件:" &strAttachmentPath &vbCrLf &"单次发送邮件数:" &intMailCount &vbCrLf &"以上信息正确与否？", vbOKCancel) <>vbOK Then

Exit Sub

End If

'获得发件箱

Set fld_OutBox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)

Set objItems = fld_OutBox.Items

If fld_OutBox.Items.Count = 0 Then

'如果发件箱邮件数为0从草稿箱中移动邮件

'从草稿箱中移动若干邮件到发件箱

funMoveMailToOutBox intMailCount

End If

'如果发件箱存在对象，对其中的邮件执行发送

If objItems.Count >0 Then

For Each objMail In objItems

If (objMail.Class = 43) Then

'发送邮件

If (strAttachmentPath <>"") Then

'存在附件路径,添加附件

objMail.Attachments.AddTrim(strAttachmentPath), olByValue, 1

End If

'延迟发送

'iIndex = iIndex + 1

'objMail.DeferredDeliveryTime =DateAdd("n", iIndex * intervalMinute, Now)

objMail.Send

End If

Next

End If

End Sub

Function funMoveMailToOutBox(ByVal numEmailAs Integer) As Boolean

'移动numEmail指定的邮件数从draft到outBox

'On Error Resume Next

Dim fld_OutBox AsOutlook.MAPIFolder

Dim fld_DraftsAsOutlook.MAPIFolder

Dim objItemsDrafts AsOutlook.Items

Dim objMail As Outlook.MailItem

Dim n As Integer

n= 0

'获得发件箱对象

Set fld_OutBox =Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)

'获得草稿箱对象

Set fld_Drafts =Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts)

Set objItemsDrafts = fld_Drafts.Items

'按照numEmail指定的数值移动邮件

While (objItemsDrafts.Count >0) And (n <numEmail)

'如果草稿箱不为空

Set fld_Drafts =Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts)

Set objItemsDrafts = fld_Drafts.Items

Set objMail = objItemsDrafts.GetFirst()

If (objMail.Class = 43) Then

objMail.Move fld_OutBox

Else

Exit Function

End If

n = n + 1

Wend

End Function

---