Здравствуйте.
Есть макрос, который "пробегается" по нужным листам открытой книги, и создает новую книгу с копией листа из открытой.
Затем, эта книга прикрепляется вложением в Outlook и отправляется почтой.
Проблема в том, что у меня не получается в новую книгу, помимо нужного листа вставить ещё один (второй) лист "Проекты" из открытой книги.
Вот мой код:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
Sub createAndSendMail(MailTo As String, Subject As String, sheetName As String)
Dim objOutlookApp As Object, objMail As Object
Dim sBody As String
Dim FileN$
Dim WorkbookLinks As Variant
Dim Wb As Workbook
Dim N As Variant
Dim i As Long
FileN = ThisWorkbook.Path & "\" & "Справка_" & sheetName & "_" & Date & ".xlsx"
ThisWorkbook.Sheets(sheetName).Copy
'Отвязка ссылки. Начало
For Each N In ActiveWorkbook.names:
On Error Resume Next
N.Delete:
Next
Set Wb = ActiveWorkbook
WorkbookLinks = Wb.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(WorkbookLinks) Then
For i = LBound(WorkbookLinks) To UBound(WorkbookLinks)
Wb.BreakLink _
Name:=WorkbookLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
Else
End If
'Отвязка ссылки. Окончание
ActiveWorkbook.SaveCopyAs FileN
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
objOutlookApp.Session.Logon
Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
sBody = "Справка по отделу прикреплена."
With objMail
.To = MailTo
.CC = ""
.BCC = ""
.Subject = Subject
.Body = sBody
.Attachments.Add FileN
.Send
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
Kill FileN
End Sub
