Private Sub Workbook_Open()
ThisWorkbook.RefreshAll

Application.Wait Time:=Now + TimeValue("0:02:00")

Dim arrSelSheets(), i As Long
    Application.ScreenUpdating = False
 
 

    SD = Date
    SD = Format(SD, "YYYY.MM.DD")
    
 Worksheets("Booked_out").Range("a1:e100").Columns.AutoFit
 Worksheets("Short").Range("a1:e50").Columns.AutoFit



    ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
    For i = 1 To UBound(arrSelSheets)
        arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
    Next
     
 
    Worksheets(Array("Booked_out", "Short")).Select
    
    Worksheets(Array("Booked_out", "Short")).Copy
    BreakLinks ActiveWorkbook
    ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & SD & " Check" & ".xlsx"
    ActiveWorkbook.Close False
''
'    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
'        ThisWorkbook.Path & "\" & SD & " Check" & ".pdf", Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    Worksheets(arrSelSheets).Select

    Application.ScreenUpdating = True
'
    
    
    
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next

    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
   
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   '?
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "Alexander.Levev@sond.com"
    sSubject = SD & " Check"
    sBody = "Hello, find attached"
    sAttachment = ThisWorkbook.Path & "\" & SD & " Check" & ".pdf"
 
   
    With objMail
        .To = sTo
'        .CC = "Alexander.Levev@sond.com;Stepan.Baev@Sond.com"
        .CC = "Alexey.Ivanov@sond.com"
        .BCC = ""
        .Subject = sSubject
        .Body = sBody
        
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment
            End If
        End If
        .Send
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
    
    
    
    
    


End Sub

Sub BreakLinks(wb As Workbook)
    If wb Is Nothing Then Exit Sub
    Dim aLinks As Variant
    aLinks = wb.LinkSources(xlLinkTypeExcelLinks)
    If IsEmpty(aLinks) Then Exit Sub
    Dim v As Variant
    On Error Resume Next
        For Each v In aLinks
            wb.BreakLink v, xlLinkTypeExcelLinks
        Next
    On Error GoTo 0
End Sub