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