2017-03-06 147 views
2

我正在使用以下VBA代碼嘗試複製工作簿中的一個範圍,並將其粘貼到電子郵件中: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:[email protected]>") 
Call doc.ReplaceItemValue("ReplyTo", "[email protected]") 
Call doc.ReplaceItemValue("DisplaySent", "[email protected]") 

'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 
+1

哪一行返回錯誤?它是否設置了WB3 = Workbooks.Open(Range(「F」&i).value)'?如果是這樣,您是否已驗證具有預期名稱的工作簿存在? –

+0

@ destination-data查看更新後的問題 – user7415328

+1

'WB3.Sheets(1).Range' – Slai

回答

0

WB3是Workbook對象。工作簿不支持range property。相反,請使用worksheet object

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

這條線在它自己不會做任何事情。如果你想選擇這些細胞調用選擇方法:

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

編輯

只注意到@Slai已經確定的根本原因,在意見。

+0

如果您使用其他用戶的評論作爲答案,那麼您應該將此答案標記爲[社區wiki](http ://meta.stackoverflow.com/questions/251597/question-with-no-answers-but-issue-solved-in-the-comments-or-extended-in-chat) – Ralph

+1

我的評論不是答案。我希望如果有多張紙,有人會提到使用紙張名稱而不是數字。看起來應該是'Set rng = WB3.Sheets(「Sheet1」)。Range ...'因爲它下面的行 – Slai

相關問題