【发布时间】:2019-07-11 10:02:07
【问题描述】:
我有一些直接通过 Outlook 电子邮件发送 excel 表的 vba 代码。我将 excel 文件保存为 .xlsm,因此宏和 VBA 程序可以在我的设备上运行。但是,当电子邮件的收件人打开 Excel 表时,不会发送模块(包含某些用户定义的公式)。我想知道是否有一种方法可以确保模块是通过电子邮件发送的,或者我可以在其他地方放置函数的代码,以便自动通过电子邮件发送。
提前感谢您的帮助。
我已经尝试在网上寻找任何情况,但我看到的只是将函数放入模块中,并且没有关于如何使用通过 vba 创建的电子邮件发送模块的说明。
电子邮件:
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
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
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 = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
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 = Range("B61")
.CC = ""
.BCC = ""
.Subject = "CS Equipment Pricebook"
.Body = Range("B30:B40")
.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
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
功能:
Function username()
username = Environ("Username")
End Function
无论何时发送邮件,具有该功能的模块都不会发送。
【问题讨论】: