Страницы: Пред. 1 2
RSS
Как сделать отправку в Telegram из макроса VBA Excel, Telegram из макроса VBA Excel
 
Ребят, помогите к картинке прикрутить еще и текстовое описание.
У метода sendPhoto помимо указания чат-ID и photo есть еще опциональная возможность указывать caption (текст, который будет прикреплен к картинке).
Вроде все правильно делаю, но не хотят сообщения на русском прикрепляться, хотя и энкодирую их в UTF-8.
Если прикреплять сообщение английскими буквами, то все ок отрабатывает, с кириллицей же никак не хочет.

Код
Public Sub telegram_send_picture()
 
    Const URL = "https://api.telegram.org/bot"
    Const TOKEN = "bla-bla-bla:some_TOKEN"   ' тут токен бота
    Const METHOD_NAME = "/sendPhoto?"
    Const CHAT_ID = "-1234567890"            ' тут ID чата, куда послать картинку
       
    Const FOLDER = "C:\Тест бота Телеграмм\"    ' папка, в которой лежит картинка
    Const JPG_FILE = "Picture1.jpg"             ' имя картинки с расширением
    
    Dim msg$: msg = "Какой-то русский текст"    ' сообщение (описание), которое надо прикрепить к картинке. 
' Если сюда указать английский текст, то все отлично работает. С русскими буквами не хочет
    msg = EncodeUTF8noBOM(msg)                  ' переводим русский текст в UTF-8 (функция описана ниже)
     
    Dim data As Object, key
    Set data = CreateObject("Scripting.Dictionary")
    data.Add "chat_id", CHAT_ID                 ' добавляем в словарь чат-ID
    data.Add "caption", msg                     ' добавляем в словарь текст, который надо прикрепить к картинке, переведенный в UTF-8
     
    
    BOUNDARY = "--OYWFRYGNCYQAOCCT44655,4239930556"   ' разделитель для form-data
 
    'заполняем словарь форм датами чат-ID и сообщения
    Dim part As String, ado As Object
    For Each key In data.keys
        part = part & "--" & BOUNDARY & vbCrLf
        part = part & "Content-Disposition: form-data; name=""" & key & """" & vbCrLf & vbCrLf
        part = part & data(key) & vbCrLf
    Next
    
    ' filename
    part = part & "--" & BOUNDARY & vbCrLf
    part = part & "Content-Disposition: form-data; name=""photo""; filename=""" & JPG_FILE & """" & vbCrLf & vbCrLf


    ' read jpg file as binary
    Dim jpg
    Set ado = CreateObject("ADODB.Stream")
    ado.Type = 1 'binary
    ado.Open
    ado.LoadFromFile FOLDER & JPG_FILE
    ado.Position = 0
    jpg = ado.read
    ado.Close
 
    ' combine part, jpg , end
    ado.Open
    ado.Position = 0
    ado.Type = 1 ' binary
    ado.Write ToBytes(part)
    ado.Write jpg
    ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "---")
    ado.Position = 0
 
    Dim req As Object, reqURL As String
    Set req = CreateObject("MSXML2.XMLHTTP")
    reqURL = URL & TOKEN & METHOD_NAME
    With req
        .Open "POST", reqURL, False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
        .send ado.read
        MsgBox .responseText
    End With
 
End Sub
 
Function ToBytes(str As String) As Variant
    Dim ado As Object
    Set ado = CreateObject("ADODB.Stream")
    ado.Open
    ado.Type = 2 ' text
    ado.Charset = "_autodetect"
    ado.WriteText str
    ado.Position = 0
    ado.Type = 1
    ToBytes = ado.read
    ado.Close
End Function

' перевод в UTF8
Function EncodeUTF8noBOM(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 4095: t = Chr(AscW(l) \ 64 \ 64 + 224) & Chr(AscW(l) \ 64) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Is > 127: t = Chr(AscW(l) \ 64 + 192) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Else: t = l
        End Select
        EncodeUTF8noBOM = EncodeUTF8noBOM & t
    Next
End Function



В итоге в виде response приходит ошибка, что текст д.б. декодирован в UTF8. Но он ведь и декодирован.
[img]C:\Тест%20бота%20Телеграмм\Безымянный.jpg[/img]
 
Всем, привет!

А у меня вопрос по текстовой части: возможно как-либо отправить помимо текста(кириллического) еще и символы(снежинки например(те, которые вставляются через вставить символ))/смайлики?
 
Добрый день! Возможно.
Берете символы в кодировке UTF-8, например отсюда https://apps.timwhitlock.info/emoji/tables/unicode
Только \x заменяете на %, чтобы вместо \xE2\x9D\x84 получилось %E2%9D%84
 
Цитата
dimbaks: Берете символы в кодировке UTF-8, например отсюда
или из основного источника
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
написал:
Ребят, помогите к картинке прикрутить еще и текстовое описание.
У метода sendPhoto помимо указания чат-ID и photo есть еще опциональная возможность указывать caption (текст, который будет прикреплен к картинке).
Вроде все правильно делаю, но не хотят сообщения на русском прикрепляться, хотя и энкодирую их в UTF-8.
Если прикреплять сообщение английскими буквами, то все ок отрабатывает, с кириллицей же никак не хочет.

Код
    [URL=#]?[/URL]       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  70  71  72  73  74  75  76  77  78  79  80  81  82  83  84  85  86  87  88  89  90  91      Public   Sub   telegram_send_picture()                Const   URL =   " https://api.telegram.org/bot "          Const   TOKEN =   "bla-bla-bla:some_TOKEN"     ' тут токен бота          Const   METHOD_NAME =   "/sendPhoto?"          Const   CHAT_ID =   "-1234567890"              ' тут ID чата, куда послать картинку                      Const   FOLDER = "C:\Тест бота Телеграмм\"      ' папка, в которой лежит картинка          Const   JPG_FILE =   "Picture1.jpg"               ' имя картинки с расширением                   Dim   msg$: msg =   "Какой-то русский текст"      ' сообщение (описание), которое надо прикрепить к картинке.     ' Если сюда указать английский текст, то все отлично работает. С русскими буквами не хочет          msg = EncodeUTF8noBOM(msg)                    ' переводим русский текст в UTF-8 (функция описана ниже)                    Dim   data   As   Object  , key          Set   data = CreateObject(  "Scripting.Dictionary"  )          data.Add   "chat_id"  , CHAT_ID                   ' добавляем в словарь чат-ID          data.Add   "caption"  , msg                       ' добавляем в словарь текст, который надо прикрепить к картинке, переведенный в UTF-8                             BOUNDARY =   "--OYWFRYGNCYQAOCCT44655,4239930556"     ' разделитель для form-data                'заполняем словарь форм датами чат-ID и сообщения          Dim   part   As   String  , ado   As   Object          For   Each   key   In   data.keys              part = part &   "--"   & BOUNDARY & vbCrLf              part = part &   "Content-Disposition: form-data; name="  ""   & key &   ""  ""   & vbCrLf & vbCrLf              part = part & data(key) & vbCrLf          Next                   ' filename          part = part &   "--"   & BOUNDARY & vbCrLf          part = part &   "Content-Disposition: form-data; name="  "photo"  "; filename="  ""   & JPG_FILE &   ""  ""   & vbCrLf & vbCrLf                ' read jpg file as binary          Dim   jpg          Set   ado = CreateObject(  "ADODB.Stream"  )          ado.Type = 1   'binary          ado.Open          ado.LoadFromFile FOLDER & JPG_FILE          ado.Position = 0          jpg = ado.read          ado.Close                ' combine part, jpg , end          ado.Open          ado.Position = 0          ado.Type = 1   ' binary          ado.Write ToBytes(part)          ado.Write jpg          ado.Write ToBytes(vbCrLf &   "--"   & BOUNDARY &   "---"  )          ado.Position = 0                Dim   req   As   Object  , reqURL   As   String          Set   req = CreateObject(  "MSXML2.XMLHTTP"  )          reqURL = URL & TOKEN & METHOD_NAME          With   req              .Open   "POST"  , reqURL,   False              .setRequestHeader   "Content-Type"  ,   "multipart/form-data; boundary="   & BOUNDARY              .send ado.read              MsgBox .responseText          End   With          End   Sub          Function   ToBytes(str   As   String  )   As   Variant          Dim   ado   As   Object          Set   ado = CreateObject(  "ADODB.Stream"  )          ado.Open          ado.Type = 2   ' text          ado.Charset =   "_autodetect"          ado.WriteText str          ado.Position = 0          ado.Type = 1          ToBytes = ado.read          ado.Close    End   Function       ' перевод в UTF8    Function   EncodeUTF8noBOM(  ByVal   txt   As   String  )   As   String          For   i = 1   To   Len(txt)              l = Mid(txt, i, 1)              Select   Case   AscW(l)                  Case   Is   > 4095: t = Chr(AscW(l) \ 64 \ 64 + 224) & Chr(AscW(l) \ 64) & Chr(8 * 16 + AscW(l)   Mod   64)                  Case   Is   > 127: t = Chr(AscW(l) \ 64 + 192) & Chr(8 * 16 + AscW(l)   Mod   64)                  Case   Else  : t = l              End   Select              EncodeUTF8noBOM = EncodeUTF8noBOM & t          Next    End   Function   
   


В итоге в виде response приходит ошибка, что текст д.б. декодирован в UTF8. Но он ведь и декодирован.
[img]c:\%D0%A2%D0%B5%D1%81%D1%82%20%D0%B1%D0%BE%D1%82%D0%B0%20%D0%A2%D0%B5%D0%BB%D0%B5%D0%B3%D1%80%D0%B0%D0%BC%D0%BC\%D0%91%D0%B5%D0%B7%D1%8B%D0%BC%D1%8F%D0%BD%D0%BD%D1%8B%D0%B9.jpg[/img]
Изменено: Shevch - 31.05.2022 13:56:42
 
Цитата
написал:
Ребят, помогите к картинке прикрутить еще и текстовое описание.
У метода sendPhoto помимо указания чат-ID и photo есть еще опциональная возможность указывать caption (текст, который будет прикреплен к картинке).
Вроде все правильно делаю, но не хотят сообщения на русском прикрепляться, хотя и энкодирую их в UTF-8.
Если прикреплять сообщение английскими буквами, то все ок отрабатывает, с кириллицей же никак не хочет.

Код
    [URL=#]?[/URL]       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  70  71  72  73  74  75  76  77  78  79  80  81  82  83  84  85  86  87  88  89  90  91      Public   Sub   telegram_send_picture()                Const   URL =   " https://api.telegram.org/bot "          Const   TOKEN =   "bla-bla-bla:some_TOKEN"     ' тут токен бота          Const   METHOD_NAME =   "/sendPhoto?"          Const   CHAT_ID =   "-1234567890"              ' тут ID чата, куда послать картинку                      Const   FOLDER = "C:\Тест бота Телеграмм\"      ' папка, в которой лежит картинка          Const   JPG_FILE =   "Picture1.jpg"               ' имя картинки с расширением                   Dim   msg$: msg =   "Какой-то русский текст"      ' сообщение (описание), которое надо прикрепить к картинке.     ' Если сюда указать английский текст, то все отлично работает. С русскими буквами не хочет          msg = EncodeUTF8noBOM(msg)                    ' переводим русский текст в UTF-8 (функция описана ниже)                    Dim   data   As   Object  , key          Set   data = CreateObject(  "Scripting.Dictionary"  )          data.Add   "chat_id"  , CHAT_ID                   ' добавляем в словарь чат-ID          data.Add   "caption"  , msg                       ' добавляем в словарь текст, который надо прикрепить к картинке, переведенный в UTF-8                             BOUNDARY =   "--OYWFRYGNCYQAOCCT44655,4239930556"     ' разделитель для form-data                'заполняем словарь форм датами чат-ID и сообщения          Dim   part   As   String  , ado   As   Object          For   Each   key   In   data.keys              part = part &   "--"   & BOUNDARY & vbCrLf              part = part &   "Content-Disposition: form-data; name="  ""   & key &   ""  ""   & vbCrLf & vbCrLf              part = part & data(key) & vbCrLf          Next                   ' filename          part = part &   "--"   & BOUNDARY & vbCrLf          part = part &   "Content-Disposition: form-data; name="  "photo"  "; filename="  ""   & JPG_FILE &   ""  ""   & vbCrLf & vbCrLf                ' read jpg file as binary          Dim   jpg          Set   ado = CreateObject(  "ADODB.Stream"  )          ado.Type = 1   'binary          ado.Open          ado.LoadFromFile FOLDER & JPG_FILE          ado.Position = 0          jpg = ado.read          ado.Close                ' combine part, jpg , end          ado.Open          ado.Position = 0          ado.Type = 1   ' binary          ado.Write ToBytes(part)          ado.Write jpg          ado.Write ToBytes(vbCrLf &   "--"   & BOUNDARY &   "---"  )          ado.Position = 0                Dim   req   As   Object  , reqURL   As   String          Set   req = CreateObject(  "MSXML2.XMLHTTP"  )          reqURL = URL & TOKEN & METHOD_NAME          With   req              .Open   "POST"  , reqURL,   False              .setRequestHeader   "Content-Type"  ,   "multipart/form-data; boundary="   & BOUNDARY              .send ado.read              MsgBox .responseText          End   With          End   Sub          Function   ToBytes(str   As   String  )   As   Variant          Dim   ado   As   Object          Set   ado = CreateObject(  "ADODB.Stream"  )          ado.Open          ado.Type = 2   ' text          ado.Charset =   "_autodetect"          ado.WriteText str          ado.Position = 0          ado.Type = 1          ToBytes = ado.read          ado.Close    End   Function       ' перевод в UTF8    Function   EncodeUTF8noBOM(  ByVal   txt   As   String  )   As   String          For   i = 1   To   Len(txt)              l = Mid(txt, i, 1)              Select   Case   AscW(l)                  Case   Is   > 4095: t = Chr(AscW(l) \ 64 \ 64 + 224) & Chr(AscW(l) \ 64) & Chr(8 * 16 + AscW(l)   Mod   64)                  Case   Is   > 127: t = Chr(AscW(l) \ 64 + 192) & Chr(8 * 16 + AscW(l)   Mod   64)                  Case   Else  : t = l              End   Select              EncodeUTF8noBOM = EncodeUTF8noBOM & t          Next    End   Function   
   


В итоге в виде response приходит ошибка, что текст д.б. декодирован в UTF8. Но он ведь и декодирован.
[img]c:\%D0%A2%D0%B5%D1%81%D1%82%20%D0%B1%D0%BE%D1%82%D0%B0%20%D0%A2%D0%B5%D0%BB%D0%B5%D0%B3%D1%80%D0%B0%D0%BC%D0%BC\%D0%91%D0%B5%D0%B7%D1%8B%D0%BC%D1%8F%D0%BD%D0%BD%D1%8B%D0%B9.jpg[/img]
Код
Sub Messegephoto()
telegram_pruebas_photo
Send_Message
End Sub


Function telegram_pruebas_photo()
 
    Const URL = "https://api.telegram.org/bot"
    Const Token = "Вставить Токен"
    Const METHOD_NAME = "/sendPhoto?"
    Const CHAT_ID = "ID ЧАТ"
     
    Const FOLDER = "C:\documents\\"
    Const JPG_FILE = "ZOOM.jpg"
     
    Dim data As Object, key
    Set data = CreateObject("Scripting.Dictionary")
    data.Add "chat_id", CHAT_ID
     
    ' generate boundary
    Dim BOUNDARY, s As String, n As Integer
    For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
    BOUNDARY = s & CDbl(Now)
 
    Dim part As String, ado As Object
    For Each key In data.keys
        part = part & "--" & BOUNDARY & vbCrLf
        part = part & "Content-Disposition: form-data; name=""" & key & """" & vbCrLf & vbCrLf
        part = part & data(key) & vbCrLf
    Next
    ' filename
    part = part & "--" & BOUNDARY & vbCrLf
    part = part & "Content-Disposition: form-data; name=""photo""; filename=""" & JPG_FILE & """" & vbCrLf & vbCrLf
     
    ' read jpg file as binary
    Dim jpg
    Set ado = CreateObject("ADODB.Stream")
    ado.Type = 1 'binary
    ado.Open
    ado.LoadFromFile FOLDER & JPG_FILE
    ado.Position = 0
    jpg = ado.read
    ado.Close
 
    ' combine part, jpg , end
    ado.Open
    ado.Position = 0
    ado.Type = 1 ' binary
    ado.Write ToBytes(part)
    ado.Write jpg
    ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "---")
    ado.Position = 0
 
    Dim req As Object, reqURL As String
    Set req = CreateObject("MSXML2.XMLHTTP")
    reqURL = URL & Token & METHOD_NAME
    With req
        .Open "POST", reqURL, False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
        .send ado.read
        'MsgBox .responseText ??????? ??????? ????
    End With
 
End Function
 
Function ToBytes(str As String) As Variant
 
    Dim ado As Object
    Set ado = CreateObject("ADODB.Stream")
    ado.Open
    ado.Type = 2 ' text
    ado.Charset = "_autodetect"
    ado.WriteText str
    ado.Position = 0
    ado.Type = 1
    ToBytes = ado.read
    ado.Close
 
End Function

Function Send_Message()
Dim objRequest As Object
Dim strChatId As String
Dim strMessage As String
Dim strPostData As String

strChatId = Sheets("ZOOM").range("L1").Value   '
strAPI_Token = range("L2").Value               '
strMessage = range("B4").Value                 '
strPostData = "chat_id=" & strChatId & "&text=" & strMessage
Set objRequest = CreateObject("MSXML2.XMLHTTP")

With objRequest
    .Open "POST", "https://api.telegram.org/bot" & strAPI_Token & "/sendMessage?", False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send (strPostData)
End With

End Function



 
Спасибо, но это не совсем то. В данном случае два отдельных сообщения будут посылаться, сначала отдельно сообщение с картинкой, потом отдельно текстовое сообщение.
Я же пытаюсь отправить одним сообщением картинку, которая в этом же сообщении будет сопровождаться определенным текстом.
 
Люди, вы что делаете? Теперь школьнички заспамят всех...
У меня сын уже попробовал в колледже бота подключить на общую рассылку (правда, на питоне), я имел неприятный разговор с директором. Но ладно, я бы понял, если бы сам написал, и от радости тестил на однокурсниках, а просто на 4PDA скачал.
Читали "Хищные вещи века" Стругацких? Вот это оно и есть.
 
Не участников форума надо ругать, а сыном заниматься что бы он свою энергию и  мысли в нужное русло направил.

Ситуация такая:
Есть таблица. ( :D Логично, правда?). Есть данные распиханные по ячейкам.
Представим что ведём подсчёт результатов беговой эстафеты. Столбцы, например, такие:
Время  Время2 Имя Результат
1 02:30 03:45 Ваня0:45
2 02:30 04:10 Маша 01:40
И т.д.
Есть две кнопки "! место" и "2 место"

Для отправки нам, например, нужны данные из столбцов  А С D F.

То есть нужно что бы в чат улетали данные из ячеек на пересечении конкретных столбцов, но на основе АКТИВНОЙ СТРОКИ.

Размышляя, в том числе и благодаря этой теме пришёл к таким мыслям:

Код message = RussianStringToURLEncode_New(ActiveCell.Text) Отправляет текст в выделенной ячейке.  Тут всё понятно.

Код message2 = RussianStringToURLEncode_New(Range("A1").Text) Отправляет текст находящийся в ячейке А1. Тут всё понятно.

Если я напишу составное условие sURL = "https://api.telegram.org/bot"; & Token & "/sendMessage?chat_id=" & ChatID & "&text=" & message & message2 я отправлю сообщение содержащее текст в выделенной ячейке и текст из ячейки А1. Тут тоже всё понятно.
А дальше как быть?


Ответ на поверхности, что-то не соображу...

И ещё завис над созданием кнопок которые отправляют шаблонный текст "я на месте" и "отошёл" без задействования ячеек таблицы.



Если не сам ответ, то в какую сторону копать?

полистал форум ещё раз, нашёл мысль вот какую:
Код
Sub xxx()  
Dim namb As Long  
Dim activeRow As Long  
activeRow = ActiveCell.Row  
namb = activeRow  
MsgBox namb  
End Sub  

Получается что нужно  message2 = RussianStringToURLEncode_New(Range("=Лист1!C2").Text)
Переделать в ...   типа такого:  message3 = RussianStringToURLEncode_New(activeRow = ActiveCell.Row; Range("myRange1").Columns(А; С; D; F).Text)


Решил пока через спрятанные ячейки с функцией "СЦЕПИТЬ"
Берёт ячейку из столбца "Х" на пересечении с активной строкой.
Решение кривое, но работает ) Спасибо за идеи, много вычитал на этом на форуме.
Код
 message = RussianStringToURLEncode_New(Cells(ActiveCell.Row, 24).Text) 'берёт данные из сборной ячейки АКТИВНОЙ СТРОКИ (данном случае столбец X)
Изменено: Константин - - 18.06.2022 15:33:33
Страницы: Пред. 1 2
Читают тему (гостей: 1)
Наверх