word2010工具栏嵌入deepseek来检测书写语法

 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中，自定义快速访问工具栏，选择宏，添加刚新建的宏到快捷访问栏。

六、用法。选中文本，电极自定义工具栏的宏命令用来检测选中文本或全文。