將EXCEL內指定範圍的內容複製至郵件並發信給指定欄位的使用者

temp11111 · 发表于 2012-2-1 23:02

本帖最后由 temp11111 于 2012-2-2 09:48 编辑

再請問老師若要加上兩個功能
1.測試信.就是只發第一筆資料給自己以確認內容是否正確
2.發信前出現 "確認"或"取消"的對話框該如何追加

第1點.是有想到旁門左道
先修改讓他只讀一行不過改了之後完全不會動作了{:soso_e109:}

For i = 3 To S2.[A4].End(xlUp).Row

复制代码

再把TO改成自己

.To = "my@test.com '聯絡人E-Mail

复制代码

不過這樣子就要將相同的語法複製兩份修改上會很麻煩{:soso_e101:}

第2點
還在再爬文

老師若是有空抽幫幫我吧
謝謝!

語法目前還在努力中..閱讀ing
慢慢補上來註解有錯誤的話再請老師幫我訂正
再次謝謝

Set S1 = Sheets("問題") '設定S1 代表"問題"這個sheet
Set S2 = Sheets("公務用") '設定S2 代表"公務用"這個sheet
'-------------標題-------------------------------------
j = 1
For i = 1 To 19 '第一列到第19列
      If i <> 5 Then 'And i <> 16 And i <> 17 And i <> 18 Then
      '哪幾列不要列入
         j = j + 1
         Debug.Print S2.Cells(2, i)
         S1.Cells(j, 1) = S2.Cells(2, i)
      End If
Next i
'------------------------------------------------------
For i = 3 To S2.[A65536].End(xlUp).Row '第三行到最後一行
      '內容
      j = 1
      With S2
         For k = 1 To 19 '第一列到第19列
            If k <> 5 Then 'And k <> 16 And k <> 17 And k <> 18 Then
            '哪幾列不要列入
                  j = j + 1
                  Debug.Print S2.Cells(i, k)
                  S1.Cells(j, 2) = S2.Cells(i, k)
            End If
         Next k
      End With

      Set rng = Nothing '還在查
'Set rng = ActiveSheet.UsedRange
      'You can also use a sheet name
      Set rng = S1.Range("A2:B19") '問題sheet的A2到B19欄
      Set NewWB = Workbooks.Add(xlWBATWorksheet) '還在查

      rng.Copy '複製範圍?
      With NewWB.Sheets(1) '以下應該是全部貼上包然格式
         .Cells(1).PasteSpecial Paste:=8
         .Cells(1).PasteSpecial Paste:=xlPasteValues
         .Cells(1).PasteSpecial Paste:=xlPasteFormats
         .Cells(1).Select
         Application.CutCopyMode = False
      End With

      'Create a file name
      TempFilePath = Environ$("temp") & "\"
      TempFileName = "Your data of " & S1.Parent.Name _
                  & " " & Format(Now, "dd-mmm-yy h-mm-ss") '不懂為什麼又用到S1

temp11111 · 发表于 2012-2-2 09:37

自問自答一
參考:msgbox做为判断条件时的使用
在最前面加上即可發出前詢問

Dim text, text1, text2 As String
text1 = "您確定要發信給使用者嗎？"
text2 = ""
text = MsgBox(text1 & text2, vbOKCancel + vbInformation, "通知信寄發前確認")
If text = vbCancel Then Exit Sub

复制代码

測試信的部分好像有點難度= ="

mineshine · 发表于 2012-2-2 12:09

本帖最后由 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

复制代码

temp11111 · 发表于 2012-2-2 13:39

mineshine 发表于 2012-2-2 12:09
你可以發副本或密件副本給自己
用display可以先看信件內容再send出去
如果不發出，就在outlook顯示提 ...

老師謝謝
感謝您想得如此週到!
連簽名檔都附上了

測試信的方面就先不用了反正好少用到
自己複製一份將MAIL改成自己其他通通刪掉就可了

再次謝謝您特地抽空幫忙

liucqa · 发表于 2012-2-3 00:24

这个应该学

billzhaopa · 发表于 2016-11-24 16:38

好贴，感谢，收藏。

iguasssu · 发表于 2017-7-12 17:55

mineshine 发表于 2012-2-2 12:09
你可以發副本或密件副本給自己
用display可以先看信件內容再send出去
如果不發出，就在outlook顯示提 ...

大师,如果签名是图片怎么办啊

lokpo766 · 发表于 2019-9-13 11:43

Mark了先

		自动登录	找回密码
密码			免费注册

[已解决] 將EXCEL內指定範圍的內容複製至郵件並發信給指定欄位的使用者

评分

最新热点 /1