vba 从工作簿复制范围并粘贴到电子邮件中？答案

【问题标题】：vba copy range from workbook and paste into email?vba 从工作簿复制范围并粘贴到电子邮件中？
【发布时间】：2017-07-26 05:44:13
【问题描述】：

我正在使用以下 VBA 代码尝试从工作簿中复制一个范围并将其粘贴到电子邮件中：

这是导致问题的一段代码。此行出现错误 438“对象不支持此属性或方法”：

WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)

代码：

'Insert Range
Dim app As New Excel.Application
app.Visible = False
'open a workbook that has same name as the sheet name
Set WB3 = Workbooks.Open(Range("F" & i).value)
'select cell A1 on the target book
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)

Call stream.WriteText(rangetoHTML(rng))

如果我使用 ThisWorkbook，似乎可以正常工作。我定义其他工作簿的方式有问题。

我在 F 列中的单元格都包含有效路径，例如：

G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\Accrol.xlsx

请问有人可以告诉我哪里出错了吗？理想情况下，我宁愿从工作簿中获取范围而不必打开它，但可惜我是 vba 的新手，所以不确定这是否可行。

目的是将范围放入电子邮件正文中。

Call stream.WriteText(rangetoHTML(rng))

完整代码：

Sub Send()
Dim answer As Integer
    answer = MsgBox("Are you sure you want to Send All Announcements?", vbYesNo + vbQuestion, "Notice")
    If answer = vbNo Then
    Exit Sub

    Else

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim Attachment As String
Dim WB3 As Workbook
Dim WB4 As Workbook
Dim rng As Range
Dim db As Object
Dim doc As Object
Dim body As Object
Dim header As Object
Dim stream As Object
Dim session As Object
Dim i As Long
Dim j As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, ws As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row  'Finds the last used row

j = 18

With ThisWorkbook.Worksheets(1)

For i = 18 To LastRow


'Start a session of Lotus Notes
Set session = CreateObject("Notes.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Set db = session.CurrentDatabase
Set stream = session.CreateStream
' Turn off auto conversion to rtf
session.ConvertMime = False



'Email Code

'Create email to be sent

Set doc = db.CreateDocument
doc.Form = "Memo"
Set body = doc.CreateMIMEEntity
Set header = body.CreateHeader("Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
Call header.SetHeaderVal("HTML message")

'Set From
Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials@Lidl.co.uk>")
Call doc.ReplaceItemValue("ReplyTo", "Food.Specials@Lidl.co.uk")
Call doc.ReplaceItemValue("DisplaySent", "Food.Specials@Lidl.co.uk")

'To
Set header = body.CreateHeader("To")
Call header.SetHeaderVal(Range("Q" & i).value)


'Email Body
Call stream.WriteText("<HTML>")
Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">")
Call stream.WriteText("<p>Good " & Range("A1").value & ",</p>")
Call stream.WriteText("<p>Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & ".<br>Please check, sign and send this back to us within 24 hours in confirmation of this order. Please also inform us of when we can expect the samples.</p>")
Call stream.WriteText("<p>The details are as follows:</p>")

'Insert Range
Dim app As New Excel.Application
app.Visible = False
'open a workbook that has same name as the sheet name
Set WB3 = Workbooks.Open(Range("F" & i).value)
'select cell A1 on the target book
WB3.Range("A20:J30").SpecialCells (xlCellTypeVisible)

Call stream.WriteText(rangetoHTML(rng))


Call stream.WriteText("<p><b>N.B.  A volume break down by RDC will follow 4/5 weeks prior to the promotion. Please note that this is your responsibility to ensure that the orders you receive from the individual depots match the allocation.</b></p>")
Call stream.WriteText("<p>We also need a completed Product Technical Data Sheet. Please complete this sheet and attach the completed sheet in your response.</p>")

'Attach file
Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")


Call stream.WriteText("<BR><p>Please note the shelf life on delivery should be 75% of the shelf life on production.</p></br>")
'Signature
Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Grüßen,</p></br>")
Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>")

Call stream.WriteText("<table border=""0"">")
Call stream.WriteText("<tr>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("</tr>")
Call stream.WriteText("</table>")


Call stream.WriteText("</font>")
Call stream.WriteText("</body>")
Call stream.WriteText("</html>")

Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)

Call doc.Send(False)
session.ConvertMime = True ' Restore conversion - very important


'Clean Up the Object variables - Recover memory
    Set db = Nothing
    Set session = Nothing
    Set stream = Nothing
    Set doc = Nothing
    Set body = Nothing
    Set header = Nothing

    WB3.Close savechanges:=False

    Application.CutCopyMode = False

'Email Code

j = j + 1

Next i
End With


Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Success!" & vbNewLine & "Announcements have been sent."

End If
End Sub

【问题讨论】：

哪一行返回错误？是Set WB3 = Workbooks.Open(Range("F" & i).value)吗？如果是，您是否验证了具有预期名称的工作簿存在？
@destination-data 查看更新的问题
WB3.Sheets(1).Range
@Slai 你为什么不发表你的评论作为答案？
@Ralph 在我的手机上，这更像是对答案的暗示。一个好的答案需要解释并阅读整个问题，我还没有喝足够的咖啡:]

标签： excel vba

【解决方案1】：

WB3 是一个工作簿对象。工作簿不支持range property。相反，请使用worksheet object。

例子

WB3.Sheets(1).Range("A20:J30").SpecialCells(xlCellTypeVisible)

这条线本身不会做任何事情。如果要选择这些单元格，请调用 select 方法：

WB3.Sheets(1).Range("A20:J30").SpecialCells(xlCellTypeVisible).Select

编辑

刚刚注意到@Slai 已经在 cmets 中确定了根本原因。

【讨论】：

如果您使用其他用户的评论作为答案，那么您应该将此答案标记为community wiki
我的评论不是答案。如果有多张纸，我希望有人会提到使用纸的名称而不是数字。似乎应该是Set rng = WB3.Sheets("Sheet1").Range...，因为它下面有一行