直接上代码，由于时间匆忙，以后写个详细的教程
#If VBA7 ThenPrivate 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
#ElsePrivate 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 IfSub GetSelectedTextAndCallDouBaoAPI()Dim selectedText As StringDim apiUrl As StringDim apiKey As StringDim requestBody As StringDim http As ObjectDim responseText As String' 获取当前选中的文本On Error Resume NextselectedText = Selection.TextOn Error GoTo 0If selectedText = "" ThenMsgBox "请先在文档中选择一段文字！", vbExclamationExit SubEnd 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 " & apiKeyDebug.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 = .responseTextDebug.Print "Response: " & responseTextEnd With' 检查并处理响应If InStr(responseText, "error") > 0 ThenMsgBox "API调用失败: " & responseText, vbCriticalExit SubEnd If' 解析结果（根据实际API返回格式调整）resultContent = ParseResponse(responseText)' 插入结果到文档If resultContent <> "" ThenSelection.InsertAfter vbNewLine & "豆包回复：" & vbNewLine & resultContentElseMsgBox "API返回结果解析失败111"End If
End SubFunction ParseResponse(responseText As String) As String' 自定义解析逻辑（根据实际API返回格式调整）Dim contentTag As StringDim StartPos As LongDim EndPos As Long' 示例解析方式：查找 "content": "..." 模式contentTag = """content"":"""StartPos = InStr(responseText, contentTag)If StartPos > 0 ThenStartPos = StartPos + Len(contentTag) + 1 ' 跳过引号EndPos = InStr(StartPos, responseText, """")If EndPos > StartPos ThenParseResponse = Mid(responseText, StartPos, EndPos - StartPos)' 处理转义字符ParseResponse = Replace(ParseResponse, "\n", vbNewLine)ParseResponse = Replace(ParseResponse, "\""", """")End IfEnd If
End Function
代码中有两个参数需要替换，一个是apikey,另一个是model
效果如下：
