VBA Macro Error "403 - Expected CSRF token not found. Has your session expired?"

Norma Cruz 1 Reputation point
2021-03-31T17:15:52.163+00:00

Hello, good morning, generate a macro for Outlook to perform the autoticketing of the emails that meet the established criteria. However it sends me the following error "403 - Expected CSRF token not found. Has your session expired? Access to the specified resource has been". Since the tocken that I try to read to use in the API is empty. This is my code, I hope you can help me

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Const xlUp As Long = -4162
Dim PosIni, PosFin, PosFin1 As Integer, EmpID As String, FechaB As String, TBody As String, TBody1 As String, TBody2 As String
Dim SenderN As String, SubjectN As String, EmpName As String, Usr As String, GSoporte As String, Categ As String
Dim Descrip As String, TCodigo As String, DescReq As String, nfecha As String, lfecha As String, nTime As Date, Solicitante As String
Dim telefono As String, TituloReq As String, vticket As String, areatick As String, ncont As Integer, i As Integer
Dim Priority As Integer, Codigo, Customer, CLocationName, Title, AssigGroup, Classification As String
Dim Cat1, Cat2, Cat3, Cat4, Prioritization, Criticality, ServiceR, CBI As String
Dim VbsFile, rstatus, rStsType, rStsName, rticket, rmessage As String, strToken As String, strUrl As String, Body As String, rstatusr As String, Rcode As Long, strResponse As String
Dim varFrom, varEnPb1, varEnPb2, EnvioEn, EnPb1, EnPb2, VReply As Boolean, busca As String
Dim stslog, vcategory As String
Dim SenderAddress As String
Dim objRequest As Object
Dim xlApp As Object ' Excel.Application
Dim xlBook As Object ' Excel.Workbook
Dim xlSheet As Object ' Excel.Worksheet
Dim fileDoesExist As Boolean
Dim sFileName As String
Dim rCount As Long

Private Sub Application_Quit()
lfecha = Left(Date, 2) & Mid(Date, 4, 2) & Right(Date, 2)
stslog = "Cierre de sesion: " & lfecha & " " & Time()
Call Log
End Sub

Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Dim olRecip As Recipient
Dim Inbox As Outlook.MAPIFolder

Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set olRecip = objectNS.CreateRecipient("norma.cruz@t-systems.com")
Set Inbox = objectNS.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set inboxItems = Inbox.Items

lfecha = Left(Date, 2) & Mid(Date, 4, 2) & Right(Date, 2)
stslog = "Inicio de sesion: " & lfecha & " " & Time()
Call Log

End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
nfecha = Date
rstatus = ""
rStsName = ""
rmessage = ""
rticket = ""
Solicitante = ""
telefono = ""
TituloReq = ""
Usr = ""
GSoporte = ""
Categ = ""
TCodigo = ""
EnvioEn = False
EnPb1 = False
EnPb2 = False
VReply = False
SenderN = ""
SubjectN = ""
TBody = ""
TBody1 = ""
TBody2 = ""
vticket = ""
DescReq = ""
Descrip = ""

' Validate if the conditions are met to trigger the ticket creation
If TypeName(Item) = "MailItem" Then
' Valida si el SenderName/Subjet corresponde a la busqueda deseada
TBody = UCase(Item.SenderName)
Call Borrahyperlinks
SenderN = TBody
TBody = Item.Body
SubjectN = Item.Subject
SenderAddress = Item.SenderEmailAddress
If UCase(SenderN) = "CRUZ VEGA, NORMA ARACELI" And _
InStr(UCase(SubjectN), "BAJA DE EMPLEADO EN EL ADS.") > 0
Call BajaMail
Call GoAPI
If rStsName <> "failure" Then
Item.Subject = rticket & " - " & Item.Subject
Item.Save
nTime = Time()
stslog = nfecha & " " & nTime & " Se creo el ticket '" & rticket & "' para el Correo '" & SubjectN & "' enviado por '" & SenderN
' Register the ticket created in the historical file
Call GrabaXls
Else
stslog = nfecha & " " & nTime & " Error en la creación del ticket: '" & rmessage & "' para el Correo '" & SubjectN & "' enviado por '" & SenderN
End If
Call Log
End If
End If
GoTo Fin

ErrorHandler:
stslog = "Error macro: " & Err.Description & " " & lfecha & " " & Time()
Call Log
MsgBox Err.Number & " - " & Err.Description
If Dir("D:\result.txt") <> "" Then Kill "D:\result.txt"
If Dir("D:\RestApiAU.vbs") <> "" Then Kill "D:\RestApiAU.vbs"
Resume Fin

Fin:
Set Item = Nothing
Set objRequest = Nothing
End Sub

Sub BajaMail()
' Extract the information from the email to generate the information for the ticket creation
PosIni = InStr(TBody, "El empleado")
PosFin = Len(TBody)
TBody1 = Mid(TBody, PosIni, (PosFin - PosIni))
TBody = TBody1
PosIni = InStr(TBody, "su usuario ") + 11
PosFin = InStr(TBody, "en el ADS") - 1
If Len(Mid(TBody, PosIni, (PosFin - PosIni))) > 0 Then
Usr = RTrim(Mid(TBody, PosIni, (PosFin - PosIni)))
End If
PosIni = InStr(TBody, "El empleado ") + 12
PosFin = InStr(TBody, " - ")
If Len(Mid(TBody, PosIni, (PosFin - PosIni))) > 0 Then
EmpID = RTrim(Mid(TBody, PosIni, (PosFin - PosIni)))
End If
PosIni = PosFin + 3
PosFin = InStr(TBody, "ha causado") - 1
If Len(Mid(TBody, PosIni, (PosFin - PosIni))) > 0 Then
EmpName = RTrim(Mid(TBody, PosIni, (PosFin - PosIni)))
End If
PosIni = InStr(TBody, "con fecha") + 10
FechaB = Mid(TBody, PosIni, 8)
'Genera la información para la creación del ticket
DescReq = "Nombre Completo:" & EmpName & " <salto> UID:" & EmpID & " <salto> Usr:" & Usr & "<salto> Fecha de Baja:" & FechaB
vticket = "{*|title|:|DATOS MX | USER | CCO | ACTIVE DIRECTORY BAJA DE USUARIO|,|customerName|:|MONTERREY S.A. DE C.V|,|category1|:|SERVICE REQUEST|,|category2|:|ACCESS|,|category3|:|OTHER|,|category4|:|NSLA INFR1 P5|,|assignmentGroup|:|MIS.INT.MX.ZEROTOUCH|,|criticality|:|NONE|,|serviceRestriction|:|NONE|,|priority|:|5|,|affectedCIName|:|CI_TBD|,|description|:|" & DescReq & "|,|customerLocation|:|MTY MEX|,|causeCode|:|BG293314|*}"
areatick = "MIS.INT.MX.ZEROTOUCH"
End Sub

Sub GrabaXls()
'Register the ticket created in the excel file "D: \ AutotikectingBaja.xlsx!
nTime = Time()

'Create the link with the Excel application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

'Validate if the log file exists, if it does not create it and open it, if it exists it opens it    
fileDoesExist = Dir(sFileName) > ""

If fileDoesExist Then
    Set xlBook = xlApp.Workbooks.Open(sFileName)
Else
    Set xlBook = xlApp.Workbooks.Add
    xlBook.SaveAs sFileName
End If
Set xlSheet = xlBook.Sheets("Sheet1")
rCount = 1
'Busca la primera linea vacia, si es 1 carga primero los encabezados
While xlSheet.Range("A" & rCount) <> ""
    rCount = rCount + 1
Wend

If rCount = 1 Then
    xlSheet.Range("A" & rCount) = "No de ticket"
    xlSheet.Range("B" & rCount) = "Fecha Creacion"
    xlSheet.Range("C" & rCount) = "Hora Creacion"
    xlSheet.Range("D" & rCount) = "Area asignada"
    xlSheet.Range("E" & rCount) = "Status"
    xlSheet.Range("F" & rCount) = "StatusType"
    xlSheet.Range("G" & rCount) = "StatusName"
    rCount = rCount + 1
End If
xlSheet.Range("A" & rCount) = rticket
xlSheet.Range("B" & rCount) = nfecha
xlSheet.Range("C" & rCount) = nTime
xlSheet.Range("D" & rCount) = areatick
xlSheet.Range("E" & rCount) = rstatus
xlSheet.Range("F" & rCount) = rStsType
xlSheet.Range("G" & rCount) = rStsName
'Guarda y Cierra el archivo
xlBook.Close SaveChanges:=True
xlApp.Quit

End Sub

Sub Log()

Dim File_Log As String
Dim fileNumber As Integer

File_Log = "D:\MacroVitro_" & lfecha & ".log"
fileNumber = FreeFile

If (VBA.Len(VBA.Dir(File_Log))) = 0 Then
    Open File_Log For Output As #fileNumber
Else
    Open File_Log For Append As #fileNumber
End If
Write #fileNumber, stslog
Close #fileNumber

End Sub

Sub GoAPI()
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = "http://160.118.117.80:8080/oo/rest/executions"
objRequest.Open "GET -H", strUrl, True
objRequest.setRequestHeader "Authorization", "Basic SU5DSURFTlQtSFBPTy1NWDrCoUNyM2F0ZVRpY2szdCEhLg=="
objRequest.setRequestHeader "x-csrf-token", "Fetch"
objRequest.Send

While objRequest.readyState <> 4
    DoEvents
Wend

strToken = objRequest.getResponseHeader("x-csrf-token")
' Make the API connection to perform the ticket creation requirement
rstatusr = ""
Rcode = 0
strUrl = "http://160.118.117.80:8080/oo/rest/executions"
Body = "{""uuid"": ""53b70d5d-3925-4006-9364-b851dae62714"", ""runName"": ""MytestsChatbot"", ""logLevel"": ""DEBUG"", ""inputs"": {""user"": ""INCIDENT-CHATBOT"", ""passw"": ""IQAuAEMAaABhAHQAQgAwADEANABQAFAAQQBjAGMAZQBzAHMA"", ""function"": ""createIncident"",""json"":" & Chr(34) & vticket & Chr(34) & "}}"
With objRequest
    .Open "POST", strUrl, False
    .setRequestHeader "x-csrf-token", strToken
    .setRequestHeader "Content-Type", "application/json"
    '.setRequestHeader "Authorization", "Basic SU5DSURFTlQtSFBPTy1NWDrCoUNyM2F0ZVRpY2szdCEhLg=="
    .setRequestHeader "Authorization", "Bearer SU5DSURFTlQtSFBPTy1NWDrCoUNyM2F0ZVRpY2szdCEhLg=="
    .Send Body
    'Process to wait for the answer
    While objRequest.readyState <> 4
        DoEvents
    Wend
    strResponse = .responseText
End With

MsgBox strResponse
PosIni = InStr(strResponse, "executionId") + 14
Rcode = Mid(strResponse, PosIni, 9)
Debug.Print strResponse

'Make the API connection to check the ticket creation status (Get)
rstatusr = "RUNNING"
While rstatusr = "RUNNING"
    For i = 1 To 2000
        ncont = i
    Next i
    With objRequest
        strUrl = "http://160.118.117.80:8080/oo/rest/executions/" & Rcode & "/execution-log"
        .Open "GET -H", strUrl, True
        .setRequestHeader "x-csrf-token", strToken
        .Send
'Process to wait for the answer
        While objRequest.readyState <> 4
            DoEvents
        Wend
        strResponse = .responseText
        PosIni = InStr(strResponse, "status")
        rstatusr = Mid(strResponse, PosIni + 9, 7)
    End With
Wend

PosIni = InStr(strResponse, "IncidentID\") + 15
rticket = Mid(strResponse, PosIni, 12)
PosIni = InStr(strResponse, "status")
rstatusr = Mid(strResponse, PosIni + 9, 7)
rstatus = Mid(strResponse, PosIni + 9, 9)
Debug.Print strResponse
' Desglosa los campos de la respuesta de status summary
PosIni = InStr(strResponse, "status")
rstatus = Mid(strResponse, PosIni + 9, 9)
PosIni = InStr(strResponse, "StatusType")
rStsType = Mid(strResponse, PosIni + 13, 8)
PosIni = InStr(strResponse, "StatusName")
rStsName = Mid(strResponse, PosIni + 13, 7)
If rStsName = "failure" Then
    PosIni = InStr(strResponse, "message") + 12
    PosFin = InStr(strResponse, "Result") - 6
    rmessage = Mid(strResponse, PosIni, (PosFin - PosIni))
Else
    rmessage = ""
End If

Set objRequest = Nothing

End Sub