VBA文本框复制字体样式

Question

我有以下代码

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

它的工作原理是创建一个带有项目符号的文本框，并且只包含具有范围"表"数据的字段

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

我如何让它也模仿格式？

谢谢。

Answer 1

您可以参考以下代码或链接了解更多格式：

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

我还注意到你会在线路上出错CCD_ 1。

你还没有给r赋值，你可能已经意识到了这一点，并且知道如何修复它。

Answer 2

实现这一点的一种方法是保存文本框内的位置，其中包含来自粗体/斜体单元格的内容。然后，根据这些单元格的长度，您可以在完成对文本框的写入后将格式应用于文本框中的字符

我建议使用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, 1), 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, 1), ItalicList(i, 2)).Font.Italic = True
End If
Next i