Решил задачу автоматизированной отправки отчетов в чаты Bitrix24 в виде картинок через веб-хук, все функции выполняются, но в конце выдает ошибку.
Что такое и как это работает:
1) В определенное время обновляется куб для olap, и отправляет письмо на почту сервера.
2) В аутлуке почты сервера настроено правило на запуск скрипта при получении определенного текста:
Код |
---|
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 |
3) В файле лежит всего один макрос который запускает макросы в других книгах
Код |
---|
Sub StartSubs() Set xlWb = Workbooks.Open("C:\Autoreport\PAFIN.xlsm") Application.Run "PAFIN.xlsm!GoSend", 1, 1, "XXX" ' ХХХ - реальный ID чата End Sub |
4) В конечных файлах есть несколько сводных таблиц с данными из OLAP подключения имеет один макрос и несколько функций.
Макрос: обновляет страницу, выбирает таблицу по указанному диапазону, переводит его в картинку-файл, возврат путь картинки и отправляет в программу для отправки сообщения и файлов через вебхук Bitrix24, далее на другом листе переключает срез и повторяет действия с каждым вариантом из списка.
Код |
---|
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 |
В результате код отрабатывает, приходит 1 картинка с 1 листа, и 10 со второго. После чего файл закрывается PAFIN.xlsm (который вызван последним), а файл вызванный из outlook : OLAPGO.xlsm (из пункта 2) остается висеть. В outlook VBA повисает ошибка.
"Ошибка
Указано измерение, недопустимое для текущего типа диаграммы."
При нажатии Debug показывает ошибку на запуске первой книги OLAPGO.xlsm.
Приложить оригинальный пример нет возможности т.к. использовать olap подключение вы не сможете, и протестить получение себе тоже (если у вас нет Bitrix24), но возможно на уровне кода и реализации вы видите очечную ошибку последовательности закрытия или еще чего то, раз все присылает значит отрабатывает точно, но что значит эта и ошибка и как ее обойти?
Уместил много, готов дополнить информацией если что то упустил.
Заранее благодарен.