Wer sich eine Copilot- oder WPS AI-Mitgliedschaft nicht leisten kann und trotzdem Fließtext in einem Dokument erleben möchte, kann dies mit Makrocode tun.
Zwei Versionen sind unten für MacOS und Windows verfügbar:
1. bitte ändern Sie den API-Schlüssel und ersetzen Sie ihn durch ein freies Modell.
(2) Grundsätzlich wird der Text zuerst markiert und dann die TasteAlt + F8Rufen Sie die Makrooperation auf, wählen Sie ChatGPTEs kann losgehen.
Kern-Code
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"
'Geben Sie Ihren API-Schlüssel ein
api_key = "Bitte holen Sie sich Ihren eigenen API-Schlüssel bei open.bigmodel.cn"
Modellname
modelName = "glm-4-plus"
systemPrompt = "Du bist ein hilfreicher Chatbot, der sich mit WORD auskennt. Schreibe keine Erklärungen in die Antworten. output should be markdown format without Die Ausgabe sollte im Markdown-Format ohne Markdown erfolgen."
If api_key = "" Then
MsgBox "Fehler: API-Schlüssel ist leer!"
Exit Sub
End If
' Aufforderung an den Benutzer, Text im Dokument auszuwählen
If Selection.Type wdSelectionIP Then
prompt = Trim(Auswahl.Text)
Set selectedText = Selection.Range
Selection.text Then prompt = Trim(Selection.text) Set selectedText = Selection.
MsgBox "Bitte wählen Sie zuerst den Inhalt aus!"
Exit Sub
End If
'Reinigen
text = Replace(prompt, Chr(34), Chr(39))
text = Ersetzen(text, vbLf, "")
text = Ersetzen(text, vbCr, "")
text = Ersetzen(text, vbCrLf, "")
' Auswahl aufheben
Selection.Collapse
' Ein HTTP-Anfrageobjekt erstellen
Set request = CreateObject("MSXML2.XMLHTTP")
Mit request
.Open "POST", API, False
.setRequestHeader "Inhalts-Typ", "anwendung/json"
.setRequestHeader "Authorisation", "Bearer " & api_key
.send "{""model"":""" & modelName & """, ""messages"": [{""content"":""" & systemPrompt & """,""role"":""system""},{" & _
"""content"":""" & text & ""","" & role"":"""user""}],"""temperature"": 1}""
status_code = .Status
Antwort = .responseText
Ende mit
'Inhalt extrahieren
Wenn status_code = 200 Dann
DisplayText = ExtractContent(response)
'Antworttext in Word-Dokument einfügen
selectedText.InsertAfter vbNewLine & ConvertMarkdownToWord(DisplayText)
StartPos = InStr(Antwort, "")
startPos = InStr(Antwort, """Nachricht"": """) + Len("""Nachricht"": """)
endPos = InStr(startPos, antwort, """")
If startPos > Len("""message"": """) And endPos > startPos Then
DisplayText = Mid(Antwort, startPos, endPos - startPos)
Sonst
DisplayText = ""
Ende Wenn
'Fehlermeldung in Word-Dokument einfügen
EDisplayText = "Fehler : " & DisplayText
selectedText.InsertAfter vbNewLine & EDisplayText
End If
'Das Objekt aufräumen
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 Einführung</title>\n</head>\n<body>\n<h1>Hallo!</h1>\n<p>Ich bin ein hilfsbereiter Chatbot mit Fachkenntnissen in HTML.</p>\n</body>\n</html>", "Rolle": "Assistent"}}],""
startPos = InStr(1, jsonString, """Inhalt"":""") + Len("""Inhalt"": """)
endPos = InStr(startPos, jsonString, ","""Rolle"":""") - 2
Inhalt = Mid(jsonString, startPos, endPos - startPos)
Inhalt = Trim(Replace(Inhalt, "\""", Chr(34)))
Inhalt = Replace(Inhalt, vbCrLf, "")
Inhalt = Replace(Inhalt, vbLf, "")
Inhalt = Replace(Inhalt, vbCr, "")
Inhalt = Replace(Inhalt, "\n", vbCrLf)
If Right(Content, 1) = """" Then
Inhalt = Links(Inhalt, Len(Inhalt) - 1)
Ende Wenn
ExtraktInhalt = Inhalt
Ende Funktion
Function ConvertMarkdownToWord(markdownText As String)
Dim lines() As String
Dim i As Long
Dim lines As String
Dim headerLevel As Integer
Dim currentParagraph As Range
Dim table As table
Dim cellContent() As String
Dim cellContent() As String Dim numRows As Long
Dim numColumns As Long
' Markdown-Text nach Zeilen aufteilen
lines = Split(markdownText, vbCr)
On Error Resume Next
' Iterieren über jede Zeile und verarbeiten
For i = 0 To UBound(lines)
lines = Trim(lines(i))
' Verarbeiten der Überschriften
If Left(Zeile, 1) = "#" Then
headerLevel = 0
Do While Mid(Zeile, KopfzeileLevel + 1, 1) = "#"
headerLevel = headerLevel + 1
Schleife
' Erzeugen des Kopfabsatzes
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Trim(Replace(line, "#", "")) & vbCrLf
currentParagraph.Style = ActiveDocument.Styles("Kopfzeile" & headerLevel)
' Fettschrift behandeln
ElseIf InStr(Zeile, "**") > 0 Then
Zeile = Ersetzen(Zeile, "**", "")
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Zeile & vbCrLf
currentParagraph.Font.Bold = True
' Kursivschrift behandeln
ElseIf InStr(line, "*") > 0 Then
Zeile = Ersetzen(Zeile, "*", "")
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Zeile & vbCrLf
currentParagraph.Font.Italic = True
' Nicht geordnete Listen behandeln
ElseIf Left(line, 1) = "-" Or Left(line, 1) = "*" Then
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Trim(Mid(line, 2)) & vbCrLf ' Die vorangehenden Symbole entfernen
currentParagraph.ListFormat.ApplyBulletDefault
' Geordnete Listen handhaben
ElseIf IsOrderedList(line) Then
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Trim(Zeile) & vbCrLf
currentParagraph.ListFormat.ApplyNumberDefault
' Links behandeln
ElseIf InStr(line, "[") > 0 And InStr(line, "]") > 0 Then
Dim linkText As String
Dim linkURL As String
linkText = Mid(Zeile, InStr(Zeile, "[") + 1, InStr(Zeile, "]") - InStr(Zeile, "[") - 1)
linkURL = Mid(Zeile, InStr(Zeile, "(") + 1, InStr(Zeile, ")") - InStr(Zeile, "(") - 1)
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter linkText & vbCrLf
ActiveDocument.Hyperlinks.Add Anker:=aktuellerAbsatz, Adresse:=linkURL, TextZurAnzeige:=linkText
' Behandlung von Tabellen
ElseIf IsMarkdownTable(lines, i) Then
' Handhabung von Tabellen
ConvertMarkdownToTable Zeilen, i
' Die Zeilen der Tabelle überspringen
i = i + CountRows(lines, i) + 1 ' Tabellenköpfe und Trennzeilen überspringen
' Normale Absätze verarbeiten
Else
Set currentParagraph = ActiveDocument.Content
currentParagraph.Collapse Direction:=wdCollapseEnd
currentParagraph.InsertAfter Zeile & vbCrLf
End If
Ende Wenn
Ende Funktion
Function IsOrderedList(line As String) As Boolean
Dim parts() As String
parts = Split(line, ".")
' Prüfen, ob die Zeile mit einer Zahl beginnt und von einem Punkt gefolgt wird
If UBound(parts) > 0 Then
If IsNumeric(Trim(parts(0))) And Len(Trim(parts(0))) > 0 Then
IsOrderedList = Wahr
Funktion beenden
Ende Wenn
Ende Wenn
IsOrderedList = False
Ende Funktion
Function IsMarkdownTable(lines() As String, ByRef startIndex As Long) As Boolean
Dim headerLine As String
Dim separatorLine As String
' Prüfen, ob mindestens drei Zeilen vorhanden sind (Kopfzeile, Trennlinie und mindestens eine Zeile mit Daten)
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
Funktion beenden
Ende Wenn
separatorLine = Trim(lines(startIndex + 1))
IsMarkdownTable = Wahr
Funktion beenden
Function CountColumns(headerLine As String) As Long
' Zähle die Anzahl der Spalten und entferne dabei die erste und die letzte Spalte | '
Dim columns() As String
columns = Split(headerLine, "|")
CountColumns = UBound(columns) - 1 ' Erste und letzte Spalte subtrahieren
Funktion beenden
Function CountRows(lines() As String, ByVal startIndex As Long) As Long
Dim count As Long
ByVal startIndex As Long
' Beginnt bei startIndex + 2, überspringt Kopf- und Trennzeilen.
Dim currentIndex As Long
currentIndex = startIndex + 2 ' Überspringen von Kopf- und Trennzeilen
' Prüfung fortsetzen, bis die Grenze überschritten ist
Do While currentIndex <= UBound(lines)
' 检查当前行是否为数据行，忽略分隔行
If Trim(lines(currentIndex) <> "") And InStr(lines(currentIndex), "|") > 0 Then
' Zeilentrenner ignorieren
If Trim(InStr(lines(currentIndex), "|---") = 0) Then
count = count + 1
Ende Wenn
End If
Exit Do ' Wenn eine Nicht-Tabellenzeile gefunden wird, wird die Schleife verlassen.
End If
currentIndex = currentIndex + 1 ' Zur nächsten Zeile gehen
Schleife
CountRows = Anzahl
Ende Funktion
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 Dim numRows As Long
Dim numColumns As Long
' Berechnen der Anzahl der Zeilen und Spalten
' numRows = UBound(lines) - startIndex - 1 ' Kopf- und Trennzeilen subtrahieren
numRows = CountRows(zeilen, startIndex)
numColumns = CountColumns(lines(startIndex))
' Sicherstellen, dass die Anzahl der Zeilen und Spalten gültig ist
Wenn numRows <= 0 Or numColumns <= 0 Then
MsgBox "Ungültige Anzahl von Tabellenzeilen oder -spalten". , vbExclamation
Exit Sub
End If
Set MyRange = ActiveDocument.Content
MyRange.Collapse Direction:=wdCollapseEnd
' Eine Word-Tabelle erstellen
Set table = ActiveDocument.Tables.Add(Range:=MyRange, numRows:=numRows + 1, numColumns:=numColumns) ' +1 für Tabellenkopf
' currentParagraph.InsertAfter table & vbCrLf
' Tabellenkopf ausfüllen
cellContent = Split(lines(startIndex), "|")
For j = 1 To UBound(cellContent) - 1 ' Das erste | ignorieren, beginnend bei 1
On Error Resume Next ' Parameterfehler ignorieren.
table.Cell(1, j).Range.text = Trim(cellContent(j)) ' Die Tabellenüberschrift ausfüllen
On Error GoTo 0 ' Ignorieren von Fehlern ausschalten.
Weiter j
' Die Tabelle mit Daten füllen
For i = startIndex + 2 To UBound(lines) ' Aus Datenzeilen auffüllen
cellContent = Split(lines(i), "|")
For j = 1 To UBound(cellContent) - 1 ' Bei 1 beginnen und das erste | ignorieren
On Error Resume Next ' Parameterfehler ignorieren.
table.Cell(i - startIndex, j).Range.text = Trim(cellContent(j)) ' Mit Daten füllen
On Error GoTo 0 ' Ignorieren von Fehlern ausschalten.
Nächste j
Nächste i
On Error Resume Next
' Tabellenränder auf 1 setzen
With table.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideLineWidth = 1
.OutsideLineWidth = 1
Ende mit
End Sub
