wps或office的word接入豆包API(VBA版本)

直接上代码，由于时间匆忙，以后写个详细的教程

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Sub GetSelectedTextAndCallDouBaoAPI()
    Dim selectedText As String
    Dim apiUrl As String
    Dim apiKey As String
    Dim requestBody As String
    Dim http As Object
    Dim responseText As String
    
    ' 获取当前选中的文本
    On Error Resume Next
    selectedText = Selection.Text
    On Error GoTo 0
    
    If selectedText = "" Then
        MsgBox "请先在文档中选择一段文字！", vbExclamation
        Exit Sub
    End If
    
    ' 设置API相关信息
    apiUrl = "https://ark.cn-beijing.volces.com/api/v3/chat/completions"
    apiKey = "xxx-xxx-xxxx" ' 请替换为你的实际API密钥
    
    ' 转义特殊字符
    selectedText = Replace(selectedText, """", "\""")   ' 转义双引号
    selectedText = Replace(selectedText, "\", "\\")     ' 转义反斜杠
    
    ' 构建请求体（根据实际API文档调整）
    requestBody = "{""model"":""xxxx-xxx-xxx"",""messages"":[{""role"":""user"",""content"":""" & selectedText & """}]}"
    ' 清除字符串中的回车和换行符
    requestBody = Replace(requestBody, vbCrLf, "")
    requestBody = Replace(requestBody, vbCr, "")
    requestBody = Replace(requestBody, vbLf, "")
    
    ' 打印调试信息
    Debug.Print "Authorization: Bearer " & apiKey
    Debug.Print "Request Body: " & requestBody
    
    ' 创建HTTP请求对象
    Set http = CreateObject("MSXML2.XMLHTTP")
    
    ' 发送POST请求
    With http
        .Open "POST", apiUrl, False
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "Authorization", "Bearer " & apiKey ' 确保API密钥通过Authorization头传递
        .send requestBody
        
        ' 获取响应文本
        responseText = .responseText
        Debug.Print "Response: " & responseText
    End With
    
    ' 检查并处理响应
    If InStr(responseText, "error") > 0 Then
        MsgBox "API调用失败: " & responseText, vbCritical
        Exit Sub
    End If
    
    ' 解析结果（根据实际API返回格式调整）
    resultContent = ParseResponse(responseText)
    
    ' 插入结果到文档
    If resultContent <> "" Then
        Selection.InsertAfter vbNewLine & "豆包回复：" & vbNewLine & resultContent
    Else
        MsgBox "API返回结果解析失败111"
    End If
End Sub

Function ParseResponse(responseText As String) As String
    ' 自定义解析逻辑（根据实际API返回格式调整）
    Dim contentTag As String
    Dim StartPos As Long
    Dim EndPos As Long
    
    ' 示例解析方式：查找 "content": "..." 模式
    contentTag = """content"":"""
    StartPos = InStr(responseText, contentTag)
    
    If StartPos > 0 Then
        StartPos = StartPos + Len(contentTag) + 1 ' 跳过引号
        EndPos = InStr(StartPos, responseText, """")
        If EndPos > StartPos Then
            ParseResponse = Mid(responseText, StartPos, EndPos - StartPos)
            ' 处理转义字符
            ParseResponse = Replace(ParseResponse, "\n", vbNewLine)
            ParseResponse = Replace(ParseResponse, "\""", """")
        End If
    End If
End Function

代码中有两个参数需要替换，一个是apikey,另一个是model

把代码复制到wps或者word的VBA编辑器中即可运行

效果如下：