Public Sub RunPromo(itm As Outlook.MailItem)
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open("C:\Autoreport\OLAPGO.xlsm")
xlApp.Application.Visible = True
xlApp.Run "OLAPGO.xlsm!StartSubs"
xlWb.Close True: xlApp.Quit
End Sub

Sub StartSubs()

Set xlWb = Workbooks.Open("C:\Autoreport\PAFIN.xlsm")
Application.Run "PAFIN.xlsm!GoSend", 1, 1, "XXX" ' ХХХ - реальный ID чата

End Sub

Sub GoSend(Go As Integer, ExitEx As Integer, ChatIDD As String)
Dim ExName As String, rDataR As Range, Pic As String, CFO As String, CFO1 As String
Application.Calculation = xlManual
Application.DisplayAlerts = False

If Go = 1 Then

ExName = ThisWorkbook.Name
ThisWorkbook.RefreshAll

Calculate
Set rDataR = SelectAll(ExName, "Main", 21, 1, 34, 16)
Pic = RtP(rDataR, "PA")
Call SendBitrix(ChatIDD, Pic)

For i = 1 To 10
CFO = ActiveWorkbook.Sheets("Список").Cells(i, 1)
CFO1 = CFO
CFO = Replace("[ЦФО].[ЦФОАналитика].&[CFO]", "CFO", CFO)
ActiveWorkbook.SlicerCaches("Срез_ЦФО_Аналитика").VisibleSlicerItemsList = Array(CFO)
Calculate
Set rDataR = SelectAll(ExName, "ЦФОData", 1, 1, 42, 16)
Pic = RtP(rDataR, CFO1)
Call SendBitrix(ChatIDD, Pic)
Next i

End If

If Weekday(Now) = 2 Then
CopyBook = ThisWorkbook.Name
With Workbooks(CopyBook).Sheets("Main")
TextCopy = .Range(.Cells(7, 2), .Cells(16, 2))
.Cells(7, 16).Resize(UBound(TextCopy, 1), UBound(TextCopy, 2)).Value = TextCopy
End With
End If

Function RtP(Sel As Range, Optional Chen As String)
    Dim sName As String, wsTmpSh As Worksheet, i As Long, Name As String, Folder As String
    
    FullPath = ActiveWorkbook.FullName
    i = InStrRev(FullPath, "\") 
    Name = Mid(FullPath, i + 1)
    Folder = Left(FullPath, i)
    
    If TypeName(Sel) <> "Range" Then
        Exit Function
    End If

    With Sel
        'Application.CutCopyMode = False
        '.Copy
        .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        If Chen <> "" Then sName = Folder & Chen & ".png" Else sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range" & ".png"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName, FilterName:="png"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    RtP = sName
End Function

Function SelectAll(table As String, shet As String, startrow As Long, startcol As Long, Optional FinRow As Long, Optional FinCol As Long)
With Workbooks(table).Sheets(shet)
If FinRow = 0 Then lLastRow = .Cells(Rows.Count, 2).End(xlUp).Row Else lLastRow = FinRow
If FinCol = 0 Then lLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column Else lLastCol = FinCol
Set SelectAll = .Range(Sheets(shet).Cells(startrow, startcol), Sheets(shet).Cells(lLastRow, lLastCol))
End With
End Function

Function SendBitrix(DialogID As String, Filename As String)
PuthExe = "\\SRVDC\Autoreport\bitrix.exe"
HookId = "XXX" ' ХХХ - условно корректное значение
HookKey = "XXX" ' ХХХ - условно корректное значение
Folder = "XXX"  ' ХХХ - условно корректное значение
WHat = Len(DialogID)
If Len(DialogID) > 4 Then
ShellParam = PuthExe & " -id " & HookId & " -profile " & HookKey & " -storage " & Folder & " -input-file " & Filename & " -chat " & DialogID
Else
ShellParam = PuthExe & " -id " & HookId & " -profile " & HookKey & " -storage " & Folder & " -input-file " & Filename & " -dialog " & DialogID
End If
Set WshShell = CreateObject("WScript.Shell")
Return1 = WshShell.Run(ShellParam, 0, True)
Kill (Filename)
End Function