[英]Adding a one cell value into body of an email via Excel
I have a macro that automatically creates an email, attaches two sheets from my workbook as attachments, and then emails those sheets to approved people. 我有一个自动创建电子邮件的宏,从工作簿中附加两张表作为附件,然后通过电子邮件将这些表发送给已批准的人。 I would like to figure out how to get the cell value at "C3" from the sheet "Instructions" into the body of the email it creates. 我想弄清楚如何将“C3”中的单元格值从“说明”表单中获取到它创建的电子邮件正文中。 I have tried several different programs but I haven't found how to do it yet. 我已经尝试了几个不同的程序,但我还没有找到如何做到这一点。
Sub Labor_Material_16009()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
With Sourcewb
Set theactivewindow = ActiveWindow
Set tempwindow = .NewWindow
.Sheets(Array("16009 Labor", "16009 Material")).Copy
End With
tempwindow.Close
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsm": FileFormatNum = 52
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsm": FileFormatNum = 52
End If
Case 56: FileExtStr = ".xlsm": FileFormatNum = 52
Case Else: FileExtStr = ".xlsm": FileFormatNum = 52
End Select
End If
End With
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
TempFilePath = Environ$("temp") & "\"
TempFileName = "16009 - " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "16009 Labor and Material Report"
.Body = "Please see the attached"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
If you want to retain your standard signature: 如果您想保留标准签名:
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "16009 Labor and Material Report"
'.Body = NOT HERE
.Attachments.Add Destwb.FullName
Dim wdDoc As Word.Document
Set wdDoc = .GetInspector.WordEditor
If Not wdDoc Is Nothing Then
With wdDoc.Range
.Collapse wdCollapseStart
.InsertBefore "Please see the attached" & vbCrLf
.Collapse wdCollapseEnd
.InsertAfter "Best wishes," & vbCrLf
.Collapse wdCollapseStart
Sourcewb.Worksheets("Instructions").Range("C3").Copy
.Paste
'.PasteAndFormat wdChartPicture
'.PasteAndFormat wdFormatPlainText
End With
End If
.Send 'or use .Display
End With
I would avoid nesting WITH statements. 我会避免嵌套WITH语句。 You can put the value of whatever range you want in to a string variable before you close it and use that later in the body. 您可以在关闭它之前将所需范围的值放入字符串变量中,然后在主体中使用它。 I would also avoid hiding errors like you do with the e-mail code. 我也会避免像使用电子邮件代码那样隐藏错误。 Deal with the errors or use an error handler but don't just skip past them. 处理错误或使用错误处理程序,但不要只是跳过它们。
TRY THIS: 尝试这个:
Option Explicit
Sub Labor_Material_16009()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Dim theactivewindow As Window
Dim tempwindow As Window
Dim InstructionText As String
With Sourcewb
InstructionText = .Worksheets("Instructions").Range("C3").Value
Set theactivewindow = ActiveWindow
Set tempwindow = .NewWindow
.Sheets(Array("16009 Labor", "16009 Material")).Copy
End With
tempwindow.Close
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsm": FileFormatNum = 52
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsm": FileFormatNum = 52
End If
Case 56: FileExtStr = ".xlsm": FileFormatNum = 52
Case Else: FileExtStr = ".xlsm": FileFormatNum = 52
End Select
End If
End With
With Destwb.Sheets(1).UsedRange
.Value = .Value
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "16009 - " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy")
Dim tempFullPath As String
tempFullPath = TempFilePath & TempFileName & FileExtStr
With Destwb
.SaveAs tempFullPath, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "16009 Labor and Material Report"
.Body = "Please see the attached" & vbNewLine & InstructionText
.Attachments.Add tempFullPath
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
Kill tempFullPath
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.