数据表直接打印
ActiveX控件制作：
1．新建ActiveX控件工程；
2．添加ADODC1控件和COMMAND1控件；
3．代码：
Option Explicit
Dim pw, ph '纸宽和纸高的坐标
Dim px, py
Dim ti '报表字段数
Dim wh, ww '字宽和字高
Dim table1 '第一页表格开始高度
Dim daima(100, 3) As String
Dim bnum As Integer
Private Function len1(str As String) As Integer
Dim si, i As Integer
Dim str1 As String
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function len2(s2 As String, si As Integer) As String
Do While len1(s2) > si
s2 = Mid(s2, 1, Len(s2) - 1)
Loop
len2 = s2
End Function
Private Sub finput()
Dim i As Integer
ti = Adodc1.Recordset.Fields.Count
For i = 1 To ti
daima(i, 1) = Adodc1.Recordset.Fields(i - 1).Name
daima(i, 2) = len1(daima(i, 1)) + 2 '表格宽度
daima(i, 3) = Adodc1.Recordset.Fields(i - 1).Name
Next i
End Sub
Private Sub printhead()
Dim pp0, tpp, i
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
pp0 = 20 - (len1(Thead))
tpp = ""
For i = 1 To pp0
tpp = tpp + " "
Next i
Printer.Print tpp & Thead
table1 = 50
End Sub
Private Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)
Dim py1 As Integer
Dim pxm, pxi, px1, bi
Dim daim1, daim2 As String
pxm = 0 '计算报表宽度
For pxi = 1 To ti
pxm = pxm + daima(pxi, 2) * ww
Next
Printer.DrawWidth = 3
Printer.FontSize = 11
Printer.FontBold = True
py = pp1 + (pp3 + 2 - pp2) * wh '计算报表高度
Printer.Line (0, pp1)-(pxm, pp1) '打印边框
Printer.Line (pxm, pp1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, pp1)
Printer.DrawWidth = 1 '打印表头
px = 0
For pxi = 1 To ti
daim2 = daima(pxi, 1)
px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = pp1 + Int(0.2 * wh)
Printer.Print daima(pxi, 1) '打印字段名
px = px + daima(pxi, 2) * ww
Printer.Line (px, pp1)-(px, py) '打印竖线
Next
Printer.FontBold = False
py = pp1 + wh
For bi = pp2 To pp3
px = 0
For pxi = 1 To ti
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = daima(pxi, 3)
'Select Case daim1
'Case "序号": daim2 = bi '打印序号
'Case "空白": daim2 = "" '打印空白字段
'Case Else: daim2 = Adodc1.Recordset(daim1)
'End Select
If IsNull(Adodc1.Recordset(daim1)) Then
daim2 = ""
Else
daim2 = Adodc1.Recordset(daim1)
End If
Printer.Print len2(daim2, Int(daima(pxi, 2))) '打印字段内容
px = px + daima(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py) '打印横线
py = py + wh
Adodc1.Recordset.MoveNext
Next bi
End Sub
Private Sub printfoot(pp1 As Integer, pp2 As Integer) '打印页码
px = pw - 300: py = ph - 5 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & pp2 & " 当前页数:" & pp1
End Sub
Private Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Call printframe(p1, p2, p3)
Call printfoot(p4, p5)
End Sub
Private Sub printbody()
Dim page As Integer '页码数
Dim pi As Integer
Dim p1y As Integer '第一页记录数
Dim p2y As Integer '第二页记录数
Dim table2 '第二页起始位置
p2y = 37
table2 = 20
table1 = table1 + wh
p1y = (ph - table1 - 100) / wh
Adodc1.Recordset.MoveFirst
If bnum < p1y + 1 Then
Call printail(table1, 1, bnum, 1, 1) '只有一页
Else
page = Int(((bnum - p1y) / p2y) + 1.9999) '计算页码
Call printail(table1, 1, p1y, 1, page) '打印第一页
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页
Else
Printer.NewPage
Call printail(table2, p1y + 1, bnum, page, page) '打印最后一页
End If
End If
End Sub
Private Sub printp()
Dim sp '左边距
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc ‘开始打印
End Sub
Private Sub Command1_Click()
Dim dbq1
dbq1 = "DBQ=\\xuewei\共享\test1.mdb;DefaultDir=c:\My Documents\共享\t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:\Program Files\Common Files\ODBC\Data Sources\test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1
Adodc1.RecordSource = Tname
Adodc1.Refresh
bnum = Adodc1.Recordset.RecordCount
finput
printp
MsgBox "打印完毕。共有" & bnum & "条记录"
Adodc1.Recordset.Close
Command1.Enabled = False
End Sub
4．产生Tname和Thead属性的接口；
5．打成INTERNET包；
6．在网页上代码如下：
<HTML>
<HEAD>
<TITLE>Gxue32.CAB</TITLE>
</HEAD>
<BODY>
数据库表格打印示例
<p></p>
<OBJECT ID="Uxue32"
CLASSID="CLSID:0DF80DF0-B268-11D5-9C19-0010D70B5752"
CODEBASE="Gxue32.CAB#version=1,0,0,0" width="79" height="33">
<param name="_ExtentX" value="2090">
<param name="_ExtentY" value="873">
<param name="Tname" value="表1">
<param name="Thead" value="数据简表">
</OBJECT>
</BODY>
</HTML>
数据表格式打印
ActiveX控件制作步骤同上，增加一个Tarray属性，代码：
Option Explicit
Dim pw, ph '纸宽和纸高的坐标
Dim px, py
Dim ti '报表字段数
Dim wh, ww '字宽和字高
Dim table1 '第一页表格开始高度
Dim daima(100, 3) As String ‘打印数组
Dim tax(100, 2) As String ‘格式数组
Dim bnum As Integer ‘总记录数
Private Function len1(str As String) As Integer
Dim si, i As Integer
Dim str1 As String
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function len2(s2 As String, si As Integer) As String
Do While len1(s2) > si
s2 = Mid(s2, 1, Len(s2) - 1)
Loop
len2 = s2
End Function
Private Function midx(taa) As String
Dim ii As Integer
Dim char1 As String
char1 = Mid(taa, 1, 1)
midx = ""
ii = 1
Do While char1 <> "{" And ii <= Len(taa) + 1
midx = midx & char1
ii = ii + 1
char1 = Mid(taa, ii, 1)
Loop
'If ii = Len(taa) Then midx = taa
'MsgBox "taa=" & taa & " midx=" & midx
End Function
Private Sub toarray(tt)
Dim ii As Integer
Dim tt0
tax(0, 0) = midx(tt)
tt0 = Mid(tt, Len(tax(0, 0)) + 2, Len(tt))
If tax(0, 0) > 0 Then
For ii = 1 To tax(0, 0)
tax(ii, 1) = midx(tt0)
tt0 = Mid(tt0, Len(tax(ii, 1)) + 2, Len(tt0))
tax(ii, 2) = midx(tt0)
tt0 = Mid(tt0, Len(tax(ii, 2)) + 2, Len(tt0))
Next ii
End If
End Sub
Private Sub finput()
Dim i As Integer
toarray (Tarray)
ti = Adodc1.Recordset.Fields.Count
If ti > tax(0, 0) Then ti = tax(0, 0)
For i = 1 To ti
daima(i, 1) = tax(i, 1)
daima(i, 2) = tax(i, 2) '表格宽度
daima(i, 3) = Adodc1.Recordset.Fields(i - 1).Name
Next i
End Sub
Private Sub printhead()
Dim pp0, tpp, i
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
pp0 = 20 - (len1(Thead))
tpp = ""
For i = 1 To pp0
tpp = tpp + " "
Next i
Printer.Print tpp & Thead
table1 = 50
End Sub
Private Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)
Dim py1 As Integer
Dim pxm, pxi, px1, bi
Dim daim1, daim2 As String
pxm = 0 '计算报表宽度
For pxi = 1 To ti
pxm = pxm + daima(pxi, 2) * ww
Next
Printer.DrawWidth = 3
Printer.FontSize = 11
Printer.FontBold = True
py = pp1 + (pp3 + 2 - pp2) * wh '计算报表高度
Printer.Line (0, pp1)-(pxm, pp1) '打印边框
Printer.Line (pxm, pp1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, pp1)
Printer.DrawWidth = 1 '打印表头
px = 0
For pxi = 1 To ti
daim2 = daima(pxi, 1)
px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = pp1 + Int(0.2 * wh)
Printer.Print daima(pxi, 1) '打印字段名
px = px + daima(pxi, 2) * ww
Printer.Line (px, pp1)-(px, py) '打印竖线
Next
Printer.FontBold = False
py = pp1 + wh
For bi = pp2 To pp3
px = 0
For pxi = 1 To ti
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = daima(pxi, 3)
'Select Case daim1
'Case "序号": daim2 = bi '打印序号
'Case "空白": daim2 = "" '打印空白字段
'Case Else: daim2 = Adodc1.Recordset(daim1)
'End Select
If IsNull(Adodc1.Recordset(daim1)) Then
daim2 = ""
Else
daim2 = Adodc1.Recordset(daim1)
End If
Printer.Print len2(daim2, Int(daima(pxi, 2))) '打印字段内容
px = px + daima(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py) '打印横线
py = py + wh
Adodc1.Recordset.MoveNext
Next bi
End Sub
Private Sub printfoot(pp1 As Integer, pp2 As Integer) '打印页码
px = pw - 300: py = ph - 5 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & pp2 & " 当前页数:" & pp1
End Sub
Private Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Call printframe(p1, p2, p3)
Call printfoot(p4, p5)
End Sub
Private Sub printbody()
Dim page As Integer '页码数
Dim pi As Integer
Dim p1y As Integer '第一页记录数
Dim p2y As Integer '第二页记录数
Dim table2 '第二页起始位置
p2y = 37
table2 = 20
table1 = table1 + wh
p1y = (ph - table1 - 100) / wh
Adodc1.Recordset.MoveFirst
If bnum < p1y + 1 Then
Call printail(table1, 1, bnum, 1, 1) '只有一页
Else
page = Int(((bnum - p1y) / p2y) + 1.9999) '计算页码
Call printail(table1, 1, p1y, 1, page) '打印第一页
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页
Else
Printer.NewPage
Call printail(table2, p1y + 1, bnum, page, page) '打印最后一页
End If
End If
End Sub
Private Sub printp()
Dim sp '左边距
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
End Sub
Private Sub Command1_Click()
Dim dbq1
dbq1 = "DBQ=\\xuewei\共享\test1.mdb;DefaultDir=c:\My Documents\共享\t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:\Program Files\Common Files\ODBC\Data Sources\test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1
Adodc1.RecordSource = Tname
Adodc1.Refresh
bnum = Adodc1.Recordset.RecordCount
finput
printp
MsgBox "打印完毕。共有" & bnum & "条记录"
Adodc1.Recordset.Close
Command1.Enabled = False
End Sub
打包后在网页上编程为：
<script language="vbscript">
<!--
Option Explicit
dim ta0(100,2)
Private Function len1(str)
Dim si, i
Dim str1
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function tostring ()
Dim ii
tostring = Ta0(0, 0) & "{"
For ii = 1 To Ta0(0, 0)
If IsNull(Ta0(ii, 1)) Then Ta0(ii, 1) = ""
tostring = tostring & Ta0(ii, 1) & "{"
If IsNull(Ta0(ii, 2)) Then Ta0(ii, 2) = 0
If Ta0(ii, 2) < len1(Ta0(ii, 1)) + 2 Then
Ta0(ii, 2) = len1(Ta0(ii, 1)) + 2
End If
tostring = tostring & Ta0(ii, 2) & "{"
Next
End Function
Private Sub window_onload()
form1.Uxue33.Tname = "注册登记表"
form1.Uxue33.Thead = "取水许可证系统注册登记表"
Ta0(0, 0) = "10"
Ta0(1, 1) = "注册名"
Ta0(1, 2) = "8"
Ta0(2, 1) = "密码"
Ta0(2, 2) = "8"
Ta0(3, 1) = "姓名"
Ta0(3, 2) = "8"
Ta0(4, 1) = "性别"
Ta0(4, 2) = "4"
Ta0(5, 1) = "单位"
Ta0(5, 2) = "16"
Ta0(6, 1) = "注册用途"
Ta0(6, 2) = "11"
Ta0(7, 1) = "电子信箱"
Ta0(7, 2) = "10"
Ta0(8, 1) = "批准"
Ta0(8, 2) = "6"
Ta0(9, 1) = "权限"
Ta0(9, 2) = "6"
Ta0(10, 1) = "取水用途"
Ta0(10, 2) = "10"
'Ta0(11, 1) = "fdsfd"
'Ta0(11, 2) = "8"
'Ta0(12, 1) = "123fdsfd"
'Ta0(12, 2) = "1"
form1.Uxue33.Tarray = tostring
msgbox form1.Uxue33.Tarray
end sub
-->
</script>