
Sub UploadDataToCBO()
'
' UploadDataToCBO Macro
'
ClearResults
containsError = False
Dim resultRow As Integer
resultRow = 2
' Get the Number of Columns to set up the field names into a string array
Dim lastColumn As Long
lastColumn = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
Dim fieldNames() As String
ReDim fieldNames(1 To lastColumn) As String
For d = 1 To lastColumn Step 1
fieldNames(d) = ActiveWorkbook.Sheets(SHEET_TITLE_CBO).Cells(1, d).Value
Next d
Dim CBOName As String
CBOName = ActiveWorkbook.Sheets(SHEET_TITLE_META).Cells(3, 2).Value
Dim numOfRows As Integer
numOfRows = ActiveWorkbook.Worksheets(SHEET_TITLE_CBO).Cells(Worksheets(SHEET_TITLE_CBO).Rows.Count, "A").End(xlUp).Row - 1
Dim cboCount As Integer
Dim batchAmount As Integer
Dim batchCallNum As Integer
Dim response As String
batchCallNum = 1
batchAmount = Sheets(SHEET_TITLE_META).Cells(5, 2).Value
'set user data
Dim strPass As String
Dim strUser As String
' Set up Data to call
strUsr = ActiveWorkbook.Sheets(SHEET_TITLE_META).Cells(4, 2).Value
strPass = InputBox("Enter Password for user " & strUsr)
strURL = Sheets(SHEET_TITLE_META).Cells(2, 2).Value & "/$batch"
Dim arr
Dim doneProcCBO As Boolean
Dim startRow As Integer
Dim endRow As Integer
Dim currRow As Integer
Dim totalBatches As Integer
currRow = 2
startRow = 2
doneProcCBO = False
totalBatches = numOfRows / batchAmount
If numOfRows Mod batchAmount > 0 Then
totalBatches = totalBatches + 1
End If
If MsgBox("Application will now process " & numOfRows & " records in " & totalBatches & " total batches." & vbCrLf & "Please be patient and check the status bar for progress." & vbCrLf & "Click Yes to proceed.", vbYesNo) = vbYes Then
If numOfRows > batchAmount Then
endRow = batchAmount + startRow - 1
Do
Application.StatusBar = "Processing: Batch " & batchCallNum & " - " & Format(batchCallNum / totalBatches, "Percent")
payload = CBOPayload(currRow, endRow, numOfRows, fieldNames, CBOName, lastColumn)
If debugMode = True Then
ActiveWorkbook.Worksheets(SHEET_TITLE_PAYLOAD).Shapes("Textbox " & batchCallNum).TextFrame.Characters.Text = payload
End If
response = PostCBOData(strURL, payload, strUsr, strPass, batchCallNum)
batchCallNum = batchCallNum + 1
payload = vbNullString
If currRow > numOfRows Then
doneProcCBO = True
End If
startRow = currRow
endRow = endRow + batchAmount
Loop While doneProcCBO = False
Else
' send all rows in the payload
endRow = numOfRows + 1
'generate Payload
payload = CBOPayload(currRow, endRow, numOfRows, fieldNames, CBOName, lastColumn)
response = PostCBOData(strURL, payload, strUsr, strPass, batchCallNum)
End If
Application.StatusBar = False
' PostCBOData(strURL,payload,strPass,batchCallNum,resultRow)
Else
'user clicked No button
End If
End Sub
Function CBOPayload(currRow, endRow, numOfRows, fieldNames, CBOName, lastColumn) As String
Dim payload As String
payload = "--batch_mybatch" & vbCrLf & "Content-Type: multipart/mixed; boundary=changeset_mychangeset1"
For e = currRow To endRow
If currRow <= numOfRows + 1 Then
payload = payload & vbCrLf & vbCrLf & "--changeset_mychangeset1" & vbCrLf & "Content-Type: application/http" & vbCrLf & "Content -Transfer - Encoding: binary" & vbCrLf & vbCrLf
payload = payload & "POST " & CBOName & " HTTP/1.1" & vbCrLf & "Content-Type: application/json" & vbCrLf & vbCrLf & "{" & vbCrLf
For f = 1 To lastColumn Step 1
payload = payload & Chr(34) & fieldNames(f) & Chr(34) & ": " & Chr(34) & ActiveWorkbook.Sheets(SHEET_TITLE_CBO).Cells(e, f).Value & Chr(34)
If f = lastColumn Then
payload = payload & vbCrLf & "}" & vbCrLf
Else
payload = payload & "," & vbCrLf
End If
Next f
End If
currRow = currRow + 1
Next e
payload = payload & vbCrLf & vbCrLf & vbCrLf & "--changeset_mychangeset1--" & vbCrLf & vbCrLf & vbCrLf & "--batch_mybatch--" & vbCrLf
CBOPayload = payload
End Function
Function PostCBOData(strURL, strPostData, strUser, strPass, batchCallNum) As String
Set objWinHttp = CreateObject("Msxml2.XMLHTTP.6.0")
objWinHttp.Open strMethod, strURL, False, strUser, strPass
objWinHttp.SetRequestHeader "x-csrf-token", "Fetch"
objWinHttp.SetRequestHeader "Cache-Control", "no-cache,max-age=0"
objWinHttp.SetRequestHeader "pragma", "no-cache"
objWinHttp.send
strToken = objWinHttp.getResponseHeader("x-csrf-token")
If Len(strToken) = 0 Then
MsgBox "Error: Most likely the password is not correct."
containsError = True
Else
objWinHttp.Open "POST", strURL, False, strUser, strPass
objWinHttp.SetRequestHeader "x-csrf-token", strToken
objWinHttp.SetRequestHeader "Content-Type", "multipart/mixed; boundary=batch_mybatch"
objWinHttp.send (strPostData)
PostCBOData = objWinHttp.ResponseText
If debugMode = True Then
ActiveWorkbook.Worksheets(SHEET_TITLE_RESULTS).Cells(1, 15).Value = PostCBOData
End If
'ActiveWorkbook.Worksheets(SHEET_TITLE_RESULTS).Cells(1, 15 + batchCallNum).Value = PostCBOData
ActiveWorkbook.Worksheets(SHEET_TITLE_RESULTS).Cells(batchCallNum, 1).Value = "Batch " & batchCallNum
If InStr(PostCBOData, "HTTP/1.1 400 Bad Request") > 0 Then
ActiveWorkbook.Worksheets(SHEET_TITLE_RESULTS).Cells(batchCallNum, 2).Value = "ERROR"
ActiveWorkbook.Worksheets(SHEET_TITLE_RESULTS).Cells(batchCallNum, 3).Value = PostCBOData
Else
ActiveWorkbook.Worksheets(SHEET_TITLE_RESULTS).Cells(batchCallNum, 2).Value = "SUCCESS"
End If
Exit Function
badPassword: MsgBox "The password is not correct."
End Function
You must be a registered user to add a comment. If you've already registered, sign in. Otherwise, register and sign in.
User | Count |
---|---|
8 | |
7 | |
5 | |
5 | |
4 | |
4 | |
4 | |
4 | |
4 | |
3 |