彰化一整天的論壇

 找回密碼
 立即註冊
查看: 521|回復: 0

【轉貼】將EXCEL內指定範圍的內容複製至郵件並發信給指定...

[複製鏈接]
發表於 2019-8-18 12:45:18 | 顯示全部樓層 |閱讀模式


  1. '將工作表內容作為信件內文參考下面網址
  2. 'Mail worksheet in the body of the mail http://www.rondebruin.nl/mail/folder3/mail2.htm
  3. Sub Mail_Sheet_Outlook_Body()
  4. ' Don't forget to copy the function RangetoHTML in the module. 將內容轉成HTML
  5. ' Working in Office 2000-2007
  6.     Dim Rng As Range, Sh As Worksheet, NewSh As Worksheet, i&, j%, k%
  7.     Dim OutApp As Object, OutMail As Object, NewWB As Workbook
  8.     Dim SigString As String
  9.     Dim Signature As String
  10.     With Application
  11.         .EnableEvents = False   '關閉Excel觸發事件功能
  12.         .ScreenUpdating = False '關閉Excel螢幕更新功能
  13.     End With
  14.     'WinXP簽名檔位置
  15.     'C:\Documents and Settings\你的電腦名稱\Application Data\Microsoft\Signatures\簽名檔名稱.htm
  16.     SigString = "C:\Documents and Settings" & Environ("username") & _
  17.                 "\Application Data\Microsoft\Signatures\Mysing.htm"
  18.    
  19.     'SigString = "C:\Users" & Environ("username") & _
  20.      "\AppData\Roaming\Microsoft\Signatures\Mysig.htm"   '使用Vista 或 Win7 作業系統 簽名檔位置
  21.    
  22.     If Dir(SigString) <> "" Then
  23.         Signature = GetBoiler(SigString)    '有簽名檔
  24.     Else
  25.         Signature = ""  '無簽名檔
  26.     End If
  27.     On Error Resume Next
  28.    
  29.     Set Sh = Sheets("公務用")
  30.     For i = 3 To Sh.[A65536].End(xlUp).Row
  31.         Set NewWB = Workbooks.Add(xlWBATWorksheet)  '指定新增工作簿參數NewWB
  32.         Set NewSh = NewWB.Sheets(1)
  33.         j = 1
  34.         For k = 1 To 19
  35.             If k <> 5 Then 'And k <> 16 And k <> 17 And k <> 18 Then
  36.                 j = j + 1
  37.                 NewSh.Cells(j, 1) = Sh.Cells(2, k) 'A欄標題
  38.                 NewSh.Cells(j, 2) = Sh.Cells(i, k) 'B欄內容
  39.                 If j > 15 And j < 19 Then NewSh.Cells(j, 2) = Format(NewSh.Cells(j, 2), "yyyy/m/d") '儲存格日期格式
  40.             End If
  41.         Next k
  42.         Set Rng = Nothing
  43.         'Set rng = ActiveSheet.UsedRange
  44.         'You can also use a sheet name
  45.         Set Rng = NewSh.UsedRange
  46.         With Rng
  47.             .Borders.LineStyle = xlContinuous   '框線線型連續
  48.             .Borders.Weight = xlThin            '框線細
  49.             .Columns.AutoFit                    '自動調整欄寬
  50.             .Columns(2).HorizontalAlignment = xlCenter  'B欄文字置中
  51.         End With
  52.         'Create a file name
  53.         TempFilePath = Environ$("temp") & ""   '暫存檔路徑
  54.         TempFileName = "Your data of " & Sh.Cells(i, 4) _
  55.                      & " " & Format(Now, "dd-mmm-yy h-mm-ss")   '暫存檔檔名
  56.    
  57.         If Val(Application.Version) < 12 Then
  58.             'You use Excel 2000-2003
  59.             FileExtStr = ".xls": FileFormatNum = -4143
  60.         Else
  61.             'You use Excel 2007-2010
  62.             FileExtStr = ".xlsx": FileFormatNum = 51
  63.         End If
  64.    
  65.         'Save, Mail, Close and Delete the file
  66.         Set OutApp = CreateObject("Outlook.Application")
  67.         Set OutMail = OutApp.CreateItem(0)
  68.         With NewWB
  69.             .SaveAs TempFilePath & TempFileName _
  70.                   & FileExtStr, FileFormat:=FileFormatNum   '儲存暫存檔
  71.             On Error Resume Next
  72.             With OutMail
  73.                 .To = Sh.Cells(i, 11)   '聯絡人E-Mail
  74.                 .CC = "my@test.com"        '副本
  75.                 .BCC = ""       '密件副本
  76.                 .Subject = Sh.Cells(i, 4) & "進度"
  77.                 .Attachments.Add NewWB.FullName
  78.                 '.Body = "THi there"    '文字內容寫法
  79.                 .HTMLBody = "<Font Face=Times Roman Size=3.5>" & Sh.Cells(i, 6) & "您好:<P>" & _
  80.                 "附件是單位 " & Sh.Cells(i, 2) & " " & Sh.Cells(i, 4) & " 進度相關資料<BR>" & _
  81.                 RangetoHTML(Rng) & "<P>" & Signature   'HTML內容寫法+簽名檔
  82.                 .Display    '預覽
  83.                 .Send       '寄出
  84.             End With
  85.             On Error GoTo 0
  86.             .Close savechanges:=False
  87.         End With
  88.    
  89.         Set OutMail = Nothing
  90.         Set OutApp = Nothing
  91.         Kill TempFilePath & TempFileName & FileExtStr   '剛除暫存檔
  92.    
  93.     Next i
  94.     With Application
  95.         .EnableEvents = True    '開啟Excel觸發事件功能
  96.         .ScreenUpdating = True  '開啟Excel螢幕更新功能
  97.     End With
  98. End Sub
  99. Function RangetoHTML(Rng As Range)  '信件HTML內容型式轉換
  100. ' Changed by Ron de Bruin 28-Oct-2006
  101. ' Working in Office 2000-2007
  102.     Dim fso As Object
  103.     Dim ts As Object
  104.     Dim TempFile As String
  105.     Dim TempWB As Workbook

  106.     TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"    '暫存檔

  107.     'Copy the range and create a new workbook to past the data in
  108.     Rng.Copy
  109.     Set TempWB = Workbooks.Add(1)
  110.     With TempWB.Sheets(1)
  111.         .Cells(1).PasteSpecial Paste:=8
  112.         .Cells(1).PasteSpecial xlPasteValues, , False, False
  113.         .Cells(1).PasteSpecial xlPasteFormats, , False, False
  114.         .Cells(1).Select
  115.         Application.CutCopyMode = False
  116.         On Error Resume Next
  117.         .DrawingObjects.Visible = True
  118.         .DrawingObjects.Delete
  119.         On Error GoTo 0
  120.     End With

  121.     'Publish the sheet to a htm file 將複製內容轉成HTML檔
  122.     With TempWB.PublishObjects.Add( _
  123.          SourceType:=xlSourceRange, _
  124.          Filename:=TempFile, _
  125.          Sheet:=TempWB.Sheets(1).Name, _
  126.          Source:=TempWB.Sheets(1).UsedRange.Address, _
  127.          HtmlType:=xlHtmlStatic)
  128.         .Publish (True)
  129.     End With

  130.     'Read all data from the htm file into RangetoHTML
  131.     Set fso = CreateObject("Scripting.FileSystemObject")
  132.     Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  133.     RangetoHTML = ts.readall
  134.     ts.Close
  135.     RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
  136.                           "align=left x:publishsource=")

  137.     'Close TempWB
  138.     TempWB.Close savechanges:=False

  139.     'Delete the htm file we used in this function
  140.     Kill TempFile

  141.     Set ts = Nothing
  142.     Set fso = Nothing
  143.     Set TempWB = Nothing
  144. End Function
  145. Function GetBoiler(ByVal sFile As String) As String '簽名檔
  146. 'Dick Kusleika
  147.     Dim fso As Object
  148.     Dim ts As Object
  149.     Set fso = CreateObject("Scripting.FileSystemObject")
  150.     Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
  151.     GetBoiler = ts.readall
  152.     ts.Close
  153. End Function
複製代碼
文章來源: http://club.excelhome.net/thread-820839-2-1.html
回復

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  

GMT+8, 2020-5-27 04:40 , Processed in 0.149585 second(s), 19 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表