word下宏命令添加右键菜单调用大语言模型

word开发者模式下，直接选visual basic，把代码粘贴进去，CrateSelectedTextWithAI()函数下把apikey换成你自己的密钥，我这个密钥不可用。这里调用的是月之暗面的模型（有一定免费额度），其他模型的没试过，应该也能用。

apiKey = "换成你自己密钥"

然后关闭visual basic窗口，运行宏命令AddCustomMenuItem，这样就添加了右键菜单。在word中选择要替换的内容或者要生成的内容，然后右键，选择菜单，则根据菜单进行替换或者生成。提示词可根据自己的需要进行修改，没实现流式输出，好像vba下不行。只是简单的调用演示。

Sub AddCustomMenuItem()
    Dim cb As CommandBar
    Dim cbBtn As CommandBarButton
    
    ' 检查是否已经存在该菜单项，若存在则先删除
    On Error Resume Next
    Application.CommandBars("Text").Controls("AI替换内容").Delete
    Application.CommandBars("Text").Controls("AI生成内容").Delete
    On Error GoTo 0
    
    ' 在右键菜单中添加菜单项
    Set cb = Application.CommandBars("Text")
    Set cbBtn = cb.Controls.Add(Type:=msoControlButton)
    With cbBtn
        .Caption = "AI替换内容"
        .OnAction = "ReplaceSelectedTextWithAI"
    End With
    Set cb2 = Application.CommandBars("Text")
    Set cbBtn2 = cb.Controls.Add(Type:=msoControlButton)
    With cbBtn2
        .Caption = "AI生成内容"
        .OnAction = "CrateSelectedTextWithAI"
    End With
End Sub

Sub ReplaceContent()
    Dim originalText As String
    Dim newText As String
    
    ' 获取选定文本
    originalText = Selection.Text
    
    ' 弹出输入框让用户输入新的文本
    'newText = InputBox("请输入要替换的新内容：", "替换内容")
    
    ' 替换选定文本的内容为新内容，并保留原始格式
    Selection.Text = newText
End Sub
Sub CrateSelectedTextWithAI()
    Dim xhr As Object
    Dim apiKey As String
    Dim apiUrl As String
    Dim selectedText As String
    Dim response As String
    Dim message As String
    
    ' 初始化API密钥和端点，换成你自己的密钥

    apiKey = "sk-ce20qi5Cetn7mV4RqyFruxMMrZHWGz7AHT2Hcfv0"
    apiUrl = "https://api.moonshot.cn/v1/chat/completions"
    
    ' 创建XMLHttpRequest对象
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    
    ' 获取用户选择的文本
    If Selection.Type = 2 Then
        selectedText = Selection.Text
    Else
        MsgBox "Please select some text first."
        Exit Sub
    End If
    
    ' 将 '\\r' 替换为换行符
    selectedText = Replace(selectedText, vbCr, "\n")
    
    ' 构建JSON字符串
    Dim jsonText As String
    jsonText = _
    "{" & vbCrLf & _
    "  ""model"": ""moonshot-v1-32k""," & vbCrLf & _
    "  ""messages"": [" & vbCrLf & _
    "    {""role"": ""system"", ""content"": ""你将收到一段或多段文字，将提供的文字内容替换，在保留原有含义的基础上，降低重复率，并进行内容扩充，内容扩充到原来的2倍""}," & vbCrLf & _
    "    {""role"": ""user"", ""content"": """ & selectedText & """}" & vbCrLf & _
    "  ]," & vbCrLf & _
    "  ""temperature"": 0.3" & vbCrLf & _
    "}"
    
    ' 发送请求到Moonshot AI的API
    xhr.Open "POST", apiUrl, False
    xhr.setRequestHeader "Authorization", "Bearer " & apiKey
    xhr.setRequestHeader "Content-Type", "application/json"
    xhr.send jsonText
    
    ' 获取响应
    response = xhr.responseText
    
    ' 检查响应是否包含错误信息
    If InStr(response, """error""") > 0 Then
        ' 解析错误信息
        Dim errorType As String
        errorType = Mid(response, InStr(response, """type"":""") + Len("""type"":"""), InStr(InStr(response, """type"":""") + Len("""type"":"""), response, """") - InStr(response, """type"":""") - Len("""type"":"""))
        
        ' 根据错误类型显示相应的提示消息
        Select Case errorType
            Case "invalid_authentication_error"
                MsgBox "鉴权失败请确认，请确认API key 是否有效。"
            Case "invalid_request_error"
                MsgBox "输入格式有误，使用了预期外的参数。"
            Case "rate_limit_reached_error"
                MsgBox "You have exceeded the rate limit. Please try again later."
            Case "exceeded_current_quota_error"
                MsgBox "超过每分钟最大访问次数限制。"
            Case Else
                MsgBox "费用不够了，请购买相关服务。"
        End Select
    Else
        ' 解析JSON响应
        message = Mid(response, InStr(response, """content"":""") + Len("""content"":"""), InStr(InStr(response, """content"":""") + Len("""content"":"""), response, """") - InStr(response, """content"":""") - Len("""content"":"""))
        
        ' 提取新内容
        If message <> "" Then
            ' 替换所选文本
            Selection.Text = Replace(message, "\n", vbCr)
        Else
            MsgBox "No new content received from the API."
        End If
    End If
End Sub

Sub ReplaceSelectedTextWithAI()
    Dim xhr As Object
    Dim apiKey As String
    Dim apiUrl As String
    Dim selectedText As String
    Dim response As String
    Dim message As String
    
    ' 初始化API密钥和端点
    apiKey = "sk-ce20qi5Cetn7mV4RqyFruxMMrZHWGz7AHT2Hcfv0xFudCbDo"
    apiUrl = "https://api.moonshot.cn/v1/chat/completions"
    
    ' 创建XMLHttpRequest对象
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    
    ' 获取用户选择的文本
    If Selection.Type = 2 Then
        selectedText = Selection.Text
    Else
        MsgBox "Please select some text first."
        Exit Sub
    End If
    
    ' 将 '\\r' 替换为换行符
    selectedText = Replace(selectedText, vbCr, "\n")
    
    ' 构建JSON字符串
    Dim jsonText As String
    jsonText = _
    "{" & vbCrLf & _
    "  ""model"": ""moonshot-v1-32k""," & vbCrLf & _
    "  ""messages"": [" & vbCrLf & _
    "    {""role"": ""system"", ""content"": ""你将收到一段或多段文字，将其内容进行细化扩充，每段内容扩充作为至少600字""}," & vbCrLf & _
    "    {""role"": ""user"", ""content"": """ & selectedText & """}" & vbCrLf & _
    "  ]," & vbCrLf & _
    "  ""temperature"": 0.3" & vbCrLf & _
    "}"
    
    ' 发送请求到Moonshot AI的API
    xhr.Open "POST", apiUrl, False
    xhr.setRequestHeader "Authorization", "Bearer " & apiKey
    xhr.setRequestHeader "Content-Type", "application/json"
    xhr.send jsonText
    
    ' 获取响应
    response = xhr.responseText
    
    ' 检查响应是否包含错误信息
    If InStr(response, """error""") > 0 Then
        ' 解析错误信息
        Dim errorType As String
        errorType = Mid(response, InStr(response, """type"":""") + Len("""type"":"""), InStr(InStr(response, """type"":""") + Len("""type"":"""), response, """") - InStr(response, """type"":""") - Len("""type"":"""))
        
        ' 根据错误类型显示相应的提示消息
        Select Case errorType
            Case "invalid_authentication_error"
                MsgBox "鉴权失败请确认，请确认API key 是否有效。"
            Case "invalid_request_error"
                MsgBox "输入格式有误，使用了预期外的参数。"
            Case "rate_limit_reached_error"
                MsgBox "You have exceeded the rate limit. Please try again later."
            Case "exceeded_current_quota_error"
                MsgBox "超过每分钟最大访问次数限制。"
            Case Else
                MsgBox "费用不够了，请购买相关服务。"
        End Select
    Else
        ' 解析JSON响应
        message = Mid(response, InStr(response, """content"":""") + Len("""content"":"""), InStr(InStr(response, """content"":""") + Len("""content"":"""), response, """") - InStr(response, """content"":""") - Len("""content"":"""))
        
        ' 提取新内容
        If message <> "" Then
            ' 替换所选文本
            Selection.Text = Replace(message, "\n", vbCr)
        Else
            MsgBox "No new content received from the API."
        End If
    End If
End Sub
Function ParseJSONContent(ByVal strContent As String) As String
    Dim sc As Object
    Dim jsonObj As Object
    Dim content As String
    Dim message As String
    
    ' 创建 ScriptControl 对象
    Set sc = CreateObject("ScriptControl")
    sc.Language = "JScript"
    
    ' JSON 字符串
    content = strContent
    
    ' 解析 JSON 字符串
    sc.ExecuteStatement "var obj = " & content
    Set jsonObj = sc.Eval("obj")
    
    ' 获取 content 字段的值
    message = sc.Eval("obj.choices[0].message.content")
    
    ' 释放对象
    Set jsonObj = Nothing
    Set sc = Nothing
    ParseJSONContent = message
    
End Function