VBA / 使用Excel VBA批次寄信 2

VBA / 使用Excel VBA批次寄信 2

Post Views: 190

VBA / 使用Excel VBA批次寄信 是使用 CDO.Message物件

但其實也可以透過 Outlook.Application 來使用 Outlook功能

引用 Outlook.Application 建立 olMailItem 之後

後續的程式碼基本上

跟 VBA / 在Outlook使用VBA批次寄信  VBA / 在Outlook使用VBA批次寄信2 是相同的

excel工作表的格式

整體程式碼

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
 
Public Sub SendMail()
    Dim xOutApp As Object
    Dim xMailItem As Object
    
    Dim xLastRow As Long
    
    Dim erMsg As String '紀錄錯誤訊息
    Dim erNm As Integer '紀錄錯誤訊息筆數

    xLastRow = Sheets("mail").Range("B200").End(xlUp).Row
    
    '計數器 記錄實際寄出的郵件數量
    Dim send_Num As Integer
    send_Num = 0
    
    Set xOutApp = CreateObject("Outlook.Application")
    If xLastRow <> 1 Then
        For n = 2 To xLastRow
            Dim check_send As String '是否郵寄 字串形式
            check_send = Sheets("mail").Range("A" & n).Value
        
            If check_send <> "" Then
            
                    Dim delaysec As Integer
                    Dim SendDate As Date
                    
                    delaysec = Int((5 - 2 + 1) * Rnd() + 2)
                    SendDate = Now()
                    
        '            Debug.Print SendDate
                    
                    SendDate = DateAdd("s", delaysec, SendDate)
                    
        '            Debug.Print SendDate
                    
                    Set xMailItem = xOutApp.CreateItem(olMailItem)
                    
                    '內文格式
                    If Sheets("mail").Range("B" & n).Value = "txt" Then
                        With xMailItem
                            .Subject = Sheets("mail").Range("F" & n).Value '主旨
                            .To = Sheets("mail").Range("D" & n).Value      '收件人
                            .BodyFormat = olFormatPlain                    '內文編碼格式
                            .Body = Sheets("mail").Range("G" & n).Value    '內文
                        End With
                        
                    ElseIf Sheets("mail").Range("B" & n).Value = "html" Then
                    
                        With xMailItem
                            .Subject = Sheets("mail").Range("F" & n).Value  '主旨
                            .To = Sheets("mail").Range("D" & n).Value       '收件人
                            .BodyFormat = olFormatHTML                      '內文編碼格式
                            .HTMLBody = Sheets("mail").Range("G" & n).Value '內文
                        End With
                        
                    Else
                    
                        MsgBox "請確認內文編碼格式"
                        
                    End If
                    
                    '附加檔案1
                    If Sheets("mail").Range("H" & n).Value <> "" Then
                        xMailItem.Attachments.Add Sheets("mail").Range("H" & n).Value
                    End If
                    
                    '附加檔案2
                    If Sheets("mail").Range("I" & n).Value <> "" Then
                        xMailItem.Attachments.Add Sheets("mail").Range("I" & n).Value
                    End If
                      
                    'cc收件人
                    If Sheets("mail").Range("E" & n).Value <> "" Then
                        mail.CC = Sheets("mail").Range("E" & n).Value
                    End If
                    
                    'DeferredDeliveryTime 設定郵件的傳送日期及時間
                    xMailItem.DeferredDeliveryTime = SendDate
                    Debug.Print "編號：" & (n - 1) & "信件，寄出時間：" & SendDate
                    
        '               發生錯誤仍繼續執行
                    On Error Resume Next
                            
        '               當發生錯誤時 用 erMsg erNm 紀錄
                    If Err.Number <> 0 Then
                        erMsg = erMsg & "編號-" & (n - 1) & "-" & Err.Number & "/" & Err.Description & Chr(10)
                        erNm = erNm + 1
                    End If
                                
                    '寄出郵件
    '                xMailItem.Send
    
                    '顯示郵件視窗
                    xMailItem.Display
                    
                    Set xMailItem = Nothing
                    
                    '計數器+1
                    send_Num = send_Num + 1
            End If
        '       正常偵錯
                On Error GoTo 0
        Next
        
        '顯示錯誤的紀錄
        If erMsg <> "" Then
            Debug.Print erMsg
            'MsgBox erMsg
        End If
        
        Debug.Print "寄送完成，共寄出" & send_Num & "封，有" & erNm & "筆錯誤。"
            
        MsgBox "寄送完成，共寄出" & send_Num & "封，有" & erNm & "筆錯誤。"
    
    End If
    
    Set xOutApp = Nothing
    
End Sub

 

Tags: