|
本帖最后由 mineshine 于 2012-2-2 12:17 编辑
temp11111 发表于 2012-2-2 09:37
自問自答一
參考:msgbox做为判断条件时的使用
在最前面加上即可發出前詢問
你可以發副本或密件副本給自己
用display可以先看信件內容再send出去
如果不發出,就在outlook顯示提示訊息時按"取消"就可以不發,程式再往下繼續執行。
程式我做了修改,可以在信件尾加上簽名檔,
簽名檔位置、檔名你再自行修正。
將全部程式覆蓋
- '將工作表內容作為信件內文參考下面網址
- 'Mail worksheet in the body of the mail http://www.rondebruin.nl/mail/folder3/mail2.htm
- Sub Mail_Sheet_Outlook_Body()
- ' Don't forget to copy the function RangetoHTML in the module. 將內容轉成HTML
- ' Working in Office 2000-2007
- Dim Rng As Range, Sh As Worksheet, NewSh As Worksheet, i&, j%, k%
- Dim OutApp As Object, OutMail As Object, NewWB As Workbook
- Dim SigString As String
- Dim Signature As String
- With Application
- .EnableEvents = False '關閉Excel觸發事件功能
- .ScreenUpdating = False '關閉Excel螢幕更新功能
- End With
- 'WinXP簽名檔位置
- 'C:\Documents and Settings\你的電腦名稱\Application Data\Microsoft\Signatures\簽名檔名稱.htm
- SigString = "C:\Documents and Settings" & Environ("username") & _
- "\Application Data\Microsoft\Signatures\Mysing.htm"
-
- 'SigString = "C:\Users" & Environ("username") & _
- "\AppData\Roaming\Microsoft\Signatures\Mysig.htm" '使用Vista 或 Win7 作業系統 簽名檔位置
-
- If Dir(SigString) <> "" Then
- Signature = GetBoiler(SigString) '有簽名檔
- Else
- Signature = "" '無簽名檔
- End If
- On Error Resume Next
-
- Set Sh = Sheets("公務用")
- For i = 3 To Sh.[A65536].End(xlUp).Row
- Set NewWB = Workbooks.Add(xlWBATWorksheet) '指定新增工作簿參數NewWB
- Set NewSh = NewWB.Sheets(1)
- j = 1
- For k = 1 To 19
- If k <> 5 Then 'And k <> 16 And k <> 17 And k <> 18 Then
- j = j + 1
- NewSh.Cells(j, 1) = Sh.Cells(2, k) 'A欄標題
- NewSh.Cells(j, 2) = Sh.Cells(i, k) 'B欄內容
- If j > 15 And j < 19 Then NewSh.Cells(j, 2) = Format(NewSh.Cells(j, 2), "yyyy/m/d") '儲存格日期格式
- End If
- Next k
- Set Rng = Nothing
- 'Set rng = ActiveSheet.UsedRange
- 'You can also use a sheet name
- Set Rng = NewSh.UsedRange
- With Rng
- .Borders.LineStyle = xlContinuous '框線線型連續
- .Borders.Weight = xlThin '框線細
- .Columns.AutoFit '自動調整欄寬
- .Columns(2).HorizontalAlignment = xlCenter 'B欄文字置中
- End With
- 'Create a file name
- TempFilePath = Environ$("temp") & "" '暫存檔路徑
- TempFileName = "Your data of " & Sh.Cells(i, 4) _
- & " " & Format(Now, "dd-mmm-yy h-mm-ss") '暫存檔檔名
-
- If Val(Application.Version) < 12 Then
- 'You use Excel 2000-2003
- FileExtStr = ".xls": FileFormatNum = -4143
- Else
- 'You use Excel 2007-2010
- FileExtStr = ".xlsx": FileFormatNum = 51
- End If
-
- 'Save, Mail, Close and Delete the file
- Set OutApp = CreateObject("Outlook.Application")
- Set OutMail = OutApp.CreateItem(0)
- With NewWB
- .SaveAs TempFilePath & TempFileName _
- & FileExtStr, FileFormat:=FileFormatNum '儲存暫存檔
- On Error Resume Next
- With OutMail
- .To = Sh.Cells(i, 11) '聯絡人E-Mail
- .CC = "my@test.com" '副本
- .BCC = "" '密件副本
- .Subject = Sh.Cells(i, 4) & "進度"
- .Attachments.Add NewWB.FullName
- '.Body = "THi there" '文字內容寫法
- .HTMLBody = "<Font Face=Times Roman Size=3.5>" & Sh.Cells(i, 6) & "您好:<P>" & _
- "附件是單位 " & Sh.Cells(i, 2) & " " & Sh.Cells(i, 4) & " 進度相關資料<BR>" & _
- RangetoHTML(Rng) & "<P>" & Signature 'HTML內容寫法+簽名檔
- .Display '預覽
- .Send '寄出
- End With
- On Error GoTo 0
- .Close savechanges:=False
- End With
-
- Set OutMail = Nothing
- Set OutApp = Nothing
- Kill TempFilePath & TempFileName & FileExtStr '剛除暫存檔
-
- Next i
- With Application
- .EnableEvents = True '開啟Excel觸發事件功能
- .ScreenUpdating = True '開啟Excel螢幕更新功能
- End With
- End Sub
- Function RangetoHTML(Rng As Range) '信件HTML內容型式轉換
- ' Changed by Ron de Bruin 28-Oct-2006
- ' Working in Office 2000-2007
- Dim fso As Object
- Dim ts As Object
- Dim TempFile As String
- Dim TempWB As Workbook
-
- TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" '暫存檔
-
- 'Copy the range and create a new workbook to past the data in
- Rng.Copy
- Set TempWB = Workbooks.Add(1)
- With TempWB.Sheets(1)
- .Cells(1).PasteSpecial Paste:=8
- .Cells(1).PasteSpecial xlPasteValues, , False, False
- .Cells(1).PasteSpecial xlPasteFormats, , False, False
- .Cells(1).Select
- Application.CutCopyMode = False
- On Error Resume Next
- .DrawingObjects.Visible = True
- .DrawingObjects.Delete
- On Error GoTo 0
- End With
-
- 'Publish the sheet to a htm file 將複製內容轉成HTML檔
- With TempWB.PublishObjects.Add( _
- SourceType:=xlSourceRange, _
- Filename:=TempFile, _
- Sheet:=TempWB.Sheets(1).Name, _
- Source:=TempWB.Sheets(1).UsedRange.Address, _
- HtmlType:=xlHtmlStatic)
- .Publish (True)
- End With
-
- 'Read all data from the htm file into RangetoHTML
- Set fso = CreateObject("Scripting.FileSystemObject")
- Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
- RangetoHTML = ts.readall
- ts.Close
- RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
- "align=left x:publishsource=")
-
- 'Close TempWB
- TempWB.Close savechanges:=False
-
- 'Delete the htm file we used in this function
- Kill TempFile
-
- Set ts = Nothing
- Set fso = Nothing
- Set TempWB = Nothing
- End Function
- Function GetBoiler(ByVal sFile As String) As String '簽名檔
- 'Dick Kusleika
- Dim fso As Object
- Dim ts As Object
- Set fso = CreateObject("Scripting.FileSystemObject")
- Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
- GetBoiler = ts.readall
- ts.Close
- End Function
复制代码 |
评分
-
1
查看全部评分
-
|