1、创建宏
一、前期准备
获取API密钥
1. 访问 DeepSeek 官网：https://platform.deepseek.com
2. 注册/登录账号
3. 进入控制台：API Keys
4. 创建新的API密钥并保存
启用Word开发工具
1. 文档 → 选项 → 自定义功能区
2. 右侧勾选「开发工具」
3. 确定
二、创建VBA代码
打开VBA编辑器
1. 点击「开发工具」选项卡
2. 点击「Visual Basic」
或
按 Alt + F11
添加引用
1. 工具 → 引用
2. 勾选：
☑ Microsoft XML, v6.0
☑ Microsoft VBScript Regular Expressions 5.5
3. 确定
创建新模块
1. 插入 → 模块
2. 粘贴以下代码
三、完整代码
Option Explicit
' API配置（请替换为你的真实API密钥）
Private Const API_KEY As String = "your_api_key_here"
Private Const API_URL As String = "https://api.deepseek.com/v1/chat/completions"
Private Const MODEL_NAME As String = "deepseek-chat"
' 主函数：检查选中文本的病句和错别字
Sub CheckGrammarWithDeepSeek()
On Error GoTo ErrorHandler
' 1. 检查是否选中文本
If Selection.Type = wdSelectionIP Then
MsgBox "请先选择要检查的文本段落！", vbExclamation, "提示"
Exit Sub
End If
Dim selectedText As String
selectedText = Selection.Text
' 2. 长度保护（DeepSeek上下文约8K token，中文约4000字）
If Len(selectedText) > 5000 Then
If MsgBox("选中文本较长（约" & Len(selectedText) & "字符），可能影响处理速度。" & vbCrLf & _
"建议分批量检查。是否继续？", vbYesNo + vbQuestion, "文本过长") = vbNo Then
Exit Sub
End If
End If
' 3. 显示状态栏提示
Dim oldStatusBar As Boolean
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
StatusBar = "正在连接AI进行语法检查..."
' 4. 创建HTTP对象
Dim http As Object
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
' 设置超时（毫秒）：解析、连接、发送、接收
http.setTimeouts 30000, 60000, 60000, 120000
' 5. 构建系统提示（内核：只报告明显必须改正的错误）
Dim systemPrompt As String
systemPrompt = "你是一个严格的中文校对专家。请只指出用户文本中**明显且必须改正**的错误，包括：" & vbCrLf & _
"1. 错别字（如同音字、形近字误用，例如：的/地/得混淆、'在'写成'再'等）" & vbCrLf & _
"2. 病句（语序错误、主谓搭配不当、成分缺失导致语句不通）" & vbCrLf & _
"3. 标点符号严重错误（如句号缺失导致句子粘连）" & vbCrLf & _
"4. 重复或遗漏关键词汇" & vbCrLf & vbCrLf & _
"忽略轻微的修辞、风格问题（如口语化表达、重复虚词等）。" & vbCrLf & _
"输出格式要求（严格遵守）：" & vbCrLf & _
"如果没有错误，只输出：未发现必须改正的错误。" & vbCrLf & _
"如果有错误，每一条错误按照以下格式列出：" & vbCrLf & _
"----------------------------------------" & vbCrLf & _
"原文：[有错误的原句或短语]" & vbCrLf & _
"类型：[错别字/病句/标点/重复遗漏]" & vbCrLf & _
"修改建议：[正确写法]" & vbCrLf & _
"说明：[简短的错误解释]" & vbCrLf & _
"----------------------------------------" & vbCrLf & _
"注意：不要输出任何额外说明、开场白或结束语，直接输出检查结果。"
' 6. 构建请求体（温度设为0.2，保证结果稳定）
Dim requestBody As String
requestBody = "{""model"":""" & MODEL_NAME & """," & _
"""messages"":[" & _
"{""role"":""system"",""content"":""" & SafeJsonEncode(systemPrompt) & """}," & _
"{""role"":""user"",""content"":""" & SafeJsonEncode(selectedText) & """}" & _
"],""temperature"":0.2,""max_tokens"":1500}"
StatusBar = "正在提交请求..."
' 7. 发送请求
With http
.Open "POST", API_URL, False
.setRequestHeader "Content-Type", "application/json; charset=UTF-8"
.setRequestHeader "Authorization", "Bearer " & API_KEY
.send requestBody
End With
StatusBar = "正在解析结果..."
' 8. 处理响应
If http.Status = 200 Then
Dim responseText As String
responseText = ParseResponseImproved(http.responseText)
' 在Word中插入结果（保留原文本格式）
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertAfter vbCrLf & vbCrLf & "【DeepSeek语法检查结果】" & vbCrLf
Selection.InsertAfter String(50, "=") & vbCrLf
Selection.InsertAfter responseText
Selection.InsertAfter vbCrLf & String(50, "=") & vbCrLf
MsgBox "检查完成！", vbInformation, "成功"
Else
Dim errorDetail As String
errorDetail = ExtractApiError(http.responseText)
MsgBox "API请求失败：" & http.Status & " " & http.statusText & vbCrLf & _
"详细信息：" & errorDetail, vbCritical, "错误"
End If
' 9. 恢复状态栏
StatusBar = ""
Application.DisplayStatusBar = oldStatusBar
Exit Sub
ErrorHandler:
StatusBar = ""
Application.DisplayStatusBar = oldStatusBar
MsgBox "运行时错误：" & Err.Description & vbCrLf & "错误编号：" & Err.Number, vbCritical, "异常"
End Sub
' 安全JSON编码（处理所有特殊字符）
Private Function SafeJsonEncode(ByVal InputText As String) As String
Dim result As String
Dim i As Long
Dim ch As String
result = ""
For i = 1 To Len(InputText)
ch = Mid(InputText, i, 1)
Select Case ch
Case "\": result = result & "\\"
Case """": result = result & "\"""
Case vbCr: result = result & "\r"
Case vbLf: result = result & "\n"
Case vbTab: result = result & "\t"
Case vbBack: result = result & "\b"
Case vbFormFeed: result = result & "\f"
Case Else
' 中文等Unicode字符无需转义，直接保留
result = result & ch
End Select
Next i
SafeJsonEncode = result
End Function
' 改进的JSON解析（处理多行、转义字符）
Private Function ParseResponseImproved(ByVal jsonText As String) As String
On Error GoTo ParseErr
' 使用正则提取 "content" 字段的内容（支持转义引号和换行）
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
' 模式说明：匹配 "content": " ... " ，其中内容可以包含转义符 \"
regex.Pattern = """content""\s*:\s*""((?:[^""\\]|\\.)*?)""(?=\s*[,}])"
regex.Global = False
regex.MultiLine = True
regex.IgnoreCase = False
If regex.Test(jsonText) Then
Dim matches As Object
Set matches = regex.Execute(jsonText)
Dim content As String
content = matches(0).SubMatches(0)
' 还原转义串行
content = UnescapeJsonString(content)
ParseResponseImproved = Trim(content)
Else
' 备用解析：查找 finish_reason 判断是否成功
If InStr(jsonText, "finish_reason") > 0 Then
ParseResponseImproved = "API响应解析失败，但请求可能已处理。原始片段：" & vbCrLf & Left(jsonText, 300)
Else
ParseResponseImproved = "无法解析API响应，请检查API密钥或网络。"
End If
End If
Exit Function
ParseErr:
ParseResponseImproved = "解析响应时出错：" & Err.Description & vbCrLf & "前200字符：" & Left(jsonText, 200)
End Function
' 还原JSON转义字符串
Private Function UnescapeJsonString(ByVal str As String) As String
Dim result As String
Dim i As Long
result = ""
i = 1
While i <= Len(str)
If Mid(str, i, 1) = "\" And i < Len(str) Then
Dim nextChar As String
nextChar = Mid(str, i + 1, 1)
Select Case nextChar
Case "n": result = result & vbCrLf: i = i + 2
Case "r": result = result & vbCr: i = i + 2
Case "t": result = result & vbTab: i = i + 2
Case """": result = result & """": i = i + 2
Case "\": result = result & "\": i = i + 2
Case "u": ' 简单处理Unicode转义（如 \u4e2d），直接忽略并跳过6个字符
result = result & "[Unicode]": i = i + 6
Case Else: result = result & "\": i = i + 1
End Select
Else
result = result & Mid(str, i, 1)
i = i + 1
End If
Wend
UnescapeJsonString = result
End Function
' 提取API返回的错误信息
Private Function ExtractApiError(ByVal jsonText As String) As String
On Error Resume Next
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Pattern = """message""\s*:\s*""([^""]+)"""
If regex.Test(jsonText) Then
ExtractApiError = regex.Execute(jsonText)(0).SubMatches(0)
Else
ExtractApiError = "无详细错误信息"
End If
End Function
' 可选辅助函数：检查整个文档
Sub CheckWholeDocument()
Selection.WholeStory
CheckGrammarWithDeepSeek
End Sub
' 可选辅助函数：检查当前段落
Sub CheckCurrentParagraph()
Selection.Paragraphs(1).Range.Select
CheckGrammarWithDeepSeek
End Sub
四、另存为（另存选项） 启用宏的模板，扩展名为dotm，将此模板保存在word的templates位置。在word中，文档-选项-加载项-模板-添加，选择刚新建的模板。
五、在word中，自定义快速访问工具栏，选择宏，添加刚新建的宏到快捷访问栏。
六、用法。选中文本，电极自定义工具栏的宏命令用来检测选中文本或全文。
