改进excel_vba_群发邮件（改进一些,保证可以运行）

 

Private Sub CommandButton1_Click()

' MailToEveryone Macro
' 把工资条通过邮件发给公司的每个人
'
' 快捷键: Ctrl+Shift+E

'要能正确发送并需要对Microseft Outlook进行有效配置
On Error Resume Next
Dim rowCount, endRowNo As Long
Dim objOutlook As New Outlook.Application
Dim objMail As MailItem
Dim CurrentMonth As String
'Dim reg As New VBScript_RegExp_55.RegExp

CurrentMonth = TextBox1.Text
If CurrentMonth = Format(Date, "yymm") & "条" Then

'激活名为"0910条"的sheet
Sheets.Item(CurrentMonth).Activate

'取得当前工作表使用的行数
endRowNo = ActiveSheet.UsedRange.Rows.Count - 1

 

'创建objOutlook应用程序对象
Set objOutlook = New Outlook.Application
Dim body As String
'开始循环发送电子邮件，比如从第一行开始，前十一行是要发送的内容
For rowCount = 1 To endRowNo Step 3
    
     '创建一个objMail为一个邮件对象
     Set objMail = objOutlook.CreateItem(olMailItem)
     With objMail
    ' .FormDescription = "[email protected]"
     .To = Cells(rowCount + 1, 21).Value
     .Subject = Format(DateAdd("m", -1, Date), "yy年m月") & "工资条"
    
    ' body = Cells(rowCount, 1).Value & Cells(rowCount, 2).Value & Cells(rowCount, 3).Value & Cells(rowCount, 4).Value & Cells(rowCount, 5).Value & Cells(rowCount, 6).Value & _
    ' Cells(rowCount, 7).Value & Cells(rowCount, 8).Value & Cells(rowCount, 9).Value & Cells(rowCount, 10).Value & Cells(rowCount, 11).Value & vbNewLine & _
    ' Cells(rowCount + 1, 1).Value & Cells(rowCount + 1, 2).Value & Cells(rowCount + 1, 3).Value & Cells(rowCount + 1, 4).Value & Cells(rowCount + 1, 5).Value & Cells(rowCount + 1, 6).Value & _
    ' Cells(rowCount + 1, 7).Value & Cells(rowCount + 1, 8).Value & Cells(rowCount + 1, 9).Value & Cells(rowCount + 1, 10).Value & Cells(rowCount + 1, 11).Value & vbNewLine
     
    ' body = Range(Cells(rowCount, 1), Cells(rowCount + 1, 23)).Copy()
     
      body = Cells(rowCount, 1).Value & "：" & Cells(rowCount + 1, 1).Value & vbNewLine & _
      Cells(rowCount, 2).Value & "：" & Cells(rowCount + 1, 2).Value & vbNewLine & _
      Cells(rowCount, 3).Value & "：" & Cells(rowCount + 1, 3).Value & vbNewLine & _
      Cells(rowCount, 4).Value & "：" & Cells(rowCount + 1, 4).Value & vbNewLine & _
      Cells(rowCount, 5).Value & "：" & Cells(rowCount + 1, 5).Value & vbNewLine & _
      Cells(rowCount, 6).Value & "：" & Cells(rowCount + 1, 6).Value & vbNewLine & _
      Cells(rowCount, 7).Value & "：" & Cells(rowCount + 1, 7).Value & vbNewLine & _
      Cells(rowCount, 8).Value & "：" & Cells(rowCount + 1, 8).Value & vbNewLine & _
      Cells(rowCount, 9).Value & "：" & Cells(rowCount + 1, 9).Value & vbNewLine & _
      Cells(rowCount, 10).Value & "：" & Cells(rowCount + 1, 10).Value & vbNewLine & _
      Cells(rowCount, 11).Value & "：" & Cells(rowCount + 1, 11).Value & vbNewLine & _
      Cells(rowCount, 12).Value & "：" & Cells(rowCount + 1, 12).Value & vbNewLine & _
      Cells(rowCount, 13).Value & "：" & Cells(rowCount + 1, 13).Value & vbNewLine & _
      Cells(rowCount, 14).Value & "：" & Cells(rowCount + 1, 14).Value & vbNewLine & _
      Cells(rowCount, 15).Value & "：" & Cells(rowCount + 1, 15).Value & vbNewLine & _
      Cells(rowCount, 16).Value & "：" & Cells(rowCount + 1, 16).Value & vbNewLine & _
      Cells(rowCount, 17).Value & "：" & Cells(rowCount + 1, 17).Value & vbNewLine & _
      Cells(rowCount, 18).Value & "：" & Cells(rowCount + 1, 18).Value & vbNewLine & _
      Cells(rowCount, 19).Value & "：" & Cells(rowCount + 1, 19).Value & vbNewLine & _
      Cells(rowCount, 20).Value & "：" & Cells(rowCount + 1, 20).Value & vbNewLine
     .body = body
     .Send
     End With
     Set objMail = Nothing
Next rowCount

Set objOutlook = Nothing

MsgBox "邮件已经全部发送完毕"
Else

MsgBox "您输入有误，请重新输入"
End If

End Sub