Telegram - Send Document via VBS

Const URL = "https://api.telegram.org/bot"
Const TOKEN = "xxxxxxxxxx"
Const METHOD_NAME = "/sendDocument?"
Const CHAT_ID = "xxxxxxxxxx"
Const FOLDER = "C:\"
Const DOCUMENT_FILE = "file.txt"

Dim data, key
Set data = CreateObject("Scripting.Dictionary")
data.Add "chat_id", CHAT_ID

' generate boundary
Dim BOUNDARY, s , n
For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
BOUNDARY = s & CDbl(Now)

Dim part , ado 
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=""document""; filename=""" & DOCUMENT_FILE & """" & vbCrLf & vbCrLf

' read document file as binary

Dim doc
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile FOLDER & DOCUMENT_FILE
ado.Position = 0
doc = ado.read
ado.Close
' combine part, document, end
ado.Open
ado.Position = 0
ado.Type = 1 ' binary
ado.Write ToBytes(part)
ado.Write doc
ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "--")
ado.Position = 0

Dim req , reqURL 
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

Function ToBytes(str)
    Dim ado
    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

Telegram - Send Photo via VBS

Const URL = "https://api.telegram.org/"
Const botID = "botxxxxxxxxx"
Const chatID = "xxxxxx"
methodeName = "/sendPhoto?chat_id=" & chatID
Const sFolder = "C:\"
Const sFile = "GO.png"

Dim data
Set data = CreateObject("Scripting.Dictionary")
data.Add "chatID", chatID
data.Add "text", "TES"

Dim BOUNDARY, s, n 
For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
BOUNDARY = s & CDbl(Now)

Dim part, ado
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=""" & sFile & """" & vbCrLf & vbCrLf
'msgbox part

' read jpg file as binary
Dim jpg
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile sFolder & sFile
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, reqURL
Set req = CreateObject("MSXML2.XMLHTTP")
reqURL = URL & botID & methodeName

'MsgBox reqURL
With req
.Open "POST", reqURL, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
.send ado.read
'MsgBox BOUNDARY
'MsgBox .responseText
End With

Function ToBytes(str)
    Dim ado
    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

Telegram - Get Message via VBS

 Dim http,URL

' you can get this json script from post: VBS - Extract JSON

Set fso = CreateObject("Scripting.FileSystemObject")

executeGlobal fso.openTextFile(strPath & "ExtractJSON.vbs" ).readAll()

'=====================

botID = "botxxxxxxx"

URL = "https://api.telegram.org/" & botID & "/getUpdates"

Set http = CreateObject("Msxml2.XMLHTTP")

http.open "GET",URL,False

'http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

http.send

strJson = http.responseText

msgbox strJson ' showing real data from telegram

Result = Extract(strJson,"(\x22(.*)\x22)")

msgbox Result ' showing data from telegram after extract by ExtractJSON

VBS - Extract JSON

 '******************************************

Function Extract(Data,Pattern)

   Dim oRE,oMatches,Match,Line

   set oRE = New RegExp

   oRE.IgnoreCase = True

   oRE.Global = True

   oRE.Pattern = Pattern

   set oMatches = oRE.Execute(Data)

   If not isEmpty(oMatches) then

       For Each Match in oMatches  

           Line = Line & Trim(Match.Value) & vbCrlf

       Next

       Extract = Line

   End if

End Function

'******************************************

Telegram - Send Message via VBS

read first to get chatID and botID from : https://core.telegram.org/bots

' ===== Start Script =====

Dim http,URL

strTxt = "Tes Message"

chatID = "xxxxxxxx"

botID = "botxxxxxxxxxxxxxxx"

URL = "https://api.telegram.org/" & botID & "/sendMessage?chat_id=" & chatID & "&text=" & strTxt

Set http = CreateObject("Msxml2.XMLHTTP")

http.open "GET",URL,False

http.send

Generate an Email from Excel

--making body mail

Sub PublishToHtml(path As String, sSheet As String, templateFileName As String, sRange As String)

    Dim newName As String

    Dim codesName As String

    

    newName = path & "\" & templateFileName & ".htm"

    codesName = templateFileName & "_30801"

    

    With ThisWorkbook.PublishObjects.Add(xlSourceRange, newName, sSheet, sRange, xlHtmlStatic, codesName, "")

        .Publish (True)

        .AutoRepublish = False

    End With

End Sub

--check a file exist?

Public Function FileFolderExists(strFullPath As String) As Boolean

'Author       : Ken Puls (www.excelguru.ca)

'Macro Purpose: Check if a file or folder exists

    On Error GoTo EarlyExit

    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

    

EarlyExit:

    On Error GoTo 0

End Function

--Refresh All Connection
Sub Refresh_All()
    counter = ActiveWorkbook.Connections.Count
    For I = 1 To counter
        With ActiveWorkbook.Connections(I).ODBCConnection
            .BackgroundQuery = False
            .Refresh
        End With
    Next

End Sub

--Create JPG from sheet
--for this procedure file excel should be visible
Sub CreateJPG(sSheet As String, sRange As String, sSlide As String)
    Dim MyPath As String
    Dim rgExp As Range
    
    MyPath = ThisWorkbook.path & "\"
    Sheets(sSheet).Select
    
    ThisWorkbook.Sheets(sSheet).Visible = True
    
    Set rgExp = Range(sRange)
    rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
    With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
                                      Width:=(rgExp.Width - 10), Height:=(rgExp.Height - 5))
        .Name = "ChartTempEXPORT"
        .Activate
    End With
   
    ActiveChart.Paste
    ActiveSheet.ChartObjects("ChartTempEXPORT").Chart.Export Filename:=MyPath & sSlide, _
                                                             FilterName:="jpg"
    ActiveSheet.ChartObjects("ChartTempEXPORT").Delete

End Sub

--Send Email
--All To,Cc,Bcc should be filled
Sub SendEmail(image1 As String, sSubject As String)
    Dim objmessage
    Set objmessage = CreateObject("CDO.Message")

    Dim xmlDoc As MSXML2.DOMDocument
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False
    xmlDoc.validateOnParse = False
    
    xmlDoc.Load (ThisWorkbook.path & "\emailList.xml")
    
    For Each Z In xmlDoc.SelectNodes("//from")
        FromAddress = Z.Text
    Next
    
    For Each a In xmlDoc.SelectNodes("//to")
        For Each O In a.SelectNodes("//mTo")
            ToAddress = ToAddress & ";" & O.Text
        Next
    Next
    
    For Each B In xmlDoc.SelectNodes("//cc")
        For Each P In B.SelectNodes("//mCc")
            CcAddress = CcAddress & ";" & P.Text
        Next
    Next
    
    For Each C In xmlDoc.SelectNodes("//bcc")
        For Each Q In C.SelectNodes("//mBcc")
            BccAddress = BccAddress & ";" & Q.Text
        Next
    Next
    
    With objmessage
        .Subject = sSubject
        .From = FromAddress
        
        .To = ToAddress
        .Cc = CcAddress
        .Bcc = BccAddress
        
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "10.10.10.10"
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        objmessage.Configuration.Fields.Update
        
        sText = ""
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.OpenTextFile(ThisWorkbook.path & "\body1.htm")
        Do Until ts.AtEndOfStream
            sText = ts.readall
        Loop
        
        sText = sText
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.OpenTextFile(ThisWorkbook.path & "\body2.htm")
        Do Until ts.AtEndOfStream
            sText = sText & ts.readall
        Loop

        htmlString = sText

        
        .HTMLBody = htmlString
             
        
        Set objBP = .AddRelatedBodyPart(ThisWorkbook.path & "\" & image1, image1, CdoReferenceTypeName)
        objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & image1 & ">"
        objBP.Fields.Update
        
        .send
    End With
    Set fso = Nothing
    Set ts = Nothing
    Set objmessage = Nothing
    

End Sub

-- How to Call All?
Private Sub WorkbookOpen()
    If FileFolderExists(ThisWorkbook.path & "\running.txt") Then
        Dim image1 As String
        
        Refresh_All
        
        image1 = "dashboard.jpg"
        CreateJPG "Dashboard", "B4:J37", image1
        PublishToHtml ThisWorkbook.path, "Body", "body1", "$A$2:$T$3"
        PublishToHtml ThisWorkbook.path, "Body", "body2", "$A$4:$T$6"
        
        SendEmail image1, "Abuser Summary Report"
        Kill ThisWorkbook.path & "\" & image1
        Kill ThisWorkbook.path & "\body1.htm"
        Kill ThisWorkbook.path & "\body2.htm"
        Kill ThisWorkbook.path & "\running.txt"
    End If
End Sub

Execute File for an Automate Job VB Script

Dim objXLApp, objXLWb, objXLWs
Dim objFSO, MyFile

Set objFSO = CreateObject("Scripting.FileSystemObject")

strPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
'Replace(WScript.ScriptFullName, WScript.ScriptName, "")
strFileExcel = "Dashboard.xlsm"

strFileName = "running.txt"
strFullName = objFSO.BuildPath(strPath, strFileName)

Set MyFile = objFSO.CreateTextFile(strFullName, True)
MyFile.Close

'Sleep for 5 Second
WScript.Sleep(5000)

'open File Excel

Set objXLApp = CreateObject("Excel.Application")
Set objXLWb = objXLApp.Workbooks.Open(strPath & "\" & strFileExcel)
objXLWb.Application.Visible = True
objXLWb.Application.Run "ThisWorkbook.WorkbookOpen"

objXLWb.Save
objXLWb.Close (False)

Set objXLWs = Nothing  
Set objXLWb = Nothing

objXLApp.Quit
Set objXLApp = Nothing