Question

我的代码是将不同工作表中的指定范围粘贴到Outlook电子邮件中。

我将代码分开以隐藏单元格。如果表格中有数据，我只想粘贴。

当隐藏特定范围的最后一行时，代码将失败。如果我取消隐藏最后一行，将导致电子邮件中出现空行。

即使隐藏了范围内的最后一行，如何运行代码？

Sub Trigger_Email()
'add rng as you add tabs. Remember to add rng under (i) Set rng and also         
(ii) With OutMail
Dim rng As Range 'For TAB01 Tab
Dim rng2 As Range 'For TAB02 Tab
Dim rng3 As Range 'For TAB03 Tab
Dim rng4 As Range 'For TAB04 Tab
Dim rng5 As Range 'For TAB05 Tab
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String

'Shows what appears at top of email
StrBody = "Hi XXX," & "<br>" & "<br>" & _
"The company provides" & "<br>" & "<br>" & _
"For your consideration& views." & "<br>" & "<br>"

Set rng = Nothing
On Error Resume Next
'This determines range to be printed into email.
'ADD rng(n+1) hear if you increase cover type. Determine range here as well.
Set rng = 
Sheets("TAB01").Range("A5:G22").Rows.SpecialCells(xlCellTypeVisible)
Set rng2 = 
Sheets("TAB02").Range("A1:F39").Rows.SpecialCells(xlCellTypeVisible)
Set rng3 = 
Sheets("TAB03").Range("A1:F50").Rows.SpecialCells(xlCellTypeVisible)
Set rng4 = 
Sheets("TAB04").Range("A1:F50").Rows.SpecialCells(xlCellTypeVisible)
Set rng5 = 
Sheets("TAB05").Range("A1:F50").Rows.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
       vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
End If

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

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

'add more rng tabs below to display in body of email.
With OutMail
    .To = "TEST@HOTMAIL.COM"
    .CC = ""
    .BCC = ""
    .Subject = "TEST 01" & Cells(5, 1)
    .HTMLBody = StrBody & rangetoHTML(rng) & rangetoHTML(rng3) & 
    rangetoHTML(rng4) & rangetoHTML(rng5) & rangetoHTML(rng2)
    .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

'Ignore this section. It prints excel format into HTML format in email.

Function rangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TemTAB05B 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 TemTAB05B = Workbooks.Add(1)
With TemTAB05B.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
With TemTAB05B.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:=TempFile, _
    Sheet:=TemTAB05B.Sheets(1).Name, _
    Source:=TemTAB05B.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 TemTAB05B
TemTAB05B.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TemTAB05B = Nothing

End Function

选中要粘贴的单元格范围时出错

0 个答案: