1.打开Word，依次点击视图（View）→宏（Macros），取一个“宏”名并点击“创建”（create）。

2.删除“宏”（Macros）中原有的代码，将以下代码复制至框中：
 

Sub chatGPT()
    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 Info
    API = "https://api.openai.com/v1/chat/completions"
    'API Key
 api_key = "sk-xxxxxxxxxxxxxxxxxxxxxxx"
    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 "Please select some text before running this macro."
        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"": ""gpt-3.5-turbo"",  ""messages"": [{""content"":""" & text & """,""role"":""user""}]," _
             & """temperature"": 1, ""top_p"": 0.7}"
      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 & 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
    startPos = InStr(jsonString, """content"": """) + Len("""content"": """)
    endPos = InStr(startPos, jsonString, "},") - 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

将 API 密钥替换api_key为您的实际 API 密钥。创建自己的API密钥。

关闭 VBA 编辑器。

3.按Alt+F8运行宏，然后选择ChatGPT并单击“运行”按钮。