顯示具有 Outlook & VBA 標籤的文章。 顯示所有文章
顯示具有 Outlook & VBA 標籤的文章。 顯示所有文章

2023年12月5日 星期二

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

延續VBA / 在Outlook使用VBA批次寄信 修改了幾次程式碼，將整個流程更順暢一些

#18-44 檔案選取功能，透過對話窗選取要讀取的excel檔案

#124-145 間隔時間，利用Outlook.MailItem物件的DeferredDeliveryTime來設定

  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
   

2022年4月16日 星期六

VBA / 在Outlook使用VBA批次寄信

VBA / 使用Excel VBA批次寄信

是透過引用 CDO.Message物件的方式來傳遞信件

但是這個方式不會在自己的信箱留下紀錄

所以嘗試在 outlook透過VBA來寄信

這樣在寄件備份就會有資料

首要工作是設定 outlook郵件帳號

VBA會使用預設的郵件帳號來發出信件

接著是讓 outlook能夠抓取來自Excel的信件資料

這時候就要在 outlook引用 Excel Application物件

不過抓取工作表最後一列的位置時

在 Excel可以使用Range.End(xlDown).Row來取得

但是 outlook VBA如果用晚期繫結中引用 Excel Application物件的Range.End(xlDown)會出現錯誤

如果先引用 Excel library就能夠正常使用

不知道是不是繫結的差異

備註：後來爬文，有人說可以改成在End( )帶入XlDirection數值

If you want to have the ability to use Excel constants within your code, you will need to either
a) Include a reference to a Microsoft Excel Object Library, or
b) Create your own constant, e.g.
    End(-4162)
or
    Const xlUp As Long = -4162
    ...
    ... End(xlUp)

另外一篇也有人提到「outlook 認不得在Excel的常數」

Outlook 2007 must not recognize the Excel Constants, whereas OL 2010 does.
Instead of writing xlUp write the enumeration for xlUp which is -4162.

在 outlook VBA 選取工作表 儲存格要將完整的路徑列出來

例如：excelMail.ActiveWorkbook.Sheets(“mail”).Range(“B” & n).Value

否則也會出現錯誤

整體而言，雖然引用 Excel Application物件可以操作Excel

但還是不完全等於在 Excel環境裡

以下為完整的測試程式碼

'
Public Sub sendMail2()
   ' Dim excelMail As Excel.Application                    '早期繫結
    Dim excelMail As Object                                '晚期繫結
    Dim mail As Outlook.MailItem
    Dim DataPath As String 'excle檔案路徑
    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 '附件
    
    DataPath = "....\xxxxxxx.xlsx"
   ' Set excelMail = New Excel.Application                 '早期繫結
    Set excelMail = CreateObject("excel.application")      '晚期繫結
    
    With excelMail
        .Visible = False
        .Workbooks.Open (DataPath)
    End With
    
    'MsgBox TypeName(excelMail)      'application
'    r = excelMail.ActiveWorkbook.Sheets("mail").UsedRange.Rows.Count  '取得列數
'    r = excelMail.ActiveWorkbook.Sheets("mail").Range("A1").End(xlDown).Row     '取得列數  出現錯誤
    r = excelMail.ActiveWorkbook.Sheets("mail").Range("A1").End(-4121).Row       'xlDown 改成 -4121

'    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
                s = excelMail.ActiveWorkbook.Sheets("mail").Range("E" & n).Value
                b = excelMail.ActiveWorkbook.Sheets("mail").Range("F" & n).Value
                a = excelMail.ActiveWorkbook.Sheets("mail").Range("G" & n).Value

                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
                
            End If
            
            Set mail = Nothing
        Next
    End If
    
    excelMail.Quit
    
    Set excelMail = Nothing
    
End Sub

 

後記：

outlook 預設是不能執行VBA，即使打開「開發人員」選項

執行時還是會出現禁止的警告

要從「檔案」→「選項」→「信任中心」→「信任中心設定」

→「巨集設定」→所有巨集都顯示通知

這樣雖然還是出現警告視窗，但確定之後還是可以執行巨集

 

之後還可以再細部設定、增加功能，例如：每封信寄出的間隔時間
 

參考資料

以VBA傳送郵件–CDO物件(失效)

Excel VBA自動寄信程式：Word網路爬蟲及Outlook郵件清單

How To Open Specific Excel File From Outlook?

Excel VBA 自動讓Outlook發郵件，或許在剎那間你就會愛上他

VBA xlUp error in macro

Outlook VBA find last Row in Excel Worksheet

Finding the LastRow from Excel Attachment via Outlook VBA

VBA Range.End (xlDown, xlUp, xlToRight, xlToLeft)

Range.End 屬性 (Excel)