数学文档的录入与编辑,数学图形的绘制与调整

Sub 英文字母斜体并排除指定词()    Dim doc As Document    Dim rng As Range    Dim i As Integer    Dim arrExcludes As Variant    Set doc = ActiveDocument    ' 步骤1：将所有英文字母设为斜体    Set rng = doc.Content    With rng.Find        .ClearFormatting        .Replacement.ClearFormatting        .Text = "[A-Za-z]"        .Replacement.Text = "^&"        .Replacement.Font.Italic = True        .Forward = True        .Wrap = wdFindContinue        .Format = True        .MatchWildcards = True        .Execute Replace:=wdReplaceAll    End With    ' 步骤2：将排除的词组改回正体    arrExcludes = Array("（A）", "（B）", "（C）", "（D）", _                        "A卷", "B卷", "2B铅笔", _                        "sin", "cos", "tan", "Rt", "kg", "km", "min", "max", "cm", "》P", "kPa", "mL", "cm/s", "km/h")    For i = LBound(arrExcludes) To UBound(arrExcludes)        Set rng = doc.Content        With rng.Find            .ClearFormatting            .Replacement.ClearFormatting            .Text = arrExcludes(i)            .Replacement.Text = "^&"            .Replacement.Font.Italic = False            .Forward = True            .Wrap = wdFindContinue            .Format = True            .MatchCase = True            .Execute Replace:=wdReplaceAll        End With    Next i    MsgBox "处理完成！", vbInformationEnd Sub

Option ExplicitSub 修复几何画板字母标签()    Const TEMP_BOOKMARK As String = "GSP_TemporaryPicturePosition"    Dim doc As Document    Dim sourceInline As InlineShape    Dim canvas As Shape    Dim item As Shape    Dim finalInline As InlineShape    Dim pastedInline As InlineShape    Dim originalPosition As Range    Dim returnRange As Range    Dim pastedRange As Range    Dim cursorPosition As Range    Dim targetWidth As Single    Dim oldWidth As Single    Dim labelWidthCm As Double    Dim txt As String    Dim warningMessage As String    Dim errorMessage As String    Dim anchorStart As Long    Dim pasteStart As Long    Dim labelCount As Long    Dim i As Long    Dim originalVerticalScroll As Long    Dim originalHorizontalScroll As Long    Dim scrollSaved As Boolean    Dim originalScreenUpdating As Boolean    Dim originalDisplayAlerts As WdAlertLevel    Dim displayAlertsSaved As Boolean    On Error GoTo ErrorHandler    Set doc = ActiveDocument    '只允许选中一幅嵌入型图片    If Selection.InlineShapes.count <> 1 Then        MsgBox "请先单独选中一幅从几何画板粘贴到 Word 的原始图片。", _               vbInformation        Exit Sub    End If    Set sourceInline = Selection.InlineShapes(1)    '保存运行前的界面状态    originalScreenUpdating = Application.ScreenUpdating    originalDisplayAlerts = Application.DisplayAlerts    displayAlertsSaved = True    originalVerticalScroll = ActiveWindow.VerticalPercentScrolled    originalHorizontalScroll = ActiveWindow.HorizontalPercentScrolled    scrollSaved = True    Application.ScreenUpdating = False    '记录图片原来的文字位置    Set originalPosition = sourceInline.Range.Duplicate    originalPosition.Collapse wdCollapseStart    anchorStart = sourceInline.Range.Start    '删除上次异常退出时可能留下的临时书签    If doc.Bookmarks.Exists(TEMP_BOOKMARK) Then        doc.Bookmarks(TEMP_BOOKMARK).Delete    End If    doc.Bookmarks.Add Name:=TEMP_BOOKMARK, _                      Range:=originalPosition    '嵌入型图片转为浮动图片，然后取消组合。    '暂时关闭 Word 提示，由 Word 自动采用默认的“是”。    sourceInline.ConvertToShape.Select    Application.DisplayAlerts = wdAlertsNone    Application.CommandBars.ExecuteMso "ObjectsUngroup"    DoEvents    Application.DisplayAlerts = originalDisplayAlerts    displayAlertsSaved = False    '寻找取消组合后生成的绘图画布    Set canvas = FindDrawingCanvas(doc, anchorStart)    If canvas Is Nothing Then        warningMessage = _            "已经执行取消组合，但没有找到 Word 生成的绘图画布。" & _            vbCrLf & vbCrLf & _            "Word 可能没有完成图片转换，请撤销本次操作后重试。"        GoTo Finish    End If    '处理画布内部的字母及带撇字母标签    For i = 1 To canvas.CanvasItems.count        Set item = canvas.CanvasItems(i)        txt = GetCanvasItemText(item)        labelWidthCm = GetLabelWidthCm(txt)        If labelWidthCm > 0 Then            oldWidth = item.Width            targetWidth = CentimetersToPoints(labelWidthCm)            item.LockAspectRatio = msoFalse            '不同版本的 Word 可能分别使用 TextFrame 或 TextFrame2            On Error Resume Next            With item.TextFrame                .WordWrap = True                .MarginLeft = 0                .MarginRight = 0                .MarginTop = 0                .MarginBottom = 0                .TextRange.ParagraphFormat.Alignment = _                    wdAlignParagraphCenter            End With            With item.TextFrame2                .WordWrap = msoTrue                .MarginLeft = 0                .MarginRight = 0                .MarginTop = 0                .MarginBottom = 0                .TextRange.ParagraphFormat.Alignment = _                    msoAlignCenter            End With            On Error GoTo ErrorHandler            '必须先打开文字换行，再设置宽度            item.Width = targetWidth            '宽度变化后保持标签中心不动            item.IncrementLeft (oldWidth - item.Width) / 2            labelCount = labelCount + 1        End If    Next i    '画布转换回嵌入型    Set finalInline = canvas.ConvertToInlineShape    '剪切处理后的图片    finalInline.Range.Cut    '剪切完成后重新读取书签，Word 会自动修正位置变化    Set returnRange = doc.Bookmarks(TEMP_BOOKMARK).Range.Duplicate    returnRange.Collapse wdCollapseStart    '记录准确的粘贴起点    pasteStart = returnRange.Start    '粘贴回原来的位置    returnRange.Paste    'Range.Paste 后，returnRange 不一定自动扩展。    '嵌入型图片在 Word 中占一个字符，因此从粘贴点向后    '读取一个字符，即可准确取得刚粘贴的图片。    Set pastedRange = doc.Range( _        Start:=pasteStart, _        End:=pasteStart + 1)    If pastedRange.InlineShapes.count > 0 Then        Set pastedInline = pastedRange.InlineShapes(1)        '将光标放在图片后面        Set cursorPosition = pastedInline.Range.Duplicate        cursorPosition.Collapse wdCollapseEnd    Else        '极少数 Word 版本不能立即返回 InlineShapes，        '图片仍已正常粘贴，直接把光标放到其后即可。        Set cursorPosition = doc.Range( _            Start:=pasteStart + 1, _            End:=pasteStart + 1)    End If    If labelCount = 0 Then        warningMessage = "已经找到绘图画布，但没有识别到字母标签。"    End IfFinish:    '无论成功、未找到画布还是发生错误，都恢复界面状态    On Error Resume Next    If Not doc Is Nothing Then        If doc.Bookmarks.Exists(TEMP_BOOKMARK) Then            doc.Bookmarks(TEMP_BOOKMARK).Delete        End If    End If    If Not cursorPosition Is Nothing Then        cursorPosition.Select    End If    If displayAlertsSaved Then        Application.DisplayAlerts = originalDisplayAlerts    End If    Application.ScreenUpdating = originalScreenUpdating    DoEvents    If scrollSaved Then        ActiveWindow.VerticalPercentScrolled = originalVerticalScroll        ActiveWindow.HorizontalPercentScrolled = originalHorizontalScroll    End If    On Error GoTo 0    If Len(errorMessage) > 0 Then        MsgBox "宏运行时出现错误：" & vbCrLf & vbCrLf & _               errorMessage, vbExclamation    ElseIf Len(warningMessage) > 0 Then        MsgBox warningMessage, vbExclamation    End If    Exit SubErrorHandler:    errorMessage = Err.Number & "：" & Err.Description    Resume FinishEnd SubPrivate Function FindDrawingCanvas( _    ByVal doc As Document, _    ByVal originalAnchorStart As Long) As Shape    Dim shp As Shape    Dim parentShape As Shape    Dim i As Long    Dim currentDistance As Long    Dim nearestDistance As Long    nearestDistance = 2147483647    On Error Resume Next    '优先从当前选区查找画布    If Selection.ShapeRange.count > 0 Then        For i = 1 To Selection.ShapeRange.count            Set shp = Nothing            Set shp = Selection.ShapeRange(i)            If Not shp Is Nothing Then                If shp.Type = msoCanvas Then                    Set FindDrawingCanvas = shp                    Exit Function                End If                Set parentShape = Nothing                Set parentShape = shp.ParentGroup                If Not parentShape Is Nothing Then                    If parentShape.Type = msoCanvas Then                        Set FindDrawingCanvas = parentShape                        Exit Function                    End If                End If            End If        Next i    End If    '选区中未找到时，查找距离原图片位置最近的画布    For Each shp In doc.Shapes        If shp.Type = msoCanvas Then            currentDistance = Abs(shp.Anchor.Start - originalAnchorStart)            If currentDistance < nearestDistance Then                nearestDistance = currentDistance                Set FindDrawingCanvas = shp            End If        End If    Next shp    On Error GoTo 0End FunctionPrivate Function GetCanvasItemText( _    ByVal item As Shape) As String    Dim s As String    On Error Resume Next    s = item.TextFrame.TextRange.Text    If Len(CleanLabelText(s)) = 0 Then        s = item.TextFrame2.TextRange.Text    End If    On Error GoTo 0    GetCanvasItemText = CleanLabelText(s)End FunctionPrivate Function CleanLabelText( _    ByVal s As String) As String    s = Replace(s, Chr(13), "")    s = Replace(s, Chr(7), "")    s = Replace(s, vbCr, "")    s = Replace(s, vbLf, "")    s = Replace(s, ChrW(160), "")    '把不同形式的撇号统一为英文直撇号    s = Replace(s, ChrW(&H2018), "'")    s = Replace(s, ChrW(&H2019), "'")    s = Replace(s, ChrW(&H2032), "'")    s = Replace(s, ChrW(&H2B9), "'")    s = Replace(s, ChrW(&HFF07), "'")    s = Trim$(s)    CleanLabelText = sEnd FunctionPrivate Function GetLabelWidthCm( _    ByVal s As String) As Double    Dim firstLetter As String    Dim hasPrime As Boolean    '允许 A、m 等单字母标签，    '也允许 A'、m' 等带一个撇号的标签。    If Len(s) = 1 Then        If Not s Like "[A-Za-z]" Then Exit Function        firstLetter = UCase$(s)        hasPrime = False    ElseIf Len(s) = 2 Then        If Not Left$(s, 1) Like "[A-Za-z]" Then Exit Function        If Right$(s, 1) <> "'" Then Exit Function        firstLetter = UCase$(Left$(s, 1))        hasPrime = True    Else        Exit Function    End If    If firstLetter = "M" Then        If hasPrime Then            GetLabelWidthCm = 0.55        Else            GetLabelWidthCm = 0.5        End If    Else        If hasPrime Then            GetLabelWidthCm = 0.45        Else            GetLabelWidthCm = 0.4        End If    End IfEnd Function