AI生成的教案还在手动复制粘贴?用好这个Word占位符技巧,一键搞定!

Option Explicit' 主程序：运行这个Sub Main_FillJsonToWord()    Dim jsonPath As String    Dim jsonContent As String    Dim matchCollection As Object    Dim match As Object    Dim keyStr As String, valueStr As String    Dim regex As Object    ' 1. 选择 JSON 文件    With Application.FileDialog(msoFileDialogFilePicker)        .Title = "请选择 json 文件格式"        .Filters.Clear        .Filters.Add "JSON Files", "*.json"        .AllowMultiSelect = False        If .Show = -1 Then            jsonPath = .SelectedItems(1)        Else            Exit Sub        End If    End With    ' 2. 读取文件内容 (处理 UTF-8 中文)    jsonContent = ReadTextFileUTF8(jsonPath)    If jsonContent = "" Then        MsgBox "文件内容为空或读取失败！", vbExclamation        Exit Sub    End If    ' 3. 初始化正则表达式引擎    Set regex = CreateObject("VBScript.RegExp")    With regex        .Global = True        .IgnoreCase = True        .MultiLine = True        ' 这个正则用于匹配 "Key": "Value" 结构，支持 value 中包含转义引号        ' 注意：这是针对你提供的扁平 JSON 结构的简化匹配        .Pattern = """([^""]+)""\s*:\s*""((?:[^""\\]|\\.)*)"""    End With    ' 4. 执行匹配    If regex.test(jsonContent) Then        Set matchCollection = regex.Execute(jsonContent)        Application.ScreenUpdating = False ' 关闭屏幕更新加快速度        ' 5. 遍历每一对 Key-Value 并替换        For Each match In matchCollection            keyStr = match.SubMatches(0)   ' 获取键 (如：授课题目)            valueStr = match.SubMatches(1) ' 获取值            ' 处理 JSON 转义字符 (如 \" 变 ")            valueStr = Replace(valueStr, "\""", """")            valueStr = Replace(valueStr, "\\", "\")            ' 执行 Word 替换，自动加上 {{ }}            Call ReplaceTextInDoc("{{" & keyStr & "}}", valueStr)        Next match        Application.ScreenUpdating = True        MsgBox "数据填充完成！共处理 " & matchCollection.Count & " 个数据项。", vbInformation    Else        MsgBox "未在文件中找到有效的 JSON 格式数据。", vbExclamation    End If    ' 清理对象    Set regex = Nothing    Set matchCollection = NothingEnd Sub' 辅助函数：突破 255 字符限制的查找替换Sub ReplaceTextInDoc(FindText As String, ReplaceText As String)    Dim myRange As Range    Set myRange = ActiveDocument.Content    ' 重置查找参数    With myRange.Find        .ClearFormatting        .Replacement.ClearFormatting        .Text = FindText        .Forward = True        .Wrap = wdFindStop        .Format = False        .MatchCase = False        .MatchWholeWord = False        .MatchWildcards = False        .MatchSoundsLike = False        .MatchAllWordForms = False    End With    ' 循环查找并替换（解决长文本问题）    Do While myRange.Find.Execute        ' 将找到的 Range 文本直接替换为新文本        ' 这种方法不受 Find.Replacement.Text 的 255 字符限制        myRange.Text = ReplaceText        ' 将 Range 折叠到末尾，继续查找下一个        myRange.Collapse Direction:=wdCollapseEnd    LoopEnd Sub' 辅助函数：以 UTF-8 编码读取文本文件 (防止中文乱码)Function ReadTextFileUTF8(filePath As String) As String    Dim objStream As Object    Set objStream = CreateObject("ADODB.Stream")    With objStream        .Type = 2 ' adTypeText        .Charset = "utf-8"        .Open        .LoadFromFile filePath        ReadTextFileUTF8 = .ReadText        .Close    End With    Set objStream = NothingEnd Function