Private Sub CommandButton1_Click()
Dim arr()
arr = Application.GetOpenFilename("所有支持文件 (*.xls;*.xlsx;*.csv),*.xls;*.xlsx;*.csv,Excel 文件 (*.xls),*.xls,Excel2007 文件 (*.xlsx),*.xlsx,CSV 文件 (*.csv),*.csv", , "選擇文件", , True)
For i = LBound(arr) To UBound(arr)
TextBox1.Value = arr(i)
Next
End Sub
Private Sub 全自動發送郵件_Click()
'要能正確發送並需要對Microseft Outlook進行有效配置
On Error Resume Next
Dim rowCount, endRowNo, endColumnNo, sFile$, sFile1$, A&, B&
Dim objOutlook As Object
Dim objMail As MailItem
Dim myAttachments As outlook.Attachments
Dim MyItem As outlook.MailItem
If TextBox1.Value = "" Then
MsgBox "未選擇文件"
End
Else
MsgBox "發送郵件"
End If
'取得當前工作表數據區行數列數
endRowNo = ActiveSheet.UsedRange.Rows.Count
endColumnNo = ActiveSheet.UsedRange.Columns.Count
'取得當前工作表的名稱，用來作爲郵件主題進行發送
sFile1 = ActiveSheet.Name
'創建objOutlook爲Outlook應用程序對象
Set objOutlook = CreateObject("Outlook.Application")
'開始循環發送電子郵件
For rowCount = 2 To endRowNo
'創建objMail爲一個郵件對象
Set objMail = objOutlook.CreateItem(olMailItem)
'設定郵件模板所在的位置
Set MyItem = objOutlook.CreateItemFromTemplate("d:\02.oft")
With objMail
'多OUTLOOK賬號設定所發送的郵箱序列（1爲第一個，2爲第二個）
MyItem.SendUsingAccount = objMail.Session.Accounts.Item(1)
'設置收件人地址，數據源所在列數
MyItem.To = Cells(rowCount, 2)
'設置抄送人地址（從通訊錄表的'E-mail地址'字段中獲得）
'MyItem.CC = "[email protected];[email protected]"
'設置郵件主題,取值工作表名，
MyItem.Subject = Format(Date, "yyyy年m月d日") + "測試"
'設置郵件內容(從通訊錄表的“內容”字段中獲得)
'align 單元格文本顯示方式 left(向左)、center(居中)、right(向右)，默認是center, width-寬 height-高 border 單元格線粗細,bordercolor返回或設置對象的邊框顔色
'colSpan是一種編程語言，其屬性可設置或返回表元橫跨的列數
'所發送郵件的附件的路徑
MyItem.Attachments.Add (TextBox1.Value)
B = 1
For A = 1 To endColumnNo
'數據表頭中添加“X”後將不發送此字段
If Application.WorksheetFunction.CountIf(Cells(1, A), "*X*") = 0 Then
If B = 1 Then
sFile = sFile + "<tr><Font Face='微軟雅黑' Color=red> <td width='20%' height='25' align='center' > " + Cells(1, A).Text + " </td> <td width='30%' height='25' align='center'> " + Cells(rowCount, A).Text + "</td>"
B = 0
Else
sFile = sFile + "<td width='20%' height='25' align='center' > " + Cells(1, A).Text + " </td> <td width='30%' height='25' align='center'> " + Cells(rowCount, A).Text + "</td> </tr>"
B = 1
End If
End If
Next
'郵件的內容，這裏取上面路徑中郵件模板中的內容
MyItem.Display
' .HTMLBody = sFile
'設置附件(從被選擇的路徑選取)
' .Attachments.Add (TextBox1.Value)
'自動發送郵件
MyItem.Send
End With
'銷毀objMail對象
Set objMail = Nothing
Set MyItem = Nothing
Next
'銷毀objOutlook對象
Set objOutlook = Nothing
'所有電子郵件發送完成時提示
MsgBox rowCount – 2 & " 份訂單發送成功！"
'清空文本框
TextBox1.Value = ""
' Sheet1.Shapes("全自動發送郵件").Delete
End Sub