Использование различного диапазона для вставки в электронную почту Outlook - PullRequest
Новая
       71

Использование различного диапазона для вставки в электронную почту Outlook

0 голосов
/ 11 декабря 2019

Я использовал код из других примеров «вставьте диапазон Excel в Outlook / Email» на сайте (Рона де Брюина), но у меня возникли проблемы с использованием переменного диапазона внутри функции. Я установил два диапазона (rng1 и rng2) и две соответствующие функции для использования, но моя ошибка в этой строке (45), которая извлекает диапазон переменной: 

Set rng1 = Sheets("Sheet2").Range(Cells(6, 8), Cells((NewRowFxn(NewRow) - 1), "N")).SpecialCells(xlCellTypeVisible)

(IВы только что начали с первого диапазона (rng1) и он не работает, поэтому еще не настроен код для rng2)

Как настроить изменяемый диапазон, чтобы найтиПоследняя строка данных и затем введите ее в rng1 & rgn2 уравнения?

Спасибо за вашу помощь.

Это мой код до сих пор: 

Sub Macro1()
 Dim rng1 As Range
 Dim rng2 As Range
 Dim OutApp As Object
 Dim OutMail As Object
 Dim sCC As String, sSubj As String, sEmAdd As String
 Dim mail_bodyA As String
 Dim mail_bodyB As String
 Dim mail_bodyC As String
 Dim f_name As String
 Dim fiscalq As String


 '// Change the values of these variables to suit
 sEmAdd = Sheet2.Range("E7")
 sCC = ""
 sSubj = Sheet2.Range("C2")
 mail_bodyA = Sheet1.Range("K2")
 mail_bodyB = Sheet1.Range("K4")
 mail_bodyC = Sheet1.Range("K6")
 f_name = Sheet2.Range("G7")
 fiscalq = Sheet2.Range("D7")
  Set rng1 = Nothing
 On Error Resume Next
 Set rng1 = Sheets("Sheet2").Range(Cells(6, 8), Cells((NewRowFxn(NewRow) - 1), "N")).SpecialCells(xlCellTypeVisible)
 'Set rng1 = Sheets("Sheet2").Range("H6:N7").SpecialCells(xlCellTypeVisible)
 On Error GoTo 0
 With Application
 .EnableEvents = 0
 .ScreenUpdating = 0
 .Calculation = xlCalculationManual
 End With
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)
 On Error Resume Next
 With OutMail
 .To = sEmAdd
 .CC = sCC
 .Subject = sSubj
 .HTMLBody = mail_bodyA & RangetoHTML(rng1)
 .Display '// Change this to .Display if you want to view the email before sending. .Send originally
 End With
 On Error GoTo 0
 With Application
 .EnableEvents = 1
 .Calculation = xlCalculationAutomatic
 End With
 Set OutMail = Nothing: Set OutApp = Nothing
End Sub
Function RangetoHTML(rng1 As Range)
 Dim fso As Object, ts As Object, TempWB As Workbook, TempFile As String
 TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 rng1.Copy
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
 .Cells(1).Select
 Application.CutCopyMode = False
 End With
 With TempWB.PublishObjects.Add( _
 SourceType:=xlSourceRange, _
 Filename:=TempFile, _
 Sheet:=TempWB.Sheets(1).Name, _
 Source:=TempWB.Sheets(1).UsedRange.Address, _
 HtmlType:=xlHtmlStatic)
 .Publish (True)
 End With
 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=")
 TempWB.Close 0
 Kill TempFile
 Set ts = Nothing: Set fso = Nothing: Set TempWB = Nothing

End Function
Function NewRowFxn()
 Dim NewRow As Integer
 NewRow = 6
 Do
    DoEvents
    NewRow = NewRow + 1
    Item = Sheet2.Range("N" & NewRow)
 Loop Until Item = ""
 End Function

 Function OldRowFxn()
 Dim OldRow As Integer
 OldRow = 6
    Do
    DoEvents
    OldRow = OldRow + 1
    Itemold = Sheet2.Range("V" & OldRow)
    Loop Until Itemold = ""
 End Function
...