VB6常用方法汇编(10)

数据表直接打印

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>

• ·WIN2000下的系统进程名称列表
• ·(转载)ARP协议揭密
• ·解决IIS启动时出现0x8ffe2740的错误
• ·(转载)修改Windows SMB相关服务的默
• ·(转载)获取Windows 系统的内核变量
• ·(转载)通用ShellCode深入剖析
• ·吐水奉献 ——PHP常用函数
• ·vbs调用WebService(摘possib
• ·用户控件用户登录判断
• ·(转载)对Native API NtSyste