Public Function RecordSetToJSON(rs As ADODB.Recordset) As String

    Dim i       As Integer

    Dim JSONstr As String

    JSONstr = ""

    If Not (rs.EOF And rs.BOF) Then
        ‘序列化JSON串
        rs.MoveFirst
        
        While Not rs.EOF
            
            ‘左边界
            JSONstr = JSONstr + "{"

            For i = 0 To rs.Fields.Count - 1
                
                ‘判断数据类型
                Select Case rs.Fields(i).Type
                    
                    Case DataTypeEnum.dbCurrency
                        ‘货币类型
                        JSONstr = JSONstr + """" + rs.Fields(i).Name + """:" + CStr(rs.Fields(i).Value) + ","
                        
                    Case DataTypeEnum.dbBigInt, DataTypeEnum.dbDecimal, DataTypeEnum.dbFloat, DataTypeEnum.dbInteger, DataTypeEnum.dbLong, DataTypeEnum.dbDouble, DataTypeEnum.dbNumeric, DataTypeEnum.dbSingle
                        ‘数值类型
                        JSONstr = JSONstr + """" + rs.Fields(i).Name + """:" + CStr(rs.Fields(i).Value) + ","
                    Case Else
                        ‘文本类型
                        JSONstr = JSONstr + """" + rs.Fields(i).Name + """:""" + CStr(rs.Fields(i).Value) + ""","
                End Select

            Next
            
            JSONstr = Left(JSONstr, Len(JSONstr) - 1)
            
            ‘右边界
            JSONstr = JSONstr + "},"
            
            rs.MoveNext
        Wend
        
        JSONstr = Left(JSONstr, Len(JSONstr) - 1)
        
        JSONstr = "[" + JSONstr + "]"
        
        RecordSetToJSON = JSONstr
        
    Else
        ‘返回空串
        RecordSetToJSON = ""
    
    End If

End Function

Public Function SendData(dataStr As String, url As String, Optional ReqMode = "POST") As String

    Dim postData As String


    ‘JSON数据
    postData = dataStr
 
    ‘--- post
    Dim HttpClient As Object
 
    Set HttpClient = CreateObject("Microsoft.XMLHTTP")
    HttpClient.Open ReqMode, url, False
    HttpClient.setRequestHeader "Content-Type", "application/json; charset=UTF-8"
    HttpClient.Send pvToByteArray(postData)
    
    Do While HttpClient.readyState <> 4
        DoEvents
    Loop
  
    SendData = HttpClient.responseText

End Function

‘ 下面是两个转换函数
Public Function pvToByteArray(sText As String) As Byte()
   pvToByteArray = GB2312ToUTF8(sText)
End Function
 
Public Function GB2312ToUTF8(strIn As String, Optional ByVal ReturnValueType As VbVarType = vbString) As Variant
    Dim adoStream As Object
  
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Charset = "utf-8"
    adoStream.Type = 2 ‘adTypeText
    adoStream.Open
    adoStream.WriteText strIn
    adoStream.Position = 0
    adoStream.Type = 1 ‘adTypeBinary
    GB2312ToUTF8 = adoStream.Read()
    adoStream.Close
  
    If ReturnValueType = vbString Then GB2312ToUTF8 = Mid(GB2312ToUTF8, 1)
       
End Function

Public Sub Upload_DATA()

    Dim url      As String

    Dim JSONstr  As String

    Dim nResult  As String


    Dim nSql     As String

    Dim cn       As New ADODB.Connection

    Dim rst      As New ADODB.Recordset

‘    Dim rsm       As New ADODB.Stream

    cn.ConnectionString = 连接参数
    cn.CursorLocation = adUseClient
    cn.Open
    
    nSql = "select c1,c2,c3 from temp"
            
    rst.Open nSql, cn, adOpenKeyset, adLockReadOnly

    If rst.EOF = False Then

        ‘        rst.Save rsm, adPersistXML
        ‘        TextResponse.Text = rsm.ReadText ‘输出XML格式数据
        url = "http://***.***.com//api//***"
            
        JSONstr = RecordSetToJSON(rst)

        If Len(Trim$(JSONstr)) > 0 Then
            nResult = SendData(JSONstr, url)
        Else
            MsgBox "没有需要上传的数据!"

        End If
        
        ‘TextResponse.Text = JSONstr
        ‘txtback.Text = nResult
        Debug.Print nResult
        
    End If

    rst.Close
    cn.Close

End Sub