Question

我正在编写PowerPoint VBA宏，以将行开头的键入的项目符号字符（例如，作为段落文本的一部分键入的“·”）更改为项目符号列表（即，作为段落格式的一部分的项目符号）。我希望列表中的项目符号看起来像是作为键入字符的项目符号一样，这意味着我需要将TextRange2.Characters(1).Font内部的所有格式化信息（作为键入文本的项目符号字符复制到新的TextRange2.ParagraphFormat.Bullet.Font中）项目符号作为段落格式的功能。有没有一种快速的方法可以进行像这样的深层复制？

根据我的收集，我可能需要创建一帮助手Sub来对所有Font2属性进行深层复制。（我知道我不能只做Set TextRange2.ParagraphFormat.Bullet.Font = TextRange2.Characters(1).Font，因为TextRange2.ParagraphFormat.Bullet.Font属性是只读的。）

如果遵循这条路线，这里有一些但不是全部的帮助者Sub。

Public Sub CopyFont2(destination As Font2, source As Font2)
Public Sub CopyFillFormat(destination As FillFormat, source As FillFormat)
Public Sub CopyGlowFormat(destination As GlowFormat, source As GlowFormat)
Public Sub CopyColorFormat(destination As ColorFormat, source As ColorFormat)
Public Sub CopyLineFormat(destination As ColorFormat, source As ColorFormat)

除了CopyFont2和CopyFillFormat之外，我还没有开始编写其他任何本书，我宁愿避免编写所有这些。有没有更简单的方法可以对内置对象进行深层复制呢？还是有其他方法可以复制我丢失的字体格式？

Answer 1

这是我处理类似问题的极其暴力的方式，其中涉及到一种情况，我需要将所有格式从一种形状复制到另一种形状并使用完全相同的文本：

Sub copyAllTextFormatting(oShp As Shape, tShp As Shape)

Debug.Print "IN_copyAllTextFormatting"
On Error GoTo Errhandler

Dim tmpRange As TextRange
Dim tmpRange2 As TextRange2



Dim i As Integer
Dim j As Integer


If oShp.HasTextFrame Then
    If oShp.TextFrame.HasText Then
        Set tmpRange = tShp.TextFrame.TextRange
        Set tmpRange2 = tShp.TextFrame2.TextRange

        With oShp.TextFrame
            .MarginBottom = tShp.TextFrame.MarginBottom
            .MarginLeft = tShp.TextFrame.MarginLeft
            .MarginRight = tShp.TextFrame.MarginRight
            .MarginTop = tShp.TextFrame.MarginTop
            .Orientation = tShp.TextFrame.Orientation
            .VerticalAnchor = tShp.TextFrame.VerticalAnchor
            .WordWrap = tShp.TextFrame.WordWrap
        End With

        For j = 1 To tmpRange.Paragraphs.Count

            With oShp.TextFrame2.TextRange.Paragraphs(j).ParagraphFormat
                If tmpRange.Paragraphs(j).ParagraphFormat.Bullet = msoTrue Then
                    .Bullet.visible = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.visible
                    .Bullet.Character = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Character
                    .Bullet.Font.Name = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Font.Name
                    .Bullet.Font.Bold = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Font.Bold
                    .Bullet.Font.Size = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Font.Size
                    .Bullet.UseTextColor = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.UseTextColor
                    .Bullet.RelativeSize = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.RelativeSize
                    If tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Type = msoBulletNumbered Then
                        .Bullet.StartValue = tmpRange.Paragraphs(j).ParagraphFormat.Bullet.StartValue
                        .Bullet.Style = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Style
                        .Bullet.Type = tmpRange2.Paragraphs(j).ParagraphFormat.Bullet.Type
                    End If
                Else
                    .Bullet.visible = msoFalse
                End If

                .Alignment = tmpRange2.Paragraphs(j).ParagraphFormat.Alignment
                .BaseLineAlignment = tmpRange2.Paragraphs(j).ParagraphFormat.BaseLineAlignment
                .HangingPunctuation = tmpRange2.Paragraphs(j).ParagraphFormat.HangingPunctuation
                .TextDirection = tmpRange2.Paragraphs(j).ParagraphFormat.TextDirection
                .WordWrap = tmpRange2.Paragraphs(j).ParagraphFormat.WordWrap
                .IndentLevel = tmpRange2.Paragraphs(j).ParagraphFormat.IndentLevel
                .LineRuleAfter = tmpRange2.Paragraphs(j).ParagraphFormat.LineRuleAfter
                .LineRuleBefore = tmpRange2.Paragraphs(j).ParagraphFormat.LineRuleBefore
                .LineRuleWithin = tmpRange2.Paragraphs(j).ParagraphFormat.LineRuleWithin
                .SpaceAfter = tmpRange2.Paragraphs(j).ParagraphFormat.SpaceAfter
                .SpaceBefore = tmpRange2.Paragraphs(j).ParagraphFormat.SpaceBefore
                .SpaceWithin = tmpRange2.Paragraphs(j).ParagraphFormat.SpaceWithin
                .LeftIndent = tmpRange2.Paragraphs(j).ParagraphFormat.LeftIndent
                .FirstLineIndent = tmpRange2.Paragraphs(j).ParagraphFormat.FirstLineIndent
            End With
        Next

        For i = 1 To tmpRange.Words.Count
            With oShp.TextFrame.TextRange.Words(i)
                .Font.Name = tmpRange.Words(i).Font.Name
                .Font.Size = tmpRange.Words(i).Font.Size
                If tmpRange.Words(i).Font.Color.Type = msoColorTypeScheme Then
                    .Font.Color.ObjectThemeColor = tmpRange.Words(i).Font.Color.ObjectThemeColor
                ElseIf tmpRange.Words(i).Font.Color.Type = msoColorTypeRGB Then
                    .Font.Color.RGB = tmpRange.Words(i).Font.Color.RGB
                ElseIf tmpRange.Words(i).Font.Color.Type = msoColorTypeMixed Then
                    For j = 1 To tmpRange.Words(i).Characters.Count
                        If tmpRange.Words(i).Characters(j).Font.Color.Type = msoColorTypeScheme Then
                            .Characters(j).Font.Color.ObjectThemeColor = tmpRange.Words(i).Characters(j).Font.Color.ObjectThemeColor
                        Else
                            .Characters(j).Font.Color.RGB = tmpRange.Words(i).Characters(j).Font.Color.RGB
                        End If
                    Next
                End If
                .Font.Bold = tmpRange.Words(i).Font.Bold
                .Font.Italic = tmpRange.Words(i).Font.Italic
                .Font.Underline = tmpRange.Words(i).Font.Underline
                .Font.Subscript = tmpRange.Words(i).Font.Subscript
                .Font.Superscript = tmpRange.Words(i).Font.Superscript
            End With
        Next

    End If
End If

Exit Sub

Errhandler:
Debug.Print "Error: " & Err.Description

End Sub

有没有一种方法可以将字体格式从一个Font2复制到另一个？

1 个答案: