Sub Отправка()
 Application.DisplayAlerts = False
 Dim OutlookApp As Object, SM As Object
 Dim cell As Range
 Set OutlookApp = CreateObject("Outlook.Application")
 For Each cell In Columns("e").Cells.SpecialCells(xlCellTypeConstants)
 If cell.Value Like "?*@?*.?*.?*" And _
 Application.WorksheetFunction.CountA(cell) > 0 Then
 Set SM = OutlookApp.CreateItem(olMailItem)
 With SM
 SM.To = cell.Value
 SM.Subject = "Привет"
 On Error Resume Next
 SM.Body = Activedocument.Content
 SM.HTMLBody = Activedocument.Content.Text
 SM.Display
 SM.HTMLBody = "Как дела?" & SM.HTMLBody
 Set SM = Nothing
 Set OutlookApp = Nothing
 End With
 End If
 Next
End Sub 

Sub Сохранение()
 Dim x As String
 strPath = "C:\Users\AVL\Desktop\Копилка"
 On Error Resume Next
 x = GetAttr(strPath) And 0
 If Err = 0 Then
   FileNameXls = strPath & "\" & "Сопоставимые АЗС" & " " & Sheets("Свод").Range("E2").Value & ".xls"
   ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
  Else
   MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
  End If
  Workbooks.Open (strPath & "\" & "Сопоставимые АЗС" & " " & Sheets("Свод").Range("E2").Value & ".xls")
    Dim iLinks As Variant, i&
    iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(iLinks) Then
    For i = 1 To UBound(iLinks)
     ActiveWorkbook.BreakLink Name:=iLinks(i), Type:=xlExcelLinks
    Next i
    End If
    Dim oVBComponent As Object, lCountLines As Long
    If ActiveWorkbook.VBProject.Protection = 1 Then
      MsgBox "VBProject выбранной книги защищён." & vbCrLf & _
       "     Компоненты не будут удалены.", vbExclamation, "Отмена выполнения"
      Exit Sub
     End If
     For Each oVBComponent In ActiveWorkbook.VBProject.VBComponents
     On Error Resume Next
     With oVBComponent
      Select Case .Type
      Case 1
          .Collection.Remove oVBComponent
      Case 2    '
          .Collection.Remove oVBComponent
      Case 3
          .Collection.Remove oVBComponent
      Case 100
           lCountLines = .CodeModule.CountOfLines
           .CodeModule.DeleteLines 1, lCountLines
      End Select
      End With
     Next
     Set oVBComponent = Nothing
    ActiveWorkbook.Sheets("Свод").Visible = False
    ActiveWorkbook.Close = False
End Sub