VBA / 在Outlook使用VBA批次寄信 2

  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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

Public Sub sendMail8()
   ' Dim excelMail As Excel.Application                    '早期繫結
    Dim excelMail As Object                                '晚期繫結
    Dim mail As Outlook.MailItem
    Dim Data As String 'mail_list檔案路徑
    Dim r As Integer
    Dim n As Integer
    Dim e As String '內文編碼
    Dim t As String '收件者
    Dim s As String '主旨
    Dim b As String '內文
    Dim a As String '附件
    Dim erMsg As String '紀錄錯誤訊息
    Dim erNm As Integer '紀錄錯誤訊息筆數
    
'    Data = "C:\Users\edu\Desktop\mail_list.xlsx"
'    透過 Excel Application建立FileDialog
    Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = False
    
    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFilePicker)
    
    ' 視窗標題
    fd.Title = "請選擇 mail_list.xlsx 檔案"
    
    ' 初始目錄
    fd.InitialFileName = "%USERPROFILE%\Desktop\mail_list.xlsx"
    
    '設定檔案類型
    fd.Filters.Clear
    fd.Filters.Add "試算表", "*.xls*", 1
'    Dim selectedItem As Variant
    
    If fd.Show = -1 Then
'        For Each selectedItem In fd.SelectedItems
'            Debug.Print selectedItem
        Data = fd.SelectedItems(1)
'        Next
    End If
    
    Set fd = Nothing
        xlApp.Quit
    Set xlApp = Nothing
    
    If Data <> "" Then
        
        MsgBox Data
        
       ' Set excelMail = New Excel.Application                 '早期繫結
        Set excelMail = CreateObject("excel.application")      '晚期繫結
        
        With excelMail
            .Visible = False
            .Workbooks.Open (Data)
        End With
        
        'MsgBox TypeName(excelMail)      'application
        r = excelMail.ActiveWorkbook.Sheets("mail").UsedRange.Rows.Count  '取得列數1
        
    '    r = excelMail.ActiveWorkbook.Sheets("mail").Range("A1").End(xlDown).Row  '取得列數2  引用excel library 不然即使是晚期繫節都會出現錯誤
    
    '    MsgBox r
        
        If r <> 1045678 Then
            For n = 2 To r
                If excelMail.ActiveWorkbook.Sheets("mail").Range("A" & n) <> "" Then  '路徑要完整 不然會出錯
                    e = excelMail.ActiveWorkbook.Sheets("mail").Range("B" & n).Value
                    t = excelMail.ActiveWorkbook.Sheets("mail").Range("D" & n).Value
                    c = excelMail.ActiveWorkbook.Sheets("mail").Range("E" & n).Value
                    s = excelMail.ActiveWorkbook.Sheets("mail").Range("F" & n).Value
                    b = excelMail.ActiveWorkbook.Sheets("mail").Range("G" & n).Value
                    a = excelMail.ActiveWorkbook.Sheets("mail").Range("H" & n).Value
                    
                    Debug.Print s
                    Debug.Print t
                    
                    Set mail = Application.CreateItem(olMailItem)
                    If e = "txt" Then
                        With mail
                            .To = t
                            .Subject = s
                            .BodyFormat = olFormatPlain
                            .Body = b
    '                        .Attachments.Add a
    '                        .Send
                        End With
                    
                    ElseIf e = "html" Then
                        With mail
                            .To = t
                            .Subject = s
                            .BodyFormat = olFormatHTML
                            .HTMLBody = b
    '                        .Attachments.Add a
    '                        .Send
                        End With
                    Else
                        
                        MsgBox "請確認內文編碼格式"
                    
                    End If
                    
                    If a <> "" Then
                        
                        mail.Attachments.Add a
                    
                    End If
                    
                    If c <> "" Then
                        mail.CC = c
                    End If
                    
    '               發生錯誤仍繼續執行
                    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
                    
                    '       間格時間(單位:秒) 2<= delaysec <= 5
                    '       int((數字上限 - 數字下限 + 1) * Rnd() + 數字下限)
                    delaysec1 = Int((5 - 2 + 1) * Rnd() + 2)
                    delaysec2 = Int((5 - 2 + 1) * Rnd() + 2)
                    delaysec3 = delaysec1 * 5 + delaysec2
                    
                    Debug.Print delaysec3
                    
'                    newHour = Hour(Now())
'                    newMinute = Minute(Now())
'                    newSecond = Second(Now()) + delaysec
'
'                    waitTime = TimeSerial(newHour, newMinute, newSecond)
'
'                    excelMail.Wait waitTime                                '在excel vba 為 Application.Wait
                    
                    SendDate = Now()
                    SendDate = DateAdd("s", delaysec3, SendDate)
                    
                    Debug.Print "Your mail will be sent at: " & SendDate
                    
                    mail.DeferredDeliveryTime = SendDate
                    
                    mail.Send
                    
                End If
                
                Set mail = Nothing
    
            Next
            
    '       正常偵錯
            On Error GoTo 0
        End If
        
        excelMail.Quit
        
        Set excelMail = Nothing
        
        '顯示錯誤的紀錄
        If erMsg <> "" Then
            Debug.Print erMsg
'            MsgBox erMsg
        End If
        
        Debug.Print "寄送完成，共寄出" & (r - 1) - erNm & "封，有" & erNm & "筆錯誤。"
        
        MsgBox "寄送完成，共寄出" & (r - 1) - erNm & "封，有" & erNm & "筆錯誤。"
     
     Else
     
        MsgBox "請重新執行，並選取 mail_list.xlsx"
        Exit Sub
        
     End If
     
End Sub