腾讯微博API核心模块

最新推荐文章于 2025-08-18 09:12:06 发布
最新推荐文章于 2025-08-18 09:12:06 发布 · 169 阅读
文章标签：
'***********************************************************************************
'***本程序可以自由传播,本人不对您使用本软件及代码造成的任何后果承担任何责任**
'***利用此代码挣钱了也无需告诉我******
'***作者：龙小龙 QQ：31519488,部分代码来源于网络***
'***感谢中国农业人才网www.5ajob.com 大力支持***
'***中国农业人才网,让伯乐与千里马不再是偶遇***
'***********************************************************************************
Public c_baseUrl As String
    Public c_request_tokenUrl As String
    Public c_authorizeUrl As String
    Public c_tokenUrl As String
    Public c_App_Key As String
    Public c_App_Secret As String
    Public c_redirect_uri As String

    Public c_oauth_token As String '未授权token
    Public c_oauth_token_secret As String
    Public c_oauth_verifier As String
    Public c_access_token As String '授权后的token
    Public c_access_token_secret As String
    Public c_accesstoken2_0 As String 'oauth2
    Public c_refreshtoken2_0 As String
    Public c_expiretime2_0 As String
    Public c_getTokenTime As String '获得授权时的时间

    Public Sub Class_Initialize()

    End Sub
    
    Public Sub Class_Terminate()
    
    End Sub
    
    Public Function Get_oauth_token()
        Dim codeUrl As String, baseString As String, paraUrl As String
        Dim codeUrlTempalte As String '获取未授权
        Dim paraUrlTempalte As String
        Dim baseStringTemplate As String
        Dim tempstr As String
        
        codeUrlTempalte = "{0}?oauth_callback={3}&oauth_consumer_key={1}&oauth_nonce={2}&oauth_signature={5}&oauth_signature_method=HMAC-SHA1&oauth_timestamp={4}&oauth_version=1.0"
        paraUrlTempalte = "oauth_callback={3}&oauth_consumer_key={1}&oauth_nonce={2}&oauth_signature_method=HMAC-SHA1&oauth_timestamp={4}&oauth_version=1.0"
        baseStringTemplate = "{method}&{encode_request_tokenUrl}&{encode_paraUrl}" '用于生成signature
        
        oauth_nonce = makePassword(10) '随机数
        oauth_timestamp = DateDiff("s", "01/01/1970 08:00:00", Now()) '邮戳
        
        paraUrl = Replace(paraUrlTempalte, "{1}", Me.c_App_Key) '参数串
        paraUrl = Replace(paraUrl, "{2}", oauth_nonce)
        paraUrl = Replace(paraUrl, "{3}", Me.c_redirect_uri)
        paraUrl = Replace(paraUrl, "{4}", oauth_timestamp)
        
        baseString = Replace(baseStringTemplate, "{method}", "GET")
        baseString = Replace(baseString, "{encode_request_tokenUrl}", strUrlEnCode(Me.c_request_tokenUrl))
        baseString = Replace(baseString, "{encode_paraUrl}", strUrlEnCode(paraUrl))
        
'        Debug.Print baseString
        oauth_signature = HAMC_SHA1(Me.c_App_Secret + "&", baseString) ' + Me.c_oauth_token_secret
        codeUrl = Replace(codeUrlTempalte, "{0}", Me.c_request_tokenUrl)
        codeUrl = Replace(codeUrl, "{1}", Me.c_App_Key)
        codeUrl = Replace(codeUrl, "{2}", oauth_nonce)
        codeUrl = Replace(codeUrl, "{3}", Me.c_redirect_uri)
        codeUrl = Replace(codeUrl, "{4}", oauth_timestamp)
        codeUrl = Replace(codeUrl, "{5}", oauth_signature)
        
        tempstr = httpGet(codeUrl)
        Get_oauth_token = tempstr
        tempstr = GetValue(tempstr, "oauth_token\=(.*?)&oauth_token_secret\=(.*?)&oauth_callback_confirmed\=true", "0|1", False, False)
        atempstr = Split(tempstr, "$$")
        If UBound(atempstr) = 1 Then
        Me.c_oauth_token = atempstr(0)
        Me.c_oauth_token_secret = atempstr(1)
        End If
    End Function

    Public Function Get_access_token()
        Dim codeUrl As String, baseString As String, paraUrl As String
        Dim codeUrlTempalte As String
        Dim paraUrlTempalte As String
        Dim baseStringTemplate As String
        Dim tempstr As String

        codeUrlTempalte = "{0}?oauth_consumer_key={1}&oauth_nonce={2}&oauth_signature={5}&oauth_signature_method=HMAC-SHA1&oauth_timestamp={4}&oauth_token={6}&oauth_token_secret={7}&oauth_verifier={3}&oauth_version=1.0"
        paraUrlTempalte = "oauth_consumer_key={1}&oauth_nonce={2}&oauth_signature_method=HMAC-SHA1&oauth_timestamp={4}&oauth_token={6}&oauth_verifier={3}&oauth_version=1.0"
        baseStringTemplate = "{method}&{encode_tokenUrl}&{encode_paraUrl}" '用于生成signature

        oauth_nonce = makePassword(10)  '随机数
        oauth_timestamp = DateDiff("s", "01/01/1970 08:00:00", Now()) '邮戳

        paraUrl = Replace(paraUrlTempalte, "{1}", Me.c_App_Key) '参数串
        paraUrl = Replace(paraUrl, "{2}", oauth_nonce)
        paraUrl = Replace(paraUrl, "{3}", Me.c_oauth_verifier)
        paraUrl = Replace(paraUrl, "{4}", oauth_timestamp)
        paraUrl = Replace(paraUrl, "{6}", Me.c_oauth_token)
        paraUrl = Replace(paraUrl, "{7}", Me.c_oauth_token_secret)
        
        baseString = Replace(baseStringTemplate, "{method}", "GET")
        baseString = Replace(baseString, "{encode_tokenUrl}", strUrlEnCode(Me.c_tokenUrl))
        baseString = Replace(baseString, "{encode_paraUrl}", strUrlEnCode(paraUrl))
        
'        Debug.Print baseString
        oauth_signature = HAMC_SHA1(Me.c_App_Secret + "&" + Me.c_oauth_token_secret, baseString)
'        Debug.Print Me.c_App_Secret + "&" + Me.c_oauth_token_secret
'        MsgBox oauth_signature
        
        codeUrl = Replace(codeUrlTempalte, "{0}", Me.c_tokenUrl)
        codeUrl = Replace(codeUrl, "{1}", Me.c_App_Key)
        codeUrl = Replace(codeUrl, "{2}", oauth_nonce)
        codeUrl = Replace(codeUrl, "{3}", Me.c_oauth_verifier)
        codeUrl = Replace(codeUrl, "{4}", oauth_timestamp)
        codeUrl = Replace(codeUrl, "{5}", oauth_signature)
        codeUrl = Replace(codeUrl, "{6}", Me.c_oauth_token)
        codeUrl = Replace(codeUrl, "{7}", Me.c_oauth_token_secret)
'        Debug.Print codeUrl

'        Debug.Print Me.c_oauth_token_secret

        tempstr = httpGet(codeUrl)
        
        tempstr0 = tempstr
        tempstr0 = GetValue(tempstr0, "oauth_token\=(.*)?&oauth_token_secret\=(.*)?&", "0|1", False, False)
        atempstr = Split(tempstr0, "$$")
        If UBound(atempstr) = 1 Then
        Me.c_access_token = atempstr(0)
        Me.c_access_token_secret = atempstr(1)
        End If
        
        Get_access_token = tempstr
       
    End Function
Public Function Get_oAuth2()
        Dim codeUrl As String, baseString As String, paraUrl As String
        Dim codeUrlTempalte As String
        Dim paraUrlTempalte As String
        Dim baseStringTemplate As String
        Dim tempstr As String
        tokenUrl2 = "http://open.t.qq.com/api/auth/get_oauth2_token"
  codeUrlTempalte = "{0}?callbackurl=null&oauth_consumer_key={1}&oauth_nonce={2}&oauth_signature={5}&oauth_signature_method=HMAC-SHA1&oauth_timestamp={4}&oauth_token={6}&oauth_version=1.0"
 paraUrlTempalte = "callbackurl=null&oauth_consumer_key={1}&oauth_nonce={2}&oauth_signature_method=HMAC-SHA1&oauth_timestamp={4}&oauth_token={6}&oauth_version=1.0"
     'callbackurl=null&clientip=222.95.116.115&format=json&
        
        
        baseStringTemplate = "{method}&{encode_tokenUrl}&{encode_paraUrl}" '用于生成signature

        oauth_nonce = makePassword(10)  '随机数
        oauth_timestamp = DateDiff("s", "01/01/1970 08:00:00", Now()) '邮戳
        paraUrl = Replace(paraUrlTempalte, "{1}", Me.c_App_Key) '参数串
        paraUrl = Replace(paraUrl, "{2}", oauth_nonce)
        paraUrl = Replace(paraUrl, "{4}", oauth_timestamp)
        paraUrl = Replace(paraUrl, "{6}", Me.c_access_token)
          
        baseString = Replace(baseStringTemplate, "{method}", "GET")
        baseString = Replace(baseString, "{encode_tokenUrl}", strUrlEnCode(tokenUrl2))
        baseString = Replace(baseString, "{encode_paraUrl}", strUrlEnCode(paraUrl))
        
'        Debug.Print baseString
        oauth_signature = HAMC_SHA1(Me.c_App_Secret + "&" + Me.c_access_token_secret, baseString)
'        MsgBox Me.c_App_Secret + "&" + Me.c_oauth_token_secret
'        MsgBox oauth_signature
        
        codeUrl = Replace(codeUrlTempalte, "{0}", tokenUrl2)
        codeUrl = Replace(codeUrl, "{1}", Me.c_App_Key)
        codeUrl = Replace(codeUrl, "{2}", oauth_nonce)
        codeUrl = Replace(codeUrl, "{4}", oauth_timestamp)
        codeUrl = Replace(codeUrl, "{5}", oauth_signature)
        codeUrl = Replace(codeUrl, "{6}", Me.c_access_token)

'        Debug.Print codeUrl

'        Debug.Print Me.c_oauth_token_secret

        tempstr = httpGet(codeUrl)
        tempstr0 = tempstr
        
        errcode = GetValueFromJson(tempstr0, "errcode")
        If errcode = 0 Then
         Me.c_accesstoken2_0 = GetValueFromJson(tempstr0, "data.accesstoken")
         Me.c_expiretime2_0 = GetValueFromJson(tempstr0, "data.expiretime")
         Me.c_refreshtoken2_0 = GetValueFromJson(tempstr0, "data.refreshtoken")
         Me.c_getTokenTime = Now()
        End If
        
        Get_oAuth2 = tempstr
'        Debug.Print tempstr
'        Debug.Print Me.c_accesstoken2_0
End Function
Public Function Get_oAuth2ByRefreshToken()
If IsDate(Me.c_getTokenTime) = False Then
   Get_oAuth2ByRefreshToken = Get_oAuth2
 ElseIf DateDiff("s", Me.c_getTokenTime, Now()) - Me.c_expiretime2_0 > 0 Then
    Get_oAuth2ByRefreshToken = Get_oAuth2
 End If
End Function
Public Function Postpic(ByVal sUrl As String, Optional ByVal param As Dictionary, Optional ByVal useBaseUrl As Boolean) As String
      If useBaseUrl = True Then
      Call Get_oAuth2ByRefreshToken '如果到期再次授权
      sUrl = Replace(Me.c_baseUrl, "{0}", sUrl & "?oauth_consumer_key={1}&oauth_token={2}&oauth_version=2.0")
      End If
      
      sUrl = Replace(sUrl, "{1}", Me.c_App_Key)
      sUrl = Replace(sUrl, "{2}", Me.c_accesstoken2_0)
      
    Dim myUpload
    Set myUpload = New clsFileUpload
    With myUpload
    .c_strDestURL = sUrl
    Set .c_param = param
    .vbsUpload
    Postpic = .c_strResponseText
    'Debug.Print .c_strResponseText
    'Debug.Print .c_strErrMsg
    End With
    Set myUpload = Nothing

End Function

Public Function httpPost(ByVal sUrl As String, Optional ByVal param As Dictionary, Optional ByVal useBaseUrl As Boolean) As String
      If useBaseUrl = True Then
       Call Get_oAuth2ByRefreshToken '如果到期再次授权
      sUrl = Replace(Me.c_baseUrl, "{0}", sUrl & "?oauth_consumer_key={1}&oauth_token={2}&oauth_version=2.0")
      End If
      
      sUrl = Replace(sUrl, "{1}", Me.c_App_Key)
      sUrl = Replace(sUrl, "{2}", Me.c_accesstoken2_0)
      
      Dim http
      Set http = CreateObject("Msxml2.XMLHTTP")
      http.open "Post", sUrl, False
       http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      If param Is Nothing Then
       http.send
      Else
       http.send BuildPostContent(param)
      End If
      httpPost = http.responseText
      Set http = Nothing
'      Debug.Print sUrl
End Function



Public Function httpGet(ByVal sUrl As String, Optional ByVal param As Dictionary, Optional ByVal useBaseUrl As Boolean) As String
     If useBaseUrl = True Then
       Call Get_oAuth2ByRefreshToken '如果到期再次授权
      sUrl = Replace(Me.c_baseUrl, "{0}", sUrl & "?oauth_consumer_key={1}&oauth_token={2}&oauth_version=2.0")
      sUrl = Replace(sUrl, "{1}", Me.c_App_Key)
      sUrl = Replace(sUrl, "{2}", Me.c_accesstoken2_0)
      
      sUrl = sUrl & "&" & BuildPostContent(param)
      End If
      Dim http
      Set http = CreateObject("Msxml2.XMLHTTP")
      http.open "Get", sUrl, False
      http.send
      httpGet = http.responseText
      Set http = Nothing
End Function

Public Function BuildPostContent(ByVal p_param As Dictionary)
    Dim l As Integer, tempstr As String, PostContentTemplate As String, PostContent As String
    PostContent = ""
    PostContentTemplate = "{0}={1}"
    '排序
    Call SortDictionary(p_param, 1)
    l = p_param.Count
    For i = 0 To l - 1
        tempstr = Replace(PostContentTemplate, "{0}", p_param.Keys(i))
        tempstr = Replace(tempstr, "{1}", p_param.Items(i))
        PostContent = IIf(PostContent = "", tempstr, PostContent & "&" & tempstr)
        
    Next
    Set p_param = Nothing
    BuildPostContent = PostContent

'    Debug.Print PostContent
End Function

Public Function strUrlEnCode(ByVal strUrl)
strUrlEnCode = Replace(strUrl, "=", "%3D")
strUrlEnCode = Replace(strUrlEnCode, "&", "%26")
strUrlEnCode = Replace(strUrlEnCode, ":", "%3A")
strUrlEnCode = Replace(strUrlEnCode, "/", "%2F")
End Function


'腾讯1.0认证
Public Function httpGet1(ByVal sUrl As String, Optional ByVal param As Dictionary, Optional ByVal useBaseUrl As Boolean) As String '腾讯1.0
     If useBaseUrl = True Then
              oauth_nonce = makePassword(10)  '随机数
              oauth_timestamp = DateDiff("s", "01/01/1970 08:00:00", Now()) '邮戳
              
            With param
              .Add "oauth_consumer_key", Me.c_App_Key
              .Add "oauth_nonce", oauth_nonce
              .Add "oauth_signature_method", "HMAC-SHA1"
              .Add "oauth_timestamp", oauth_timestamp
              .Add "oauth_token", Me.c_access_token
              .Add "oauth_version", "1.0"
            End With
            Call SortDictionary(param, 1)
            paraUrl = BuildPostContent(param)
            baseUrl = Replace(Me.c_baseUrl, "{0}", sUrl)
      
        baseStringTemplate = "{method}&{encode_tokenUrl}&{encode_paraUrl}" '用于生成signature
        baseString = Replace(baseStringTemplate, "{method}", "GET")
        baseString = Replace(baseString, "{encode_tokenUrl}", strUrlEnCode(baseUrl))
        baseString = Replace(baseString, "{encode_paraUrl}", strUrlEnCode(paraUrl))
        oauth_signature = HAMC_SHA1(Me.c_App_Secret + "&" + Me.c_access_token_secret, baseString)
'Debug.Print baseString
        With param
        .Add "oauth_signature", oauth_signature
        End With
         Call SortDictionary(param, 1)
         paraUrl = BuildPostContent(param)
       sUrl = baseUrl & "?" & paraUrl
      End If
      

      Dim http
      Set http = CreateObject("Msxml2.XMLHTTP")
      http.open "Get", sUrl, False
      http.send
      httpGet1 = http.responseText
      Set http = Nothing

End Function
Public Function httpPost1(ByVal sUrl As String, Optional ByVal param As Dictionary, Optional ByVal useBaseUrl As Boolean) As String
     If useBaseUrl = True Then
          oauth_nonce = makePassword(10)  '随机数
          oauth_timestamp = DateDiff("s", "01/01/1970 08:00:00", Now()) '邮戳
          
        With param
          .Add "oauth_consumer_key", Me.c_App_Key
          .Add "oauth_nonce", oauth_nonce
          .Add "oauth_signature_method", "HMAC-SHA1"
          .Add "oauth_timestamp", oauth_timestamp
          .Add "oauth_token", Me.c_access_token
          .Add "oauth_version", "1.0"
        End With
        Call SortDictionary(param, 1)
        paraUrl = BuildPostContent(param)
        baseUrl = Replace(Me.c_baseUrl, "{0}", sUrl)
      
        baseStringTemplate = "{method}&{encode_tokenUrl}&{encode_paraUrl}" '用于生成signature
        baseString = Replace(baseStringTemplate, "{method}", "POST")
        baseString = Replace(baseString, "{encode_tokenUrl}", strUrlEnCode(baseUrl))
        baseString = Replace(baseString, "{encode_paraUrl}", strUrlEnCode(paraUrl))
        oauth_signature = HAMC_SHA1(Me.c_App_Secret + "&" + Me.c_access_token_secret, baseString)
'Debug.Print baseString
        With param
        .Add "oauth_signature", oauth_signature
        End With
         Call SortDictionary(param, 1)
         paraUrl = BuildPostContent(param)
       sUrl = baseUrl '& "?" & paraUrl
      End If
      
      Dim http
      Set http = CreateObject("Msxml2.XMLHTTP")
      http.open "Post", sUrl, False
       http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      If param Is Nothing Then
       http.send
      Else
       http.send paraUrl
      End If
      httpPost1 = http.responseText
      Set http = Nothing
'      Debug.Print sUrl
End Function
'1.0发图片还是提示签名错误，但我计算的结果和腾讯给的在线调试工具计算的结果是一致的，不知道原因 ，也不用管了，腾讯都已经在测试2.0的授权了，淘汰1.0是迟早的事情，这一点，腾讯走得太慢了，小企鹅变成懒企鹅了
Public Function Postpic1(ByVal sUrl As String, Optional ByVal param As Dictionary, Optional ByVal useBaseUrl As Boolean) As String
     If useBaseUrl = True Then
          oauth_nonce = makePassword(10) '随机数
          oauth_timestamp = DateDiff("s", "01/01/1970 08:00:00", Now())  '邮戳
          
        With param
          .Add "oauth_consumer_key", Me.c_App_Key
          .Add "oauth_nonce", oauth_nonce
          .Add "oauth_signature_method", "HMAC-SHA1"
          .Add "oauth_timestamp", oauth_timestamp
          .Add "oauth_token", Me.c_access_token
          .Add "oauth_version", "1.0"
          
          
          '把pic 弄出来
          picpath = .Item("pic")
          .Remove ("pic")
        End With
        Call SortDictionary(param, 1)
        paraUrl = BuildPostContent(param)
        baseUrl = Replace(Me.c_baseUrl, "{0}", sUrl)
      
        baseStringTemplate = "{method}&{encode_tokenUrl}&{encode_paraUrl}" '用于生成signature
        baseString = Replace(baseStringTemplate, "{method}", "POST")
        baseString = Replace(baseString, "{encode_tokenUrl}", strUrlEnCode(baseUrl))
        baseString = Replace(baseString, "{encode_paraUrl}", strUrlEnCode(paraUrl))
        oauth_signature = HAMC_SHA1(Me.c_App_Secret + "&" + Me.c_access_token_secret, baseString)
'        Debug.Print baseString
        With param
        .Add "oauth_signature", oauth_signature
'        .Add "pic", Split(picpath, "|")(2)
        End With
         Call SortDictionary(param, 1)
         paraUrl = BuildPostContent(param)
       sUrl = baseUrl & "?" & paraUrl '"format=json&content=good&clientip=49.74.73.203&jing=11&wei=18&pic=c:\13.jpg&syncflag=0" '
      End If
      Debug.Print sUrl
      '把pic加上
'       param.Remove ("pic")
    param.Add "pic", picpath

'     Call SortDictionary(param, 1)
'For i = 0 To param.Count - 1
'Debug.Print param.Keys(i) & "=" & param.Items(i)
'Next


    Dim myUpload
    Set myUpload = New clsFileUpload
    With myUpload
    .c_strDestURL = sUrl
    Set .c_param = param
    .vbsUpload
    Postpic1 = .c_strResponseText
    'Debug.Print .c_strResponseText
    'Debug.Print .c_strErrMsg
    End With
    Set myUpload = Nothing

End Function
'1.0核心函数结束


'说明：Dictionary排序
'参数：
'   objDict:Dictionary对象
'   intSort: 1 根据key排序; 2 根据value排序
Function SortDictionary(objDict, intSort)
  ' declare our variables
  Dim strDict()
  Dim objKey
  Dim strKey, strItem
  Dim x, Y, Z

  ' get the dictionary count
  Z = objDict.Count

  ' we need more than one item to warrant sorting
  If Z > 1 Then
    ' create an array to store dictionary information
    ReDim strDict(Z, 2)
    x = 0
    ' populate the string array
    For Each objKey In objDict
        strDict(x, 1) = CStr(objKey)
        strDict(x, 2) = CStr(objDict(objKey))
        x = x + 1
    Next

    ' perform a a shell sort of the string array
    For x = 0 To (Z - 2)
      For Y = x To (Z - 1)
        If StrComp(strDict(x, intSort), strDict(Y, intSort), vbTextCompare) > 0 Then
            strKey = strDict(x, 1)
            strItem = strDict(x, 2)
            strDict(x, 1) = strDict(Y, 1)
            strDict(x, 2) = strDict(Y, 2)
            strDict(Y, 1) = strKey
            strDict(Y, 2) = strItem
        End If
      Next
    Next

    ' erase the contents of the dictionary object
    objDict.RemoveAll

    ' repopulate the dictionary with the sorted information
    For x = 0 To (Z - 1)
      objDict.Add strDict(x, 1), strDict(x, 2)
    Next

  End If

End Function