如何在Excel发送范围内保留格式

时间:2019-06-07 11:09:44

标签: excel vba outlook

我对VBA还是很陌生,并使用我设法从网上找到的东西中解救出来。 我在下面获得了这段代码,以作为附件发送单元格范围,并且在某种程度上有效。

问题在于通过此代码创建的excel附件未保留格式(最重要的是列宽)

如何修改代码以保持源格式和宽度?

 Sub SendRange()    
    Dim xFile As String
    Dim xFormat As Long
    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim Ws As Worksheet
    Dim FilePath As String
    Dim FileName As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim WorkRng As Range
    xTitleId = "KutoolsforExcel"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Wb = Application.ActiveWorkbook
    Wb.Worksheets.Add
    Set Ws = Application.ActiveSheet
    WorkRng.Copy Ws.Cells(1, 1)
    Ws.Copy
    Set Wb2 = Application.ActiveWorkbook

    Select Case Wb.FileFormat
    Case xlOpenXMLWorkbook:
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    Case xlOpenXMLWorkbookMacroEnabled:
        If Wb2.HasVBProject Then
            xFile = ".xlsm"
            xFormat = xlOpenXMLWorkbookMacroEnabled
        Else
            xFile = ".xlsx"
            xFormat = xlOpenXMLWorkbook
        End If
    Case Excel8:
        xFile = ".xls"
        xFormat = Excel8
    Case xlExcel12:
        xFile = ".xlsb"
        xFormat = xlExcel12
    End Select

    FilePath = Environ$("temp") & "\"
    FileName = "MAB Taxi - " & Range("B1")
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat

    With OutlookMail
        .To = "email@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "MAB Taxi - " & Range("B1")
        .Body = "hello, please check and read this document. "
        .Attachments.Add Wb2.FullName
        .Send
    End With

    Wb2.Close
    Kill FilePath & FileName & xFile
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Ws.Delete

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

0 个答案:

没有答案