对于买不起copilot会员或WPS AI会员的朋友，还想体验在文档中续写文本，可以通过宏代码实现。
下面针对MacOS和Windows推出两个版本：
1.请修改API密钥，换成免费模型
2.基本用法就是先选中文本，然后按Alt + F8调出宏操作, 选择 ChatGPT即可。
核心代码
Sub chatGPTWord()
Dim request As Object
Dim text As String, response As String, API As String, api_key As String, DisplayText As String, error_result As String
Dim startPos As Long, status_code As Long
Dim prompt As String
Dim selectedText As Range
API = "https://open.bigmodel.cn/api/paas/v4/chat/completions"
'Enter Your API Key
api_key = "请在智谱清言open.bigmodel.cn获取您自己的 API KEY"
'Model Name
modelName = "glm-4-plus"
systemPrompt = "You are a helpful chat bot that has expertise in WORD. Do not write explanations on replies. Output should be markdown format without markdown."
If api_key = "" Then
MsgBox "Error: API key is blank!"
Exit Sub
End If
' Prompt the user to select text in the document
If Selection.Type <> wdSelectionIP Then
prompt = Trim(Selection.text)
Set selectedText = Selection.Range
Else
MsgBox "请先选择内容！"
Exit Sub
End If
'Cleaning
text = Replace(prompt, Chr(34), Chr(39))
text = Replace(text, vbLf, "")
text = Replace(text, vbCr, "")
text = Replace(text, vbCrLf, "")
' Remove selection
Selection.Collapse
'Create an HTTP request object
Set request = CreateObject("MSXML2.XMLHTTP")
With request
.Open "POST", API, False
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Bearer " & api_key
.send "{""model"":""" & modelName & """, ""messages"": [{""content"":""" & systemPrompt & """,""role"":""system""},{" & _
"""content"":""" & text & """,""role"":""user""}],""temperature"": 1}"
status_code = .Status
response = .responseText
End With
'Extract content
If status_code = 200 Then
DisplayText = ExtractContent(response)
'Insert response text into Word document
selectedText.InsertAfter vbNewLine & ConvertMarkdownToWord(DisplayText)
Else
startPos = InStr(response, """message"": """) + Len("""message"": """)
endPos = InStr(startPos, response, """")
If startPos > Len("""message"": """) And endPos > startPos Then
DisplayText = Mid(response, startPos, endPos - startPos)
Else
DisplayText = ""
End If
'Insert error message into Word document
EDisplayText = "Error : " & DisplayText
selectedText.InsertAfter vbNewLine & EDisplayText
End If
'Clean up the object
Set request = Nothing
End Sub
Function ExtractContent(jsonString As String) As String
Dim startPos As Long
Dim endPos As Long
Dim Content As String
'{"choices":[{"finish_reason":"stop","index":0,"message":{"content":"<html>\n<head>\n<title>Chat Bot Introduction</title>\n</head>\n<body>\n<h1>Hello!</h1>\n<p>I am a helpful chat bot with expertise in HTML.</p>\n</body>\n</html>","role":"assistant"}}],""
startPos = InStr(1, jsonString, """content"":""") + Len("""content"": """)
endPos = InStr(startPos, jsonString, ",""role"":""") - 2
Content = Mid(jsonString, startPos, endPos - startPos)
Content = Trim(Replace(Content, "\""", Chr(34)))
Content = Replace(Content, vbCrLf, "")
Content = Replace(Content, vbLf, "")
Content = Replace(Content, vbCr, "")
Content = Replace(Content, "\n", vbCrLf)
If Right(Content, 1) = """" Then
Content = Left(Content, Len(Content) - 1)
End If
ExtractContent = Content
End Function
Function ConvertMarkdownToWord(markdownText As String)
Dim lines() As String
Dim i As Long
Dim line As String
Dim headerLevel As Integer
Dim currentParagraph As Range
Dim table As table
Dim cellContent() As String
Dim numRows As Long
Dim numColumns As Long
' 将 Markdown 文本按行分割
lines = Split(markdownText, vbCr)
On Error Resume Next
' 遍历每一行并处理
For i = 0 To UBound(lines)
line = Trim(lines(i))
' 处理标题
If Left(line, 1) = "#" Then
headerLevel = 0
Do While Mid(line, headerLevel + 1, 1) = "#"
headerLevel = headerLevel + 1
Loop
' 创建标题段落
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Trim(Replace(line, "#", "")) & vbCrLf
currentParagraph.Style = ActiveDocument.Styles("标题 " & headerLevel)
' 处理粗体
ElseIf InStr(line, "**") > 0 Then
line = Replace(line, "**", "")
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter line & vbCrLf
currentParagraph.Font.Bold = True
' 处理斜体
ElseIf InStr(line, "*") > 0 Then
line = Replace(line, "*", "")
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter line & vbCrLf
currentParagraph.Font.Italic = True
' 处理无序列表
ElseIf Left(line, 1) = "-" Or Left(line, 1) = "*" Then
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Trim(Mid(line, 2)) & vbCrLf ' 去掉前面的符号
currentParagraph.ListFormat.ApplyBulletDefault
' 处理有序列表
ElseIf IsOrderedList(line) Then
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Trim(line) & vbCrLf
currentParagraph.ListFormat.ApplyNumberDefault
' 处理链接
ElseIf InStr(line, "[") > 0 And InStr(line, "]") > 0 Then
Dim linkText As String
Dim linkURL As String
linkText = Mid(line, InStr(line, "[") + 1, InStr(line, "]") - InStr(line, "[") - 1)
linkURL = Mid(line, InStr(line, "(") + 1, InStr(line, ")") - InStr(line, "(") - 1)
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter linkText & vbCrLf
ActiveDocument.Hyperlinks.Add Anchor:=currentParagraph, Address:=linkURL, TextToDisplay:=linkText
' 处理表格
ElseIf IsMarkdownTable(lines, i) Then
' 处理表格
ConvertMarkdownToTable lines, i
' 跳过表格的行
i = i + CountRows(lines, i) + 1 ' 跳过表头和分隔行
' 处理普通段落
Else
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter line & vbCrLf
End If
Next i
End Function
Function IsOrderedList(line As String) As Boolean
Dim parts() As String
parts = Split(line, ".")
' 检查是否以数字开头并且后面跟着一个点
If UBound(parts) > 0 Then
If IsNumeric(Trim(parts(0))) And Len(Trim(parts(0))) > 0 Then
IsOrderedList = True
Exit Function
End If
End If
IsOrderedList = False
End Function
Function IsMarkdownTable(lines() As String, ByRef startIndex As Long) As Boolean
Dim headerLine As String
Dim separatorLine As String
' 检查至少有三行（表头、分隔行和至少一行数据）
If UBound(lines) < 2 Then
IsMarkdownTable = False
Exit Function
End If
headerLine = Trim(lines(startIndex))
If InStr(headerLine, "|") = 0 Then
IsMarkdownTable = False
Exit Function
End If
' 检查分隔行是否存在
If startIndex + 1 > UBound(lines) Then
IsMarkdownTable = False
Exit Function
End If
separatorLine = Trim(lines(startIndex + 1))
IsMarkdownTable = True
End Function
Function CountColumns(headerLine As String) As Long
' 计算列数，去掉第一个和最后一个 |
Dim columns() As String
columns = Split(headerLine, "|")
CountColumns = UBound(columns) - 1 ' 减去第一个和最后一个
End Function
Function CountRows(lines() As String, ByVal startIndex As Long) As Long
Dim count As Long
count = 0
' 从 startIndex + 2 开始，跳过表头和分隔行
Dim currentIndex As Long
currentIndex = startIndex + 2 ' 跳过表头和分隔行
' 继续检查直到超出边界
Do While currentIndex <= UBound(lines)
' 检查当前行是否为数据行，忽略分隔行
If Trim(lines(currentIndex) <> "") And InStr(lines(currentIndex), "|") > 0 Then
' 忽略分隔行
If Trim(InStr(lines(currentIndex), "|---") = 0) Then
count = count + 1
End If
Else
Exit Do ' 如果遇到非表格行，退出循环
End If
currentIndex = currentIndex + 1 ' 移动到下一行
Loop
CountRows = count
End Function
Sub ConvertMarkdownToTable(lines() As String, startIndex As Long)
Dim i As Long
Dim j As Long
Dim table As table
Dim cellContent As Variant
Dim numRows As Long
Dim numColumns As Long
' 计算行数和列数
'numRows = UBound(lines) - startIndex - 1 ' 减去表头和分隔行
numRows = CountRows(lines, startIndex)
numColumns = CountColumns(lines(startIndex))
' 确保行数和列数有效
If numRows <= 0 Or numColumns <= 0 Then
'MsgBox "表格行数或列数无效。", vbExclamation
Exit Sub
End If
Set MyRange = ActiveDocument.Content
MyRange.Collapse Direction:=wdCollapseEnd
' 创建 Word 表格
Set table = ActiveDocument.Tables.Add(Range:=MyRange, numRows:=numRows + 1, numColumns:=numColumns) ' +1 用于表头
'currentParagraph.InsertAfter table & vbCrLf
' 填充表头
cellContent = Split(lines(startIndex), "|")
For j = 1 To UBound(cellContent) - 1 ' 从 1 开始，忽略第一个 |
On Error Resume Next ' 忽略参数错误
table.Cell(1, j).Range.text = Trim(cellContent(j)) ' 填充表头
On Error GoTo 0 ' 关闭错误忽略
Next j
' 填充表格数据
For i = startIndex + 2 To UBound(lines) ' 从数据行开始填充
cellContent = Split(lines(i), "|")
For j = 1 To UBound(cellContent) - 1 ' 从 1 开始，忽略第一个 |
On Error Resume Next ' 忽略参数错误
table.Cell(i - startIndex, j).Range.text = Trim(cellContent(j)) ' 填充数据
On Error GoTo 0 ' 关闭错误忽略
Next j
Next i
On Error Resume Next
' 设置表格边框为 1
With table.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideLineWidth = 1
.OutsideLineWidth = 1
End With
End Sub
