Dim PageHeader As Long '打印页上部留空 Dim PageFooter As Long '打印页下部留空 Dim PageLeft As Long '打印页左部留空 Dim PageRight As Long '打印页右部留空 Dim UseWidth As Long Dim UseHeight As Long Dim i, j, k, c, b As Integer Dim Word As String Dim StartX As Long Dim StartY As Long Dim StartyLine As Long '用来纪录打印竖线的起点 Dim EndyLine As Long ' 用来纪录打印竖线的末点 Dim strTitle As String Const w1 = 1.5, w2 = 2 '设置线与字段之间的距离 Const h = 14 '设置表格的高度 Dim v(40) As Variant '定义数组 将字段值导入 Dim N As Integer '用于记录表的列数 Dim l1, l2, m, t As Variant '设置标题 strTitle = t1 N = Adodc1.Recordset.Fields.Count ' Dim strSubTitle As String ' strSubTitle = "Printer对象打印报表实例" '建立一个ADO数据连接 ' Dim DataConn As New ADODB.Connection ' Dim DataRec As New ADODB.Recordset ' Dim strSQL As String '若数据库连接出错，则转向ConnectionERR ' On Error GoTo ConnectionERR ' '建立一个连接字串 ' '这个连接串可能根据数据库配置的不同而不同 ' DataConn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;" ' DataConn.ConnectionString = DataConn.ConnectionString & "Persist Security Info=False;" ' DataConn.ConnectionString = DataConn.ConnectionString & "Initial Catalog=pubs;" ' DataConn.ConnectionString = DataConn.ConnectionString & "Data Source=land-net" ' '建立数据库连接 ' DataConn.Open ' '若RecordSet建立出错，则转向RecordsetERR ' On Error GoTo RecordSetERR ' strSQL = "SELECT au_lname,au_fname,phone " ' '从表authors查询 ' strSQL = strSQL & "FROM authors" ' DataRec.Open strSQL, DataConn ' On Error GoTo PrintERR '设置页面参数 On Error GoTo PrintERR PageHeader = 5 PageFooter = 25 PageLeft = 20 PageRight = 20 With Printer .ScaleMode = 6 .ScaleLeft = 0 .ScaleTop = -5 '设置纸型 .PaperSize = psize .FontSize = fsize ' .ScaleWidth = 210 ' .ScaleHeight = 297 UseWidth = .ScaleWidth UseHeight = .ScaleHeight - 30 .CurrentX = 0 .CurrentY = 0 .DrawWidth = 1 .DrawStyle = 6 End With '打印数据和网格线 Dim yy As Variant yy = 0 c = 0 Do Until Adodc1.Recordset.EOF '将字段值导入到数组中去 For b = 0 To N - 1 v(b) = "" & Adodc1.Recordset.Fields(b).Value Next b ' '判断是否该页已打满，若已满,开始新的一页 If Printer.CurrentY >= UseHeight Then '开始新的一页 Printer.NewPage End If ' 设置打印头的初始位置 With Printer .CurrentX = PageLeft + .ScaleLeft .CurrentY = PageHeader + yy ' StartyLine = .CurrentY End With '' 打印标题 With Printer .CurrentX = (UseWidth - .TextWidth(strTitle)) / 2 ' .CurrentY = PageHeader + .ScaleTop End With Printer.Print strTitle ' 保存坐标y Dim x1, y1, x2, y2 As Variant y1 = PageHeader + yy + 1 ' '打印表格的第一条线 '注意：Line方法不能用在With ....End With块里 ' 确定字段的总宽度 m = 0 For i = 0 To N - 1 l1 = Printer.TextWidth(Trim(pp(i))) ' If v(i) = Null Then ' l2 = 0 ' Else l2 = Printer.TextWidth(Trim(v(i))) ' End If If l1 >= l2 Then m = m + l1 + 2 w1 Else: m = m + l2 + 2 w1 End If Next i ' 设置打印头坐标 With Printer .CurrentX = (UseWidth + m) / 2 .CurrentY = y1 + 5 End With Printer.Line -((UseWidth - m) / 2, Printer.CurrentY) y2 = Printer.CurrentY x2 = Printer.CurrentX ' '打印表头 ' 打印第一条竖线 Printer.Line -(x2, y2 + h / 2) '' 打印其他的字段和竖线 Dim p1, p2 As Variant p1 = x2 + w1 p2 = y2 + w2 l1 = 0 l2 = 0 For j = 0 To N - 1 Printer.CurrentX = p1 Printer.CurrentY = p2 l1 = Printer.TextWidth(Trim(pp(j))) l2 = Printer.TextWidth(Trim(v(j))) If l1 >= l2 Then p1 = p1 + l1 + 2 w1 Else p1 = p1 + l2 + 2 w1 End If Printer.Print pp(j) Printer.Line (p1 - w1, y2 + h / 2)-(p1 - w1, y2) Next j ' 打印中间的横线 Printer.Line (p1 - w1, y2 + h / 2)-(x2, y2 + h / 2) '' 打印字段数据 ' 打印第一条竖线 Printer.Line (x2, y2 + h / 2)-(x2, y2 + h) ' 打印其他的字段数值和竖线 p1 = x2 + w1 p2 = y2 + w2 + h / 2 l1 = 0 l2 = 0 For k = 0 To N - 1 Printer.CurrentX = p1 Printer.CurrentY = p2 l1 = Printer.TextWidth(Trim(pp(k))) l2 = Printer.TextWidth(Trim(v(k))) If l1 >= l2 Then p1 = p1 + l1 + 2 w1 Else p1 = p1 + l2 + 2 w1 End If Printer.Print v(k) Printer.Line (p1 - w1, y2 + h)-(p1 - w1, y2 + h / 2) Next k ' 打印最后一条横线 Printer.Line (p1 - w1, y2 + h)-(x2, y2 + h) Adodc1.Recordset.MoveNext c = c + 1 yy = (Printer.ScaleHeight / 6) (c Mod 6) Loop '结束打印 Printer.EndDoc Exit Sub 'ConnectionERR: ' '错误处理程序 ' MsgBox "数据库连接错误，" & Err.Description, vbCritical, "出错" ' Exit Sub 'RecordSetERR: ' MsgBox "RecordSet生成错误，" & Err.Description, vbCritical, "错误" ' Exit Sub PrintERR: MsgBox "打印错误，" & Err.Description, vbCritical, "出错" End Sub
