有没有办法将字体格式从一个 Font2 复制到另一个？

Question

我正在编写一个 PowerPoint VBA 宏来将在行首输入的项目符号字符（例如作为段落文本的一部分输入的“・”）更改为项目符号列表（即项目符号作为段落格式的一部分） .我希望列表中的项目符号看起来与作为键入字符的项目符号完全一样，这意味着我需要将 TextRange2.Characters(1).Font 中的所有格式信息复制到 TextRange2.ParagraphFormat.Bullet.Font 中，将项目符号字符作为键入文本复制到 TextRange2.ParagraphFormat.Bullet.Font 以获取新项目符号作为功能的段落格式。有没有一种快速的方法来做这样的深拷贝？

据我所知，我可能需要创建一堆助手 Subs 来深度复制所有 Font2 属性。 （我知道我不能只做Set TextRange2.ParagraphFormat.Bullet.Font = TextRange2.Characters(1).Font，因为TextRange2.ParagraphFormat.Bullet.Font 属性是只读的。）

这里有一些但不是全部的帮助者Subs，如果我遵循这条路线，我将需要。

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