question

NormaCruz-5327 avatar image
0 Votes"
NormaCruz-5327 asked JadeLiang-MSFT edited

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

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

office-vba-dev
· 1
5 |1600 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.

Hi @NormaCruz-5327,
Please kindly understand under Outlook tag, we mainly focus on general issue on outlook desktop client, considering your issue may be more related to VBA development instead of Outlook desktop client, I would remove Outlook tag and add vba development tag, thanks for your understanding and hope your issue would be resolved soon.

0 Votes 0 ·

0 Answers