[發問] outlook方法改為系統預設的郵件程式

takeshilin88

請教各位大大：
原本使用outlook方法寄信，
因老闆要求要改成系統預設的郵件程式寄信(windows live mail)，
請問要如何修改？

1. Sub Send_Range_Body()
   
2. 
   
3.     Dim rng As Range
   
4.     Dim OutApp As Object
   
5.     Dim OutMail As Object
   
6.     Application.ReferenceStyle = xlA1
   
7. 
   
8.     'Set rng = Nothing
   
9.     On Error Resume Next
   
10.     Set rng = Sheets("sheet1").Range("A4:F20").SpecialCells(xlCellTypeVisible)
    
11.     On Error GoTo 0
    
12. 
    
13.     If rng Is Nothing Then
    
14.         MsgBox "請選擇一個選區並且工作表不能是保護狀態。" & _
    
15.                vbNewLine & "請再次嘗試。", vbOKOnly
    
16.         Exit Sub
    
17.     End If
    
18. 
    
19.     With Application
    
20.         .EnableEvents = False
    
21.         .ScreenUpdating = False
    
22.     End With
    
23. 
    
24.     Set OutApp = CreateObject("Outlook.Application")
    
25.     Set OutMail = OutApp.CreateItem(0)
    
26. 
    
27.     On Error Resume Next
    
28.     With OutMail
    
29.         .To = "ppppn@orrns.com.tw"
    
30.         '.CC = "副本給誰"  
    
31.         '.BCC = "密件副本給誰"   
    
32.         .Subject = "hello"  '主旨
    
33.         .HTMLBody = RangetoHTML(rng)  
    
34.         .Display
    
35.         
    
36.     End With
    
37.     On Error GoTo 0
    
38. 
    
39.     With Application
    
40.         .EnableEvents = True
    
41.         .ScreenUpdating = True
    
42.     End With
    
43. 
    
44.     Set OutMail = Nothing
    
45.     Set OutApp = Nothing
    
46. End Sub
    
47. 
    
48. 'FUNCTION RangetoHTML
    
49. Function RangetoHTML(rng As Range)
    
50. ' Changed by Ron de Bruin 28-Oct-2006
    
51. ' Working in Office 2000-2016
    
52.     Dim fso As Object
    
53.     Dim ts As Object
    
54.     Dim TempFile As String
    
55.     Dim TempWB As Workbook
    
56. 
    
57.     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
58. 
    
59.     'Copy the range and create a new workbook to past the data in
    
60.     rng.Copy
    
61.     Set TempWB = Workbooks.Add(1)
    
62.     With TempWB.Sheets(1)
    
63.         .Cells(1).PasteSpecial Paste:=8
    
64.         .Cells(1).PasteSpecial xlPasteValues, , False, False
    
65.         .Cells(1).PasteSpecial xlPasteFormats, , False, False
    
66.         .Cells(1).Select
    
67.         Application.CutCopyMode = False
    
68.         On Error Resume Next
    
69.         .DrawingObjects.Visible = True
    
70.         .DrawingObjects.Delete
    
71.         On Error GoTo 0
    
72.     End With
    
73. 
    
74.     'Publish the sheet to a htm file
    
75.     With TempWB.PublishObjects.Add( _
    
76.          SourceType:=xlSourceRange, _
    
77.          Filename:=TempFile, _
    
78.          Sheet:=TempWB.Sheets(1).Name, _
    
79.          Source:=TempWB.Sheets(1).UsedRange.Address, _
    
80.          HtmlType:=xlHtmlStatic)
    
81.         .Publish (True)
    
82.     End With
    
83. 
    
84.     'Read all data from the htm file into RangetoHTML
    
85.     Set fso = CreateObject("Scripting.FileSystemObject")
    
86.     Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    
87.     RangetoHTML = ts.readall
    
88.     ts.Close
    
89.     RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    
90.                           "align=left x:publishsource=")
    
91. 
    
92.     'Close TempWB
    
93.     TempWB.Close savechanges:=False
    
94. 
    
95.     'Delete the htm file we used in this function
    
96.     Kill TempFile
    
97. 
    
98.     Set ts = Nothing
    
99.     Set fso = Nothing
    
100.     Set TempWB = Nothing
     
101. End Function

複製代碼