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

您可以参考以下代码或使用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分配值，您可能已经意识到这一点，并且知道如何解决它。

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

VBA文本框复制字体样式

2 个答案: