批量修改word文本框等自选图形格式

cuanju

word中的文本框等自选图形对象，一般包括三部分：画布（里面有文本框、连接符等图形）、组合图形（里面有文本框、连接符等图形）及非画布和非组合图形。画布和组合图形的好处是可以作为盛放多个文本框等的“容器”，方便作为一个整体复制到新的文档中。

统计图形个数时，1个画布或1个组合图形都反馈只有1个shape图形而不统计下属的子图形个数，下属的子图形分别用CanvasItems集合和GroupItems集合表示。

以下是一个通用的操作画布、组合图形和非画布和非组合图形代码，可以根据实际情况修改。
=========================================================================================


Sub d1()
    Rem 批量修改word文本框等自选图形格式
    Application.ScreenUpdating = False
    On Error Resume Next
    Dim arr()
    k = 0
    For Each oShp In ActiveDocument.Shapes
        ReDim Preserve arr(k)
        arr(k) = oShp.Name
        k = k + 1
    Next
    For j = 0 To UBound(arr)
        sName = arr(j)
        Set oShp = ActiveDocument.Shapes(sName)
        '=====================================
        If oShp.Type = msoCanvas Then '操作画布（如果画布内还有组合图形，则把该组合图形作为画布内的一个整体作处理）
            For i = 1 To oShp.CanvasItems.Count
                If oShp.CanvasItems(i).Type = msoLine Or oShp.CanvasItems(i).Name Like "*Connector*" Or oShp.CanvasItems(i).Name Like "*Freeform*" Then '排除各种连接符、直线等 （如果对直线起作用，如设置直线的颜色等，需修改代码）
                Else
                    Debug.Print oShp.CanvasItems(i).Name
                    With oShp.CanvasItems(i).TextFrame.TextRange
                        '.Text = "1"
                        '.Font.Name = "宋体"
                        .Font.Color = vbBlack
                        '.Font.Size = 8
                        '.ListFormat.ConvertNumbersToText '转手动编号
                        '.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
                        '.ParagraphFormat.DisableLineHeightGrid = -1 '取消对齐到文档网格
                        With .ParagraphFormat
                            '.CharacterUnitFirstLineIndent = 0
                            '.FirstLineIndent = 0
                            '.CharacterUnitLeftIndent = 0
                            '.LeftIndent = 0
                            '.CharacterUnitRightIndent = 0
                            '.RightIndent = 0
                            '.Alignment = wdAlignParagraphCenter
                        End With
                    End With
                    With oShp.CanvasItems(i).TextFrame
                        '.MarginTop = CentimetersToPoints(0)
                        '.MarginBottom = CentimetersToPoints(0)
                        '.MarginLeft = CentimetersToPoints(0)
                        '.MarginRight = CentimetersToPoints(0)
                        .VerticalAnchor = msoAnchorMiddle '文本框内文本垂直中部对齐
                    End With
                    'oShp.CanvasItems(i).Fill.ForeColor = vbYellow '文本框底纹
                    oShp.CanvasItems(i).Fill.Visible = False '文本框无底纹颜色
                    oShp.CanvasItems(i).Line.ForeColor = vbBlack '文本框轮廓颜色、连接符颜色
                    oShp.CanvasItems(i).Line.Weight = 0.5 '文本框轮廓粗细、连接符粗细
                    'oShp.CanvasItems(i).Height = CentimetersToPoints(1.1) '文本框高度
                    'oShp.CanvasItems(i).Width = CentimetersToPoints(2.5) '文本框宽度
                End If
            Next
        End If
        '=====================================
        If oShp.Type = msoGroup Then '操作组合图形（也适用于组合图形下的子组合图形）
            For i = 1 To oShp.GroupItems.Count
                If oShp.GroupItems(i).Type = msoLine Or oShp.GroupItems(i).Name Like "*Connector*" Or oShp.GroupItems(i).Name Like "*Freeform*" Then '排除各种连接符、直线等 （如果对直线起作用，如设置直线的颜色等，需修改代码）
                Else
                    With oShp.GroupItems(i).TextFrame.TextRange
                        '.Text = "1"
                        '.Font.Name = "宋体"
                        .Font.Color = vbBlack
                        '.Font.Size = 8
                        '.ListFormat.ConvertNumbersToText '转手动编号
                        '.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
                        '.ParagraphFormat.DisableLineHeightGrid = -1 '取消对齐到文档网格
                        With .ParagraphFormat
                            '.CharacterUnitFirstLineIndent = 0
                            '.FirstLineIndent = 0
                            '.CharacterUnitLeftIndent = 0
                            '.LeftIndent = 0
                            '.CharacterUnitRightIndent = 0
                            '.RightIndent = 0
                            '.Alignment = wdAlignParagraphCenter
                        End With
                    End With
                    With oShp.GroupItems(i).TextFrame
                        '.MarginTop = CentimetersToPoints(0)
                        '.MarginBottom = CentimetersToPoints(0)
                        '.MarginLeft = CentimetersToPoints(0)
                        '.MarginRight = CentimetersToPoints(0)
                        .VerticalAnchor = msoAnchorMiddle '文本框内文本垂直中部对齐
                    End With
                    'oShp.GroupItems(i).Fill.ForeColor = vbYellow '文本框底纹
                    oShp.GroupItems(i).Fill.Visible = False '文本框无底纹颜色
                    oShp.GroupItems(i).Line.ForeColor = vbBlack '文本框轮廓颜色、连接符颜色
                    oShp.GroupItems(i).Line.Weight = 0.5 '文本框轮廓粗细、连接符粗细
                    'oShp.GroupItems(i).Height = CentimetersToPoints(1.1) '文本框高度
                    'oShp.GroupItems(i).Width = CentimetersToPoints(2.5) '文本框宽度
                End If
            Next
        End If
        '=====================================
        Rem 注意个别情况下会对图片或其他图形对象误操作
        If Not oShp.Type = msoGroup And Not oShp.Type = msoCanvas Then '操作非画布和非组合图形
            If oShp.Type = msoLine Or oShp.Name Like "*Connector*" Or oShp.Name Like "*Freeform*" Then '排除各种连接符、直线等（如果对直线起作用，如设置直线的颜色等，需修改代码）
            Else
                'If oShp.GroupItems.Count = 0 And oShp.CanvasItems.Count = 0 Then
                With oShp.TextFrame.TextRange
                    '.Text = "1"
                    '.Font.Name = "宋体"
                    .Font.Color = vbBlack
                    '.Font.Size = 8
                    '.ListFormat.ConvertNumbersToText '转手动编号
                    '.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
                    '.ParagraphFormat.DisableLineHeightGrid = -1 '取消对齐到文档网格
                    With .ParagraphFormat
                        '.CharacterUnitFirstLineIndent = 0
                        '.FirstLineIndent = 0
                        '.CharacterUnitLeftIndent = 0
                        '.LeftIndent = 0
                        '.CharacterUnitRightIndent = 0
                        '.RightIndent = 0
                        '.Alignment = wdAlignParagraphCenter
                    End With
                End With
                With oShp.TextFrame
                    '.MarginTop = CentimetersToPoints(0)
                    '.MarginBottom = CentimetersToPoints(0)
                    '.MarginLeft = CentimetersToPoints(0)
                    '.MarginRight = CentimetersToPoints(0)
                    .VerticalAnchor = msoAnchorMiddle '文本框内文本垂直中部对齐
                End With
                'oShp.Fill.ForeColor = vbYellow '文本框底纹
                oShp.Fill.Visible = False '文本框无底纹颜色
                oShp.Line.ForeColor = vbBlack '文本框轮廓颜色、连接符颜色
                oShp.Line.Weight = 0.5 '文本框轮廓粗细、连接符粗细
                'oShp.WrapFormat.AllowOverlap = False '禁止重叠
                'oShp.Height = CentimetersToPoints(1.1) '文本框高度
                'oShp.Width = CentimetersToPoints(2.5) '文本框宽度
                'End If
            End If
        End If
    Next
    '=====================================
    Application.ScreenUpdating = True
End Sub

cuanju

这是一个删除文本框内回车符的示例代码，也可以改成其他的替换方式。

===================================
Sub d5()
Rem word文本框内文字查找替换
    Application.ScreenUpdating = False
    On Error Resume Next
    '也可用于其他矩形等其他含文字图形的替换
    Dim arr()
    k = 0
    For Each oShp In ActiveDocument.Shapes
        ReDim Preserve arr(k)
        arr(k) = oShp.Name
        k = k + 1
    Next
   
    For j = 0 To UBound(arr)
        sName = arr(j)
        Set oShp = ActiveDocument.Shapes(sName)
        Rem 操作画布
        If oShp.Type = msoCanvas Then
            For n = 1 To oShp.CanvasItems.Count
                oShp.CanvasItems(n).TextFrame.TextRange.Find.Execute findtext:="^13", replacewith:="", Replace:=wdReplaceAll, MatchWildcards:=True
            Next
        End If
        Rem 操作组合图形
        If oShp.Type = msoGroup Then
            For n = 1 To oShp.GroupItems.Count
                oShp.GroupItems(n).TextFrame.TextRange.Find.Execute findtext:="^13", replacewith:="", Replace:=wdReplaceAll, MatchWildcards:=True
            Next
        End If
        Rem 操作非画布和非组合图形
        If Not oShp.Type = msoGroup And Not oShp.Type = msoCanvas Then
                oShp.TextFrame.TextRange.Find.Execute findtext:="^13", replacewith:="", Replace:=wdReplaceAll, MatchWildcards:=True
        End If
    Next
    Application.ScreenUpdating = True
End Sub

xseyuan

怎么判断任意多边形内是否含有文字，
If oShp.GroupItems(i).Type = msoFreeform Then '任意多边形是否含有文字
                       If oShp.GroupItems(i).TextFrame.TextRange = "" Then
                      oShp.GroupItems(i).Fill.Visible = False '不显示底纹颜色
                       Else
                       oShp.GroupItems(i).Fill.ForeColor = RGB(100, 100, 100) '文本框底纹
                       oShp.GroupItems(i).Fill.Visible = True '显示底纹颜色
                       oShp.GroupItems(i).TextFrame.TextRange.Style = ActiveDocument.Styles("五中") '字体样式
                      End If
                    End If