Excel VBA 将文本框（文本和格式）复制到另一个文本框（无 ActiveX / 用户表单）

Posted 2023-03-29

【中文标题】Excel VBA 将文本框（文本和格式）复制到另一个文本框（无 ActiveX / 用户表单）

【英文标题】：Excel VBA copy Text Box (Text and Format) to another Text Box (no ActiveX / User Forms)

【发布时间】：2021-07-07 17:34:57

【问题描述】：

我正在尝试将内容（文本和格式）从一个工作表上的文本框中复制到同一工作簿中另一张工作表上的另一个文本框中。我已经能够成功复制几乎所有内容，但理由（中心/左/右）不适用于每一行。我以一种非常笨拙的方式执行此操作：复制文本，然后遍历每个字符以获取格式集。在 excel vba 中似乎没有一种简单的方法可以复制文本和所有格式。本质上，我正在尝试在原始文本框上执行“全选（Cntrl-A）”，“复制（Cnrl-C）”，然后在目标文本框上执行“特殊粘贴（保留源格式）”。 IT 使用鼠标可以很好地工作，但我不想那样做。我只想运行一个宏来做同样的事情。另外，我注意到当宏运行时，目标文本框对文本应用全局对齐，我不再能够单独选择一行并设置其对齐方式（即所有行居中或所有行左对齐 vs . 能够单独调整每条线）。同样，这种奇怪的行为只发生在宏运行之后。如果我使用鼠标剪切和粘贴方法，文本可以再次逐行对齐。这是我的笨拙代码：

Sub Update_CARD_LEG_BACK()
    ' Set varibles to reduce typing and make changing origin and destination text boxes easier.
    Set Orig = Sheets("MAIN_INPUT2").Shapes("CARD_LEG_BACK")
    Set Orig_Sheet = Sheets("MAIN_INPUT2")
    Set Dest = Sheets("CARD_LEGACY").Shapes("BACK")
    Set Dest_Sheet = Sheets("CARD_LEGACY")

    'Copy text from origin text box to destination text box.  Copies only the text NO formating.
    Dest.TextFrame.Characters.Text = Orig.TextFrame.Characters.Text

    For i = 1 To Len(Orig.TextFrame.Characters.Text)
        Dest.TextFrame.Characters(i, 1).Font.Underline = Orig.TextFrame.Characters(i, 1).Font.Underline
        With Dest.TextFrame2.TextRange.Characters(i, 1)
            .Text = Orig.TextFrame2.TextRange.Characters(i, 1).Text
        With .Font
            .Name = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Name
            .Size = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Size
            .Bold = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Bold
            .Strikethrough = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Strikethrough
            .Superscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Superscript
            .Subscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Subscript
            .Fill.ForeColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.ForeColor.RGB
            .Fill.BackColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.BackColor.RGB
            .Fill.Visible = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Visible
            .Fill.Transparency = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Transparency
        End With
        With .ParagraphFormat
           .BaselineAlignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.BaselineAlignment
           .SpaceWithin = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceWithin
           .SpaceBefore = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceBefore
           .SpaceAfter = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceAfter
           .IndentLevel = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.IndentLevel
           .FirstLineIndent = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.FirstLineIndent
           .Alignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.Alignment
           .HangingPunctuation = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.HangingPunctuation
         End With
       End With
    Next i

    'Copy fill color of origin text box to destination text box. Also copies transparancy (required for 'no fill' option to copy correctly).
    Dest.Fill.ForeColor.RGB = Orig.Fill.ForeColor.RGB
    Dest.Fill.Transparency = Orig.Fill.Transparency
End Sub

【问题讨论】：

您是否考虑过删除第二个文本框并将其替换为第一个文本框的副本？似乎这可能比从第一个复制这么多属性更容易......

现在试试。我只需要能够将粘贴的文本框定位在目标页面上的正确位置。

【参考方案1】：

您可以将第二个替换为第一个的副本：

Sub Tester()

    ReplaceWithCopy Sheet1.Shapes("SourceTB"), Sheet2.Shapes("DestTB")

End Sub


Sub ReplaceWithCopy(shpSrc As Shape, shpDest As Shape)
    Dim nm As String
    
    shpSrc.Copy
    shpDest.Parent.Paste
    With shpDest.Parent.Shapes(shpDest.Parent.Shapes.Count)
        .Left = shpDest.Left
        .Top = shpDest.Top
        .Width = shpDest.Width
        .Height = shpDest.Height
        nm = shpDest.Name
        shpDest.Delete   'remove the shape being replaced
        .Name = nm       'rename copy to just-deleted shape
    End With
End Sub

【讨论】：

太棒了！！正是我想要的，非常感谢！

我现在有些困难。出于某种原因，它适用于某些文本框，但对于其他文本框则不起作用。任何想法为什么？它复制 Src 文本框并删除 Dest 文本框，但不会重命名或移动新复制的文本框。看来它可能没有使用“shpDest.Parent.Shapes.Count”变量引用正确的文本框。我不明白为什么它并不总是有效。

它在测试一对文本框时对我有用。你有分组或嵌套的形状吗？当它不起作用时，您会收到任何错误消息吗？

是的，我有很多分组文本框，并且没有错误消息。一切正常，除了移动和重命名，它告诉我“Shapes(shpDest.Parent.Shapes.Count)”没有锁定正确的形状。由于我复制了形状，所以新复制的形状的名称与Src相同。我们可以只使用该名称而不是计数吗？

您可以，但也请注意，没有什么能阻止您在工作表上用相同的名称命名两个形状，这可能会在以后尝试使用形状访问其名称时出现问题。