多层表头

请先打开CaseStyudy目录下的文件"PDFCreator示例.Table"，然后选择"多层表头"这个表，再运行本节的示例代码。

本节的任务还是打印数据表，不过这次是要打印一个有多层表头的数据表，打印结果如下：

多层表头打印的思路来自合并分单元格以及合并单元格实战，首先定义两个二维数组表示多层表头：

Dim HeaderCells(, ) As String = {
{"2,1", "1,4", "0", "0", "0", "1,4", "0", "0", "0"},
{0, "1", "1", "1", "1", "1", "1", "1", "1"}
}

Dim HeaderCaptions(, ) As String = {
{"产品", "东部", "", "", "", "南部", "", "", ""},
{"", "一季度", "二季度", "三季度", "四季度", "一季度", "二季度", "三季度", "四季度"}
}

然后重写drawHeader过程， 使其支持多层表头：

Dim drawHeader =
Function(tHeaderCells(,) As String , tHeaderCaptions(,) As String, tWidths() As Integer, tRect As RectangleF)
    '代码
End Function

因为drawRow过程有调用drawHeader，所以这个过程也要稍微修改一下，加上两个表示表头的二维数组作为参数：

Dim drawRow =
Function(dr As DataRow, tFields() As String, tWidths() As Integer, tHeaderCells(,) As String , tHeaderCaptions(,) As String, tRect As RectangleF)
    tRect.Height = rowHeight '设置行高
    If tRect.Bottom > rectPage.Bottom Then '如果剩余空间不够
        pdc.NewPage() '则另起一页
        tRect.Y = rectPage.Y '定位到页首
        tRect = drawHeader.Invoke(tHeaderCells, tHeaderCaptions, tWidths, tRect) '给新增加的页面绘制表头
    End If
    '其他代码
End Function

示例

下面是完整的代码，请在命令窗口执行，同样这个代码是通用的，你可以用于打印任何有多层表头的数据表：

Dim file As String = "c:\temp\test.pdf"
Dim pdc As New PDFCreator()
pdc.PaperKind = Drawing.Printing.PaperKind.A3
Dim rectPage As RectangleF = pdc.PageRectangle
rectPage.Inflate( - 72, - 72)
Dim sf As New StringFormat
sf.LineAlignment = StringAlignment.Center '单元格内容垂直居中
Dim rowHeight As Integer = 20 '行高为20磅
Dim fontHeader As New Font("微软雅黑", 12, fontstyle.Bold) '列标题字体
Dim fontData As New Font("微软雅黑", 10) '数据单元格字体

'绘制列标题的lambda过程,支持多层表头
Dim drawHeader =
Function(tHeaderCells(,) As String , tHeaderCaptions(,) As String, tWidths() As Integer, tRect As RectangleF)
    tRect.Height = rowHeight '设置行高
    If tRect.Bottom > rectPage.Bottom Then '如果剩余空间不够
        pdc.NewPage() '则另起一页
        tRect.Y = rectPage.Y ''定位到页首
    End If
    Dim rectBorder = tRect 'rectBorder为单元格边框矩形
    sf.Alignment = StringAlignment.Center '列标题水平居中
    For r As Integer = 0 To tHeaderCells.GetLength(0) - 1 '逐行绘制
        For c As Integer = 0 To tHeaderCells.GetLength(1) - 1 '逐一绘制这行的单元格
            Dim ifo As String = tHeaderCells(r, c)
            Dim cellHeight As Double = 0 '单元格高度
            Dim cellWidth As Double = 0 '单元格宽度
            If ifo = "0" OrElse ifo = "1" Then
                cellHeight = rowHeight '
                cellWidth = tWidths(c) '
            Else '如果是合并单元格
                Dim vls() As String = tHeaderCells(r, c).Split(",")
                cellHeight = rowHeight * CInt(vls(0))
                For mc As Integer = c To c + CInt(vls(1)) - 1 '根据合并列数计算单元格宽度
                    cellWidth = cellWidth + tWidths(mc)
                Next
            End If
            If ifo <> "0" Then '绘制单元格
                rectBorder.Height = cellHeight
                rectBorder.Width = cellWidth
                pdc.DrawRectangle(pens.DarkGray, rectBorder) '绘制单元格
                If tHeaderCaptions(r, c) > "" Then
                    Dim rectContent As RectangleF = rectBorder
                    rectContent.Inflate( - 3, - 3)
                    pdc.DrawString( tHeaderCaptions(r, c) , fontHeader, color.Black, rectContent, sf)
                End If
            End If
            rectBorder.Offset(tWidths(c), 0) '右移一列
        Next
        rectBorder.Offset(0, rowHeight) '下移一行
        rectBorder.X = rectPage.X '单元格回到水平初始位置，准备绘制下一行
        tRect.Offset(0, tRect.Height) '移动到下一行位置
    Next
    Return tRect '返回rect
End Function

'绘制行的lambda过程，dr为要绘制的DataRow，tFields为列名，tWidths为列宽，tRect为改行所在的矩形局域,tHeaderCells和tHeaderCaptions两个二维数组用于表示表头
Dim drawRow =
Function(dr As DataRow, tFields() As String, tWidths() As Integer, tHeaderCells(,) As String , tHeaderCaptions(,) As String, tRect As RectangleF)
    tRect.Height = rowHeight '设置行高
    If tRect.Bottom > rectPage.Bottom Then '如果剩余空间不够
        pdc.NewPage() '则另起一页
        tRect.Y = rectPage.Y '定位到页首
        tRect = drawHeader.Invoke(tHeaderCells, tHeaderCaptions, tWidths, tRect) '给新增加的页面绘制表头
    End If
    Dim rectBorder = tRect '单元格边框矩形
    For c As Integer = 0 To tFields.Length - 1 '逐个列绘制
        rectBorder.Width = tWidths(c) '设置列宽
        pdc.DrawRectangle(pens.DarkGray, rectBorder) '绘制单元格边框
        Dim rectContent As RectangleF = rectBorder '内容矩形
        rectContent.Inflate( - 3, - 3) '单元格边距为3磅
        If dr.DataTable.DataCols(tFields(c)).IsNumeric Then '如果是数值列
            sf.Alignment = StringAlignment.Far '水平靠右对齐
        Else
            sf.Alignment = StringAlignment.Near '否则居中对齐
        End If
        pdc.DrawString(dr(tFields(c)), fontData, Color.Black, rectContent, sf) '绘制单元格内容
        rectBorder.Offset(rectBorder.Width, 0) ''将rectBorder右移到下一个单元格位置
    Next
    tRect.Offset(0, tRect.Height) '移动到下一个内容的起始位置
    Return tRect '返回rect
End Function  

'用于定义多层表头的两个二维数组
Dim HeaderCells(, ) As String = {
{"2,1", "1,4", "0", "0", "0", "1,4", "0", "0", "0"},
{0, "1", "1", "1", "1", "1", "1", "1", "1"}
}
Dim HeaderCaptions(, ) As String = {
{"产品", "东部", "", "", "", "南部", "", "", ""},
{"", "一季度", "二季度", "三季度", "四季度", "一季度", "二季度", "三季度", "四季度"}
}
Dim fields() As String = {"产品", "东部_一季度", "东部_二季度", "东部_三季度", "东部_四季度", "南部_一季度", "南部_二季度", "南部_三季度", "南部_四季度"}
Dim Widths() As Integer = {92, 72, 72, 72, 72, 72, 72, 72, 72}
Dim rect As RectangleF = rectPage 'rect将传递给所有用于绘制的lambda过程的tRect参数，相当于一个位置游标，始终都在动态变化中
rect = drawHeader.Invoke(HeaderCells, HeaderCaptions, widths, rect) '绘制列标题
For Each r As Row In Tables("多层表头").Rows '逐行绘制
    rect = drawRow.Invoke(r.DataRow, fields, widths, HeaderCells, HeaderCaptions, rect) '绘制行
Next
pdc.Save(file) '保存文件
Process.Start(file) '打开文件