VBA - Merging two scripts - vba

Question

I have a problem with combining two scripts into one, I tried to the script, "createTask" to add as text, "msg2" from the "SaveMessageAsMsg" script.
When I tried to merge it either didn't pull msg2 or the createtask script didn't execute properly.
The lower script is to save the selected email on the local network and extract the address to this saved .msg element, and this address is to be used as text in the JsonString of "createTask" script under msg2.
If anyone has an idea how to combine this I would be very grateful.
Sub send()
Dim Sarasa As Object
Dim x, mailItem As Outlook.mailItem
For Each x In Application.ActiveExplorer.Selection
If TypeName(x) = "MailItem" Then
Set mailItem = x
Call createTask(mailItem)
End If
Next
End Sub
Sub createTask(ByRef mItem As Outlook.mailItem)
Dim kbUrl As String
Dim title As String
Dim kbUsername As String
Dim kbPassword As String
Dim kbProjectId As Integer
Dim kbSwimlaneId As Integer
kbUrl = "https://website.com/jsonrpc.php"
kbUsername = "test"
kbPassword = "test"
kbProjectId = 1
kbSwimlaneId = 1
Set LoginRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
LoginRequest.Option(4) = 13056
LoginRequest.Open "POST", kbUrl, False
LoginRequest.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
LoginRequest.SetCredentials kbUsername, kbPassword, 0
title = InputBox(mItem.Subject, "Title")
If StrPtr(title) = 0 Then
ElseIf title = vbNullString Then
JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & Format(mItem.CreationTime, "ddd hh:nn") & " / " & Split(mItem.SenderName)(1) & " / " & mItem.Subject & """, ""description"":""" & "[LINK](file:" + msg2 & ")" & """}}"
Else
JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & Format(mItem.CreationTime, "ddd hh:nn") & " / " & Split(mItem.SenderName)(1) & " / " & title & """, ""description"":""" & "[LINK](file:" + msg2 & ")" & """}}"
End If
LoginRequest.Send JsonString
If LoginRequest.Status = 200 Then
'MsgBox "Mail: " & mItem.Subject & " - Status: " & LoginRequest.responseText
Call buscaError(LoginRequest.responseText, mItem)
Else
MsgBox "The list did not respond - 200 OK"
End If
End Sub
Function buscaError(strBuscar As String, ByRef mItem As Outlook.mailItem)
Dim useCategory As String
useCategory = "LIST"
Dim olMail As Outlook.mailItem
Dim RegError As RegExp
Dim RegExito As RegExp
Dim M1 As MatchCollection
Dim M As Match
Set olMail = Application.ActiveExplorer().Selection(1)
Set RegError = New RegExp
Set RegExito = New RegExp
With RegError
.Pattern = "(error)"
.Global = True
End With
With RegExito
.Pattern = "(result)"
.Global = True
End With
If RegError.test(strBuscar) Then
'MsgBox "Mail processing error: " & mItem.Subject
ElseIf RegExito.test(strBuscar) Then
Call AddCategory(mItem, useCategory)
'MsgBox "Ok"
End If
End Function
Sub AddCategory(aMailItem As mailItem, newCategory As String)
Dim categories() As String
Dim listSep As String
listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")
categories = Split(aMailItem.categories, listSep)
If UBound(Filter(categories, newCategory)) = -1 Then
ReDim Preserve categories(UBound(categories) + 1)
categories(UBound(categories)) = newCategory
aMailItem.categories = Join(categories, listSep)
aMailItem.Save
End If
End Sub
With this
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.mailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim msg2 As String
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = "\\local.disk\folder"
msg2 = sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub

Answer 1

You can split the functions into two separate ones. In both cases you retrieve the currently selected mail item, so after getting the object you can call two separate functions to get the job done.
Sub send()
Dim Sarasa As Object
Dim x, mailItem As Outlook.mailItem
For Each x In Application.ActiveExplorer.Selection
If TypeName(x) = "MailItem" Then
Set mailItem = x
Call createTask(mailItem)
Call SaveMessageAsMsg(mailItem)
End If
Next
End Sub
Sub createTask(ByRef mItem As Outlook.mailItem)
Dim kbUrl As String
Dim title As String
Dim kbUsername As String
Dim kbPassword As String
Dim kbProjectId As Integer
Dim kbSwimlaneId As Integer
kbUrl = "https://website.com/jsonrpc.php"
kbUsername = "test"
kbPassword = "test"
kbProjectId = 1
kbSwimlaneId = 1
Set LoginRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
LoginRequest.Option(4) = 13056
LoginRequest.Open "POST", kbUrl, False
LoginRequest.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
LoginRequest.SetCredentials kbUsername, kbPassword, 0
title = InputBox(mItem.Subject, "Title")
If StrPtr(title) = 0 Then
ElseIf title = vbNullString Then
JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & Format(mItem.CreationTime, "ddd hh:nn") & " / " & Split(mItem.SenderName)(1) & " / " & mItem.Subject & """, ""description"":""" & "[LINK](file:" + msg2 & ")" & """}}"
Else
JsonString = "{""jsonrpc"": ""2.0"", ""method"": ""createTask"",""id"": 1176509098,""params"": {""score"": 0, ""project_id"": """ & kbProjectId & """, ""swimlane_id"":""" & kbSwimlaneId & """ , ""title"":""" & Format(mItem.CreationTime, "ddd hh:nn") & " / " & Split(mItem.SenderName)(1) & " / " & title & """, ""description"":""" & "[LINK](file:" + msg2 & ")" & """}}"
End If
LoginRequest.Send JsonString
If LoginRequest.Status = 200 Then
'MsgBox "Mail: " & mItem.Subject & " - Status: " & LoginRequest.responseText
Call buscaError(LoginRequest.responseText, mItem)
Else
MsgBox "The list did not respond - 200 OK"
End If
End Sub
Function buscaError(strBuscar As String, ByRef mItem As Outlook.mailItem)
Dim useCategory As String
useCategory = "LIST"
Dim olMail As Outlook.mailItem
Dim RegError As RegExp
Dim RegExito As RegExp
Dim M1 As MatchCollection
Dim M As Match
Set olMail = Application.ActiveExplorer().Selection(1)
Set RegError = New RegExp
Set RegExito = New RegExp
With RegError
.Pattern = "(error)"
.Global = True
End With
With RegExito
.Pattern = "(result)"
.Global = True
End With
If RegError.test(strBuscar) Then
'MsgBox "Mail processing error: " & mItem.Subject
ElseIf RegExito.test(strBuscar) Then
Call AddCategory(mItem, useCategory)
'MsgBox "Ok"
End If
End Function
Sub AddCategory(aMailItem As mailItem, newCategory As String)
Dim categories() As String
Dim listSep As String
listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")
categories = Split(aMailItem.categories, listSep)
If UBound(Filter(categories, newCategory)) = -1 Then
ReDim Preserve categories(UBound(categories) + 1)
categories(UBound(categories)) = newCategory
aMailItem.categories = Join(categories, listSep)
aMailItem.Save
End If
End Sub
Public Sub SaveMessageAsMsg(ByVal oMail As Outlook.mailItem)
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim msg2 As String
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = "\\local.disk\folder"
msg2 = sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub