返回列表 上一主題 發帖

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

takeshilin88
　暱稱: 鹹蛋

中學生Rank: 2

帖子
62 
主題
13 
精華
0 
積分
109 
點名
0  
作業系統
Win 10家用版 
軟體版本
Office 2013 
閱讀權限
20 
性別
女 
來自
新北 
註冊時間
2016-1-27 
最後登錄
2024-8-12 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-3-17 11:52 | 只看該作者

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

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

  3.     Dim rng As Range
  4.     Dim OutApp As Object
  5.     Dim OutMail As Object
  6.     Application.ReferenceStyle = xlA1

  8.     'Set rng = Nothing
  9.     On Error Resume Next
  10.     Set rng = Sheets("sheet1").Range("A4:F20").SpecialCells(xlCellTypeVisible)
  11.     On Error GoTo 0

  13.     If rng Is Nothing Then
  14.         MsgBox "請選擇一個選區並且工作表不能是保護狀態。" & _
  15.                vbNewLine & "請再次嘗試。", vbOKOnly
  16.         Exit Sub
  17.     End If

  19.     With Application
  20.         .EnableEvents = False
  21.         .ScreenUpdating = False
  22.     End With

  24.     Set OutApp = CreateObject("Outlook.Application")
  25.     Set OutMail = OutApp.CreateItem(0)

  27.     On Error Resume Next
  28.     With OutMail
  29.         .To = "[email protected]"
  30.         '.CC = "副本給誰"  
  31.         '.BCC = "密件副本給誰"   
  32.         .Subject = "hello"  '主旨
  33.         .HTMLBody = RangetoHTML(rng)  
  34.         .Display
  35.         
  36.     End With
  37.     On Error GoTo 0

  39.     With Application
  40.         .EnableEvents = True
  41.         .ScreenUpdating = True
  42.     End With

  44.     Set OutMail = Nothing
  45.     Set OutApp = Nothing
  46. End Sub

  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

  57.     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

  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

  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

  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=")

  92.     'Close TempWB
  93.     TempWB.Close savechanges:=False

  95.     'Delete the htm file we used in this function
  96.     Kill TempFile

  98.     Set ts = Nothing
  99.     Set fso = Nothing
  100.     Set TempWB = Nothing
  101. End Function
複製代碼
收藏 分享

        靜思自在 : 【停滯不前，終無所得】人都迷於尋找奇蹟，因而停滯不前；縱使時間再多、路再長，也了無用處，終無所得。
返回列表 上一主題