Dim endpoint : endpoint = !endpoint!
Dim client_id : client_id = !client_id!
Dim client_secret : client_secret = !client_secret!
Dim username : username = !username!
Dim password : password = !password!
Dim secretToken : secretToken = !secretToken!

Dim access_token : access_token = $access_token$
Dim template_file : template_file = !テンプレートCSV!
Dim where : where = !データ絞込条件!
Dim limit : limit = !データ取得上限数!
Dim output_file : output_file = !出力先CSV!
Dim scenario_folder : scenario_folder = !シナリオフォルダ名!

Dim c
Set c = New SalesforceRestJsonController
c.Initialize endpoint
c.GetAccessToken client_id, client_secret, username, password, secretToken

c.CreateTemplateFiles scenario_folder

c.SaveJsonRecordsToCsv template_file, where, limit, output_file

Class SalesforceRestJsonController
	Public TemplateFile
	Public SObjectName
	Public FieldsCSV
	Public LabelsCSV
	Public Fields
	Public EndPoint
	Public AccessToken
	Public URL
	Public JsonObject
	Public JsonObjectEx
	Public TotalSize
	Public JsonTool
	
	Sub Class_Initialize
	End Sub

	Sub Initialize(pEndPoint)
		EndPoint = pEndPoint
	End Sub

	Function GetAccessToken(pClientId, pClientSecret, pUserName, pPassword, pSecretToken)
		Dim url : url = "/services/oauth2/token"

		Dim param
		param = "grant_type=password" _
			& "&client_id=" & pClientId _
			& "&client_secret=" & pClientSecret _
			& "&username=" & pUserName _
			& "&password=" & pPassword & pSecretToken
		Set jo = GetJsonObject(GetHttpResonseTextByPost(url, param))
		
		Me.AccessToken = jo.access_token
		GetAccessToken = Me.AccessToken
	End Function
	
	Function GetHttpResonseTextByPost(pUrl, pParam)
		Dim oHTTP : Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
		oHTTP.Open "POST", Me.EndPoint & pUrl, False
		oHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
		oHTTP.Send pParam
		GetHttpResonseTextByPost = oHTTP.ResponseText
		Set oHTTP = Nothing
	End Function

	Function GetHttpResonseTextByGet(pUrl)
		Dim oHTTP : Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
		oHTTP.Open "GET", EndPoint & pUrl, False
		oHTTP.SetRequestHeader "Content-Type", "application/json"
		oHTTP.SetRequestHeader "Authorization", "Bearer " & Me.AccessToken
		oHTTP.Send()
		GetHttpResonseTextByGet = oHTTP.ResponseText
		Set oHTTP = Nothing
	End Function

	Function GetJsonObject(pJsonString)
		Set Me.JsonTool = CreateObject("HtmlFile")
		Me.JsonTool.write "<meta http-equiv='X-UA-Compatible' content='IE=edge' />"
		Me.JsonTool.write "<script>document.getJSArray=function () {return eval('[]');}</script>"
		Me.JsonTool.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
		Me.JsonTool.write "<script>document.JsonStringify=JSON.stringify;</script>"
		Set Me.JsonObject = Me.JsonTool.JsonParse(pJsonString)
		Set GetJsonObject = Me.JsonObject
	End Function

	Function SaveJsonRecordsToCsv(pTemplateFile, pWhere, pLimit, pOutputFile)
		SetupQueryUrl pTemplateFile, pWhere, pLimit
		Dim oHTTP
		Set oHTTP = GetHttpObjectFromUrlAsync(Me.URL)

		If oHTTP.readyState <> 4 Then
    			oHTTP.waitForResponse(600)
		End If

		WriteCsvHeader pOutputfile

		Dim json
		json = oHTTP.ResponseText
		Set oHTTP = Nothing
		AppendJsonRecordsToCsvAsync pOutputFile, json
	End Function

	Function SetupQueryUrl(pTemplateFile, pWhere, pLimit)
		Me.TemplateFile = pTemplateFile
		Set objRe = New RegExp
		objRe.Pattern = "(.+\\)+(.+)_template_(.+)\.csv$"
		Set matches = objRe.Execute(TemplateFile)
		Me.SObjectName = matches(0).SubMatches(2)

		Dim stream : Set stream = GetAdodbStreamForUTF8()
		stream.Open
		stream.LoadFromFile Me.TemplateFile
		Me.LabelsCSV = stream.ReadText(-2)
		Me.FieldsCSV = stream.ReadText(-2)
		stream.Close
		
		Me.Fields = Split(FieldsCSV, ",")

		Me.URL = "/services/data/v53.0/query/?q=SELECT " & FieldsCSV & " FROM " & SObjectName
		If pWhere <> "" Then
			Me.URL = Me.URL & " WHERE " & pWhere
		End If
		If pLimit <> "" Then
			Me.URL = Me.URL & " LIMIT " & pLimit
		End If
	End Function

	Function WriteCsvHeader(pOutputfile)
		Dim stream
		Set stream = GetAdodbStreamForUTF8()
		stream.Open
		stream.WriteText c.LabelsCSV, 1
		stream.WriteText c.FieldsCSV, 1
		stream.SaveToFile pOutputfile, 2
		stream.Close
	End Function

	Function GetJsonObjectFromUrl(pUrl)
		Dim oHTTP : Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
		oHTTP.Open "GET", EndPoint & pUrl, False
		oHTTP.SetRequestHeader "Content-Type", "application/json"
		oHTTP.SetRequestHeader "Authorization", "Bearer " & Me.AccessToken
		oHTTP.Send()

		Set GetJsonObjectFromUrl = GetJsonObjectFromText(oHTTP.ResponseText)
		Set oHTTP = Nothing
	End Function

	Function GetJsonObjectFromUrlEx(pUrl)
		Dim oHTTP : Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
		oHTTP.Open "GET", EndPoint & pUrl, False
		oHTTP.SetRequestHeader "Content-Type", "application/json"
		oHTTP.SetRequestHeader "Authorization", "Bearer " & Me.AccessToken
		oHTTP.Send()

		GetJsonObjectFromTextEx(oHTTP.ResponseText)
		Set oHTTP = Nothing
	End Function

	Function GetHttpObjectFromUrlAsync(pUrl)
		Dim oHTTP : Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
		oHTTP.Open "GET", EndPoint & pUrl, True
		oHTTP.SetRequestHeader "Content-Type", "application/json"
		oHTTP.SetRequestHeader "Authorization", "Bearer " & Me.AccessToken
		oHTTP.Send()

		Set GetHttpObjectFromUrlAsync = oHTTP
	End Function

	Function AppendJsonRecordsToCsvAsync(pOutputFile, pJsonData)
		Set Me.JsonObject = _
			GetJsonObject( _
				GetJsonRecordsToCsvForInnerJson( _
					pJsonData _
				) _
			)
		Dim isDone
		isDone = Me.JsonObject.Json.done

		Dim oHTTP
		If Not isDone Then
			Set oHTTP = GetHttpObjectFromUrlAsync(Me.JsonObject.Json.nextRecordsUrl)
		End If
		
		AppendCsvData pOutputFile, Me.JsonObject.getCsvData(Me.FieldsCSV)
		
		If isDone Then
			Exit Function
		End If

		If oHTTP.readyState <> 4 Then
    			oHTTP.waitForResponse(600)
		End If

		Dim json
		json = oHTTP.ResponseText
		Set oHTTP = Nothing

		AppendJsonRecordsToCsvAsync pOutputFile, json
	End Function

	Function AppendCsvData(pOutputFile, pCsvData)
		Dim stream
		Set stream = GetAdodbStreamForUTF8()
		stream.Open
		stream.LoadFromFile pOutputFile
		stream.Position = stream.Size
		stream.WriteText pCsvData
		stream.SaveToFile pOutputFile, 2
		stream.Close
		Set stream = Nothing
	End Function

	Function GetJsonRecordsToCsvForInnerJson(jsondata)
		Dim jsondataEx
		Dim fnc
		fnc = "function(fields){ var fArr = fields.split(','); var ret = ''; for(i = 0; i<this.Json.records.length; i++){for(f = 0; f<fArr.length; f++){if(f != 0){ret += ','};if(!isNaN(this.Json.records[i][fArr[f]])){ret +='='};ret += '""' + String(this.Json.records[i][fArr[f]]).replace('""', '""""').replace('\r\n', '\n') + '""'} ret += '\r\n'}return ret;}"
		jsondataEx = "{ ""getCsvData"": " & fnc & ",""Json"":" + jsondata + "}"
		GetJsonRecordsToCsvForInnerJson = jsondataEx
	End Function

	Function GetRecordValue(pRowNumber, pFieldName)
		Dim records
		Set records = Me.JsonObject.records
		GetRecordValue = Eval("records.[" & pRowNumber & "]." & pFieldName)
		If Err.Number <> 0 Then
			MsgBox pRowNumber & "," & pFieldName & ":Err" & Err.Message
		End If
	End Function

	Function GetTextWriterForShiftJis(pFileName)
		Dim fs
		Set fs = CreateObject("Scripting.FileSystemObject")
		Set GetTextWriterForShiftJis = fs.OpenTextFile(pFileName, 2, True, False)
	End Function

	Function GetTextAppendWriterForShiftJis(pFileName)
		Dim fs
		Set fs = CreateObject("Scripting.FileSystemObject")
		Set GetTextAppendWriterForShiftJis = fs.OpenTextFile(pFileName, 8, True, False)
	End Function

	Function GetAdodbStreamForUTF8()
		Dim s
		Set s = CreateObject("ADODB.Stream")
		s.Type = 2
		s.Charset = "UTF-8"
		Set GetAdodbStreamForUTF8 = s
	End Function
	
	Function CreateTemplateFiles(pScenarioFolder)
		Dim json
		json = GetHttpResonseTextByGet("/services/data/v53.0/sobjects/")
		Set Me.JsonObject = GetJsonObject(GetJsonGlobalDescribeForInnerJson(json))
		Dim sobjectsCSV
		sobjectsCSV = Me.JsonObject.getSObjects()
		Dim sobjects
		sobjects = Split(sobjectsCSV, ",")
		For Each sobjectName in sobjects
			If sobjectName <> "" Then
				Dim sobjectDescribeUrl
				sobjectDescribeUrl = "/services/data/v53.0/sobjects/" & sobjectName & "/describe"
				json = GetHttpResonseTextByGet(sobjectDescribeUrl)
				Set Me.JsonObject = GetJsonObject(GetJsonFieldsForInnerJson(json))
				Dim templateFilePath
				templateFilePath = pScenarioFolder & "\テンプレート\" & Me.JsonObject.Json.label & "_template_" & sobjectName & ".csv"
				Dim stream : Set stream = GetAdodbStreamForUTF8
				stream.Open
				stream.WriteText Me.JsonObject.getFields()
				stream.SaveToFile templateFilePath, 2
				stream.Close
			End If
		Next
	End Function

	Function GetJsonGlobalDescribeForInnerJson(jsondata)
		Dim jsondataEx
		Dim fnc
		fnc = "function(){var ret = ''; for(i = 0; i < this.Json.sobjects.length; i++){if(this.Json.sobjects[i].searchable){ret += this.Json.sobjects[i].name + ','}}return ret;}"
		jsondataEx = "{ ""getSObjects"": " & fnc & ",""Json"":" + jsondata + "}"
		GetJsonGlobalDescribeForInnerJson = jsondataEx
	End Function

	Function GetJsonFieldsForInnerJson(jsondata)
		Dim jsondataEx
		Dim fnc
		fnc = "function(){var retLabels = '';var retNames = ''; for(i = 0; i < this.Json.fields.length; i++){if(i != 0){retNames += ',';retLabels += ',';};retNames += this.Json.fields[i].name;retLabels += this.Json.fields[i].label;}return retLabels + '\r\n' + retNames;}"
		jsondataEx = "{ ""getFields"": " & fnc & ",""Json"":" + jsondata + "}"
		GetJsonFieldsForInnerJson = jsondataEx
	End Function

End Class
'Ver 2022/03/22