Excel使用Unicode绘制树形网络消除字符间隙的技术求助

问题描述 #

通过VBA调用Unicode框形字符在Excel单元格中绘制树形网络，功能可正常运行，但字符间始终存在明显间隙。尝试过以下方案均无法彻底解决：

• 调整字号至16号，手动缩小自动增大的行高
• 横向合并单元格、合并大单元格
• 插入TextBox承载字符
  打印时间隙问题仍然存在。

原测试代码及操作说明：

1. 在单元格输入=ExampleBoxes(1)
2. 使用参数1、0、2查看不同效果
3. 将代码放入模块即可生成对应图形

Option Explicit

Function ExampleBoxes(arg As Integer) As String()
        Dim tst(1 To 5, 1 To 5)  As String ' Multiple Rows and Columns
        Dim tstbc(0 To 3, 0 To 3)  As String ' Multiple Rows and Columns
        Dim tstbc2(0 To 3, 0 To 3)  As String ' Multiple Rows and Columns
        Dim rc(1 To 5, 1 To 5)  As String ' Multiple Rows and Columns
        Dim rc0(1 To 5, 0) As String ' Multiple Rows
        Dim r0c0(0) As String ' One big cell merged over rows
        
        rc(1, 1) = GetBoxChar(1, 1)
        rc(1, 2) = GetBoxChar(1, 2)
        rc(1, 3) = GetBoxChar(1, 3)
        rc(1, 4) = GetBoxChar(0, 1)
        'rc(1, 5) = GetBoxChar(1, 3)
        
        rc(2, 1) = GetBoxChar(2, 1)
        rc(2, 2) = GetBoxChar(2, 2)
        rc(2, 3) = GetBoxChar(2, 3)
        rc(2, 4) = GetBoxChar(0, 1)
        'rc(2, 5) = GetBoxChar(1, 3)
        
        rc(3, 1) = GetBoxChar(3, 1)
        rc(3, 2) = GetBoxChar(3, 2)
        rc(3, 3) = GetBoxChar(3, 3)
        rc(3, 4) = GetBoxChar(0, 1)
        'rc(3, 5) = GetBoxChar(1, 3)
        
        rc(4, 1) = GetBoxChar(2, 1)
        rc(4, 2) = GetBoxChar(0, 2)
        rc(4, 3) = GetBoxChar(0, 2)
        rc(4, 4) = GetBoxChar(3, 3)
        'rc(4, 5) = GetBoxChar(1, 3)
        
        rc(5, 1) = GetBoxChar(3, 2)
        'rc(5, 2) = GetBoxChar(1, 3)
        'rc(5, 3) = GetBoxChar(1, 3)
        'rc(5, 4) = GetBoxChar(1, 3)
        'rc(5, 5) = GetBoxChar(1, 3)
        Dim clno As Integer, rwno As Integer
        For clno = 0 To 3
            For rwno = 0 To 3
                tstbc(clno, rwno) = GetBoxChar(clno, rwno)
                tstbc2(clno, rwno) = clno & "-" & rwno
            Next
        Next
    
        For clno = 1 To 5
            For rwno = 1 To 5
                If rc(rwno, clno) = "" Then rc(rwno, clno) = " "  ' To put the spaces in if we copy into notepad
                rc0(rwno, 0) = rc0(rwno, 0) & rc(rwno, clno) ' concatenate the columns into one line
                r0c0(0) = r0c0(0) & rc(clno, rwno) ' concatenate the columns into one line and rows into one cell
                tst(rwno, clno) = rwno & "-" & clno
            Next
            r0c0(0) = r0c0(0) & vbLf
        Next
    ' change totest each tyoe
    Select Case arg
        Case 0
        ExampleBoxes = rc
        Case 1
        ExampleBoxes = rc0
        Case 2
        ExampleBoxes = r0c0
        Case 3
        ExampleBoxes = tst
        Case 4
        ExampleBoxes = tstbc
        Case 5
        ExampleBoxes = tstbc2
    End Select
        'doboxes = strrc
        'doboxes = rc2
    End Function
    
    Function GetBoxChar(i As Integer, J As Integer) As String
        
        Dim boxChars(3, 3) As Long
        boxChars(0, 1) = 9474 'UD
        boxChars(0, 2) = &H2500 'LR
        
        boxChars(1, 1) = 9484 'TL
        boxChars(1, 2) = 9516 'TM
        boxChars(1, 3) = &H2510 'TR
    
        boxChars(2, 1) = 9500 'ML
        boxChars(2, 2) = 9532 'MM
        boxChars(2, 3) = 9508 'BL
    
        boxChars(3, 1) = 9492 'BL
        boxChars(3, 2) = 9524 'BM
        boxChars(3, 3) = &H2518 'BR
        GetBoxChar = ChrW(boxChars(i, J))
    End Function

问题根源 #

1. 字体非等宽：默认字体（如Calibri）为比例字体，不同字符宽度不一致，导致拼接时出现间隙
2. 单元格内边距：Excel单元格默认存在内边距，即使合并单元格也无法完全消除
3. Unicode字符排版：部分框形字符的设计存在微小空白区域，普通排版无法完全贴合

解决方案 #

方案1：优化单元格与字体设置（最小改动） #

1. 切换等宽字体：将目标单元格区域的字体设置为Consolas或Courier New，确保每个字符宽度一致
2. 清除单元格内边距：
   • 右键单元格→设置单元格格式→对齐→将“缩进”设为0，取消“自动换行”
   • 或用VBA批量设置：

     Sub SetCellFormat()
         With Range("A1:E5") ' 替换为你的目标区域
             .Font.Name = "Consolas"
             .Font.Size = 12
             .HorizontalAlignment = xlLeft
             .VerticalAlignment = xlTop
             .IndentLevel = 0
             .ColumnWidth = 1.2 ' 匹配等宽字符宽度
             .RowHeight = 14 ' 匹配字号高度
         End With
     End Sub
     

3. 禁用网格线：视图→取消勾选“网格线”，避免网格线与字符间隙混淆

方案2：改进TextBox实现（彻底消除间隙） #

原TextBox方案未彻底消除间隙，需优化格式设置：

Sub DrawTreeWithTextBox()
    Dim treeStr As String
    Dim tb As Shape
    
    ' 生成完整树形字符串（用ExampleBoxes(2)的结果）
    treeStr = ExampleBoxes(2)(0)
    
    ' 删除原有TextBox（可选）
    For Each tb In ActiveSheet.Shapes
        If tb.Type = msoTextBox Then tb.Delete
    Next
    
    ' 创建新TextBox
    Set tb = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 100, 80)
    With tb.TextFrame2
        .TextRange.Text = treeStr
        .VerticalAnchor = msoAnchorTop
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
        .WordWrap = msoFalse
    End With
    With tb.TextFrame2.TextRange.Font
        .Name = "Consolas"
        .Size = 12
        .Spacing = 0 ' 字符间距设为0
    End With
    tb.Line.Visible = msoFalse ' 隐藏TextBox边框
End Sub

方案3：用Shape绘制树形网络（无字符间隙） #

完全避开Unicode字符的排版问题，直接用形状绘制线条和矩形：

Sub DrawTreeWithShapes()
    Dim shp As Shape
    
    ' 绘制矩形节点
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 20, 20, 60, 20)
    shp.TextFrame2.TextRange.Text = "节点1"
    shp.Line.Weight = 1
    
    ' 绘制连接线
    Set shp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 50, 40, 50, 60)
    shp.Line.Weight = 1
    
    ' 绘制子节点
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 20, 60, 60, 20)
    shp.TextFrame2.TextRange.Text = "节点2"
    shp.Line.Weight = 1
End Sub

操作验证 #

1. 执行方案1的SetCellFormat宏后，重新输入=ExampleBoxes(1)，字符间隙会大幅减小
2. 方案2生成的TextBox中的树形网络无明显间隙，打印时也不会出现
3. 方案3的形状绘制完全无间隙，适合需要高精度的场景

内容的提问来源于stack exchange，提问作者Ross