VBA文本框复制字体样式

如何解决VBA文本框复制字体样式

我有以下代码

Dim TB As TextBox
Dim mycell As Range
ThisWorkbook.Worksheets("Print").Activate
Cells(r,1).Select
Dim mytext As String
Set mycell = ActiveCell
With mycell
    Set TB = .Parent.TextBoxes.Add(top:=.top,Left:=.Left,Width:=Range(Cells(r,1),Cells(r,9)).Width,Height:=42)
    TB.Name = "TB"
    TB.Font.Size = 10
    TB.Font.Name = "Tahoma"
End With
TB.ShapeRange.Line.Visible = msoFalse
Dim c As Range
Dim i As Integer
i = 0
For Each c In table.Rows
    If Not IsEmpty(c.Value) Then
        i = i + 1
        If i < [Circumstances_Count] Then
            TB.text = mytext & Chr(149) & " " & c.Value & vbNewLine
        Else
            TB.text = mytext & Chr(149) & " " & c.Value
        End If
        mytext = TB.text
    End If
Next c

它可以按预期方式创建带有项目符号点的文本框，并且仅包含带有“表”范围数据的字段

问题在于它没有粗体字或斜体等文本格式。

我如何也模仿格式？

谢谢。

解决方法

您可以参考以下代码或使用Link获取更多格式：

With mycell
    Set TB = .Parent.TextBoxes.Add(Top:=.Top,Left:=.Left,Width:=Range(Cells(r,1),Cells(r,9)).Width,Height:=42)
    TB.Name = "TB"
    TB.Font.Size = 10
    TB.Font.Name = "Tahoma"
    TB.Characters.Text = "test"
    TB.Characters.Font.Bold = True
    TB.Characters.Font.Italic = True
End With

我也注意到您会在网上遇到错误 Cells (r,1) .Select。

您尚未为r分配值，您可能已经意识到这一点，并且知道如何解决它。

,

执行此操作的一种方法是将文本框中的位置保存在其中来自粗体/斜体单元格的内容中。然后，根据这些单元格的长度，可以在写完文本框后将格式应用于文本框内的字符。

我建议使用2个数组来存储有关位置和需要格式化的文本长度的信息。

例如，您可以尝试以下方法：

Dim BoldList() As Variant
ReDim BoldList(1 To Table.Rows.Count,1 To 2)

Dim ItalicList() As Variant
ReDim ItalicList(1 To Table.Rows.Count,1 To 2)

Dim c As Range
Dim i As Integer
i = 0
For Each c In Table.Rows
    If Not IsEmpty(c.Value) Then
        i = i + 1
        
        If c.Font.Bold Then
            BoldList(i,1) = Len(mytext) + 3
            BoldList(i,2) = Len(c.Value)
        End If
        
        If c.Font.Italic Then
            ItalicList(i,1) = Len(mytext) + 3
            ItalicList(i,2) = Len(c.Value)
        End If
        
        If i < [Circumstances_Count] Then
            TB.Text = mytext & chr(149) & " " & c.Value & vbNewLine
            BoldList(i,2) = BoldList(i,2) + 1
            ItalicList(i,2) = ItalicList(i,2) + 1
        Else
            TB.Text = mytext & chr(149) & " " & c.Value
        End If
        mytext = TB.Text
    End If
Next c

'Apply the formatting
For i = 1 To UBound(BoldList)
    If Not IsEmpty(BoldList(i,1)) Then
        TB.Characters(BoldList(i,BoldList(i,2)).Font.Bold = True
    End If
Next i

For i = 1 To UBound(ItalicList)
    If Not IsEmpty(ItalicList(i,1)) Then
        TB.Characters(ItalicList(i,ItalicList(i,2)).Font.Italic = True
    End If
Next i