[已解决]用VBA代码解决发工资条邮件的问题！

过江龙

各位大侠，因本人EXCEL水平实在有限，恳请哪位能帮帮我，不甚感激了。我的要求是：在完成工资条分列后，根据最后一列的邮件地址，直接在EXCEL里将邮件分别向该职工发出，而不通过WORD邮件合并，是按正文形式而不是附件形式。不知道我的要求是不是太高了，不过真的希望有人能帮帮我，谢谢了！ I1u6AVPq.rar (2.21 KB, 下载次数: 58)

2010-6-13 12:21 上传

点击文件名下载附件
用VBA代码解决发工资条邮件的问题！

最佳答案

月排行榜 / 总排行榜

上清宫主

2010-6-18 11:36

[em06][em06][em06]

不得已，刚给你注册个126的邮箱：vbaemail@126.com,密码vbaemail123,改好后的代码如下：

Sub EMAIL()
Dim cm As Variant, ar()
Set cm = CreateObject("CDO.Message") '创建对象

cm.From = "vbaemail@126.com"     '设置发信人的邮箱，请必须改动

ar = Range("a1:e" & [a65536].End(xlUp).Row).Value
stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址

cm.Subject = "主题:邮件发送试验" '设定邮件的主题，按你的需要改动

With cm.Configuration.Fields
    .Item(stUl & "smtpserver") = "smtp.126.com"     '126的SMTP服务器地址，发信人如果用的不是126的邮箱，请改此处
   
   
    .Item(stUl & "smtpserverport") = 25                  'SMTP服务器端口
    .Item(stUl & "sendusing") = 2                        '发送端口
    .Item(stUl & "smtpauthenticate") = 1                 '
   
   
    .Item(stUl & "sendusername") = "vbaemail"     '发送方邮箱名称，必须改来与前边一至
    .Item(stUl & "sendpassword") = "vbaemail123"  '发送方邮箱密码，必须改来与前边一至的邮箱密码
   
   
    For i% = 2 To UBound(ar)
      stm$ = ""
      For j% = 1 To 4
         stm = stm & ar(1, j) & ":" & ar(i, j) & "      "
      Next
      stm = Trim(stm)
      cm.To = ar(i, 5) & "@qq.com" '设置收信人的邮箱
      cm.HtmlBody = stm     '使用html格式发送邮件
      .Update
      cm.Send '最后当然是执行发送了
    Next
End With
Set cm = Nothing
End Sub

工作表中的QQ号就该你该改了哟

跳转到最佳答案楼层

htcaiwuke

期待答案

EPP

以下摘录自随书光盘中的一段代码（非原创，可些我不会，但可能对你有所帮助）：

Sub SendTest()
    SendMail "xfwen1973@gmail.com", "xfwen@21cn.com", "hello", _
      "test auto send email", "d:\try.txt"
End Sub
Public Sub SendMail1、(strTo As String, strCC As String, strSubject _
  As String, strBody As String, Optional strAttach As String)
    Dim otlk As Outlook.Application
    Dim mailitem As Outlook.mailitem
    On Error GoTo errHandle
    Set otlk = New Outlook.Application
    Set mailitem = otlk.CreateItem(olMailItem)
    With mailitem
        .To = strTo
        .CC = strCC
        .Importance = olImportanceHigh
        .Subject = strSubject
        .Body = strBody
        If Len(strAttach) <> 0 Then .Attachments.Add strAttach
        .Send
    End With
    Do Until mailitem.Sent = True
        DoEvents
    Loop
errHandle:
    otlk.Quit
    Set otlk = Nothing
End Sub
Sub ListAllFolders(objFolder As Outlook.MAPIFolder)
    Dim mItem As Outlook.mailitem
    Dim objSubFolder As Outlook.MAPIFolder
    Dim strSub As String, strSender As String
    Dim strCC As String, strBody As String
    For Each mItem In objFolder.Items
        If mItem.UnRead = True Then
            strSub = mItem.Subject
            strSender = mItem.SenderEmailAddress
            strCC = mItem.CC
            strBody = mItem.HTMLBody
            MsgBox "发送者：" & strSender & vbCrLf _
                & "CC：" & strCC & vbCrLf _
                & "主题：" & strSub & vbCrLf _
                & "主体：" & strBody
        End If
    Next
    For Each objSubFolder In objFolder.Folders
        ListAllFolders objSubFolder
    Next
    Set mItem = Nothing
End Sub
Sub ListUnReadMail()
    Dim otlk As Outlook.Application
    Dim nmspc As Outlook.Namespace
    Dim mlItem As Outlook.mailitem
    Dim objFolder As Outlook.MAPIFolder
    On Error GoTo errHandle
    Set otlk = New Outlook.Application
    Set nmspc = otlk.GetNamespace("MAPI")
    Set objFolder = nmspc.GetDefaultFolder(olFolderInbox)
    ListAllFolders objFolder
errHandle:
    otlk.Quit
    Set otlk = Nothing
    Set nmspc = Nothing
    Set objFolder = Nothing
End Sub

wayy

楼上的这个好像也是以附件形式，不是正文行式吧

BAIXINGR

期待答案

木文

学习.

nichangdong

等待学习

开辆小富康

用OUTLOOK？九年没用OUTLOOK了。

上清宫主

利用几个都可办到，到网上找找，很多的

过江龙

请楼上的跟我一个地址，谢谢！