97 lines
3.4 KiB
Plaintext
97 lines
3.4 KiB
Plaintext
'--------------------------------------------------
|
||
' 调用 DeepSeek API 的 VBA 代码（Word 2007 兼容版）
|
||
'--------------------------------------------------
|
||
Sub CallDeepSeekAPI()
|
||
' 需要启用以下引用（VBE -> 工具 -> 引用）：
|
||
' 1. Microsoft XML, v3.0 (或其他可用版本)
|
||
' 2. Microsoft Scripting Runtime
|
||
|
||
Dim http As Object
|
||
Dim apiKey As String
|
||
Dim apiUrl As String
|
||
Dim requestBody As String
|
||
Dim response As String
|
||
Dim selectedText As String
|
||
|
||
' 配置参数（需替换为你的API信息）
|
||
apiKey = "sk-fa515b8ff11747bab1bcc616553a4a13" ' 替换为你的API密钥
|
||
apiUrl = "https://api.deepseek.com/v1/chat/completions" ' 替换实际API地址
|
||
|
||
' 获取输入内容
|
||
If Selection.Type <> wdSelectionIP Then
|
||
selectedText = Trim(Selection.Text)
|
||
Else
|
||
selectedText = InputBox("请输入您的问题：", "DeepSeek 输入")
|
||
End If
|
||
|
||
' 输入验证
|
||
If selectedText = "" Then
|
||
MsgBox "输入内容不能为空！", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
' 构建请求体（根据API文档调整）
|
||
requestBody = "{"
|
||
requestBody = requestBody & """model"": ""deepseek-chat"","
|
||
requestBody = requestBody & """messages"": [{""role"": ""user"", ""content"": """ & EscapeJSON(selectedText) & """}],"
|
||
requestBody = requestBody & """temperature"": 0.7"
|
||
requestBody = requestBody & "}"
|
||
|
||
' 发送请求（使用旧版 XMLHTTP）
|
||
Set http = CreateObject("MSXML2.XMLHTTP.6.0")
|
||
On Error Resume Next
|
||
With http
|
||
.Open "POST", apiUrl, False
|
||
.setRequestHeader "Content-Type", "application/json"
|
||
.setRequestHeader "Authorization", "Bearer " & apiKey
|
||
.send requestBody
|
||
|
||
If .Status = 200 Then
|
||
response = .responseText
|
||
' 解析响应
|
||
Dim resultText As String
|
||
resultText = ExtractContentFromJSON(response)
|
||
|
||
' 插入到文档
|
||
If resultText <> "" Then
|
||
Selection.InsertAfter vbNewLine & "[DeepSeek 响应]：" & resultText
|
||
Else
|
||
MsgBox "解析响应失败，原始响应：" & response
|
||
End If
|
||
Else
|
||
MsgBox "请求失败（状态码：" & .Status & "）" & vbNewLine & .responseText
|
||
End If
|
||
End With
|
||
|
||
' 错误处理
|
||
If Err.Number <> 0 Then
|
||
MsgBox "发生错误：" & Err.Description, vbCritical
|
||
End If
|
||
End Sub
|
||
|
||
' JSON特殊字符转义
|
||
Function EscapeJSON(ByVal s As String) As String
|
||
EscapeJSON = Replace(s, "\", "\\")
|
||
EscapeJSON = Replace(EscapeJSON, """", "\""")
|
||
EscapeJSON = Replace(EscapeJSON, vbCr, "\r")
|
||
EscapeJSON = Replace(EscapeJSON, vbLf, "\n")
|
||
EscapeJSON = Replace(EscapeJSON, vbTab, "\t")
|
||
End Function
|
||
|
||
' 简单JSON解析（兼容旧版环境）
|
||
Function ExtractContentFromJSON(ByVal jsonStr As String) As String
|
||
Dim startPos As Long
|
||
Dim endPos As Long
|
||
|
||
' 查找 "content": "..." 的位置
|
||
startPos = InStr(1, jsonStr, """content"": """) + 11
|
||
If startPos > 11 Then
|
||
endPos = InStr(startPos, jsonStr, """")
|
||
If endPos > startPos Then
|
||
ExtractContentFromJSON = Mid(jsonStr, startPos, endPos - startPos)
|
||
' 还原转义字符
|
||
ExtractContentFromJSON = Replace(ExtractContentFromJSON, "\""", """")
|
||
ExtractContentFromJSON = Replace(ExtractContentFromJSON, "\n", vbCrLf)
|
||
End If
|
||
End If
|
||
End Function |