Question

有人可以就此问题向我提出建议。我从Ron de Bruin网站获得以下代码，将多张工作表发送到单元格A1中的电子邮件地址。

然而，当收到电子邮件时，它已经更改了工作表上的时间格式，即16:00:00更改为0.666666667 任何人都可以看到如何适应它以保持16:00:00？

 Option Explicit


Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

TempFilePath = Environ$("temp") & ""

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set OutApp = CreateObject("Outlook.Application")

For Each sh In ThisWorkbook.Worksheets

If sh.Range("A1").Value Like "?*@?*.?*" Then

sh.Copy

Set wb = ActiveWorkbook

'Change all cells in the worksheet to values

With wb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With

Application.CutCopyMode = False

TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutMail = OutApp.CreateItem(0)

With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

On Error Resume Next
With OutMail
.To = sh.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "TEST"
.Body = "Hi there"
.Attachments.Add wb.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

Set OutMail = Nothing

Kill TempFilePath & TempFileName & FileExtStr

End If

Next sh

Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

Answer 1

我的书呆子被你的问题扼杀了，并重构了你的代码。

Public Sub Mail_Every_Worksheet()
    'Working in Excel 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Worksheets
        Dim emailAddress As String
        emailAddress = sh.Range("A1").Value2
        If IsValidEmailAddress(emailAddress) Then
            Dim tempFileName As String
            tempFileName = "Sheet " & sh.Name & " of " & ThisWorkbook.Name & " " & Format$(Now, "dd-mmm-yy h-mm-ss")
            Dim tempBook As Workbook
            Set tempBook = CreateTempWorkbookFrom(sh, Environ$("temp"), tempFileName)
            Dim tempBookFullPath As String
            tempBookFullPath = tempBook.FullName
            tempBook.Close

            SendOutlookEmailTo emailAddress, vbNullString, vbNullString, "Subject", "Body", tempBookFullPath

            Kill tempBookFullPath
        End If
    Next

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Private Function IsValidEmailAddress(ByVal value As String) As Boolean
    IsValidEmailAddress = (value Like "?*@?*.?*")
End Function

Private Function CreateTempWorkbookFrom(ByVal copySheet As Worksheet, ByVal tempSavePath As String, ByVal tempFileName As String) As Workbook
    If Right$(tempSavePath, 1) <> Application.PathSeparator Then
        tempSavePath = tempSavePath & Application.PathSeparator
    End If

    copySheet.Copy
    Set CreateTempWorkbookFrom = ActiveWorkbook

    With CreateTempWorkbookFrom.Worksheets(1).UsedRange
        'Change all cells in the worksheet to values
        .Cells.Value2 = .Cells.Value2
    End With

    If Val(Application.Version) < 12 Then
        CreateTempWorkbookFrom.SaveAs tempSavePath & tempFileName & ".xls", xlWorkbookNormal
    Else
        CreateTempWorkbookFrom.SaveAs tempSavePath & tempFileName & ".xlsm", xlOpenXMLWorkbookMacroEnabled
    End If
End Function

Private Sub SendOutlookEmailTo(ByVal emailAddress As String, _
                                ByVal CC As String, _
                                ByVal BCC As String, _
                                ByVal Subject As String, _
                                ByVal Body As String, _
                                ParamArray attachments() As Variant)
    On Error Resume Next
    Dim mailItem As Object 'Outlook.mailItem 'Tools>References>Microsoft Outlook X.xx Object Library
    Const OutlookMailItem As Long = 0
    Set mailItem = CreateObject("Outlook.Application").CreateItem(OutlookMailItem) ' Outlook.Application.CreateItem(olMailItem)
    With mailItem
        .To = emailAddress
        .CC = CC
        .BCC = BCC
        .Subject = Subject
        .Body = Body

        Dim attachment As Variant
        For Each attachment In attachments
            .attachments.Add attachment
        Next

        .Display

        .Send
    End With
    On Error GoTo 0
End Sub

要在单元格A1中处理的邮件表 - 保留格式

1 个答案: