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
|
0 comments:
張貼留言