以前做的一个单据外观小程序,客户可以编辑word模版改变单据的样式,废话不说了,直接上图和代码:http://leek.woku.com/article/4876141.html
Public Sub ExporToWord2003()
On Error GoTo DocERR
'************************************************************************************
Dim Rs As New ADODB.Recordset
Dim strsql As String
If Len(TextNumber.Text) <> 0 Then
'*使用自定义寻找表单号
If Len(TextNumber.Text) <> 12 Then
MsgBox "输入的表单号应该是12个数字字符",vbInformation
GoTo PROC_EXIT
End If
strsql = "SELECT * FROM 记录 WHERE 记录号 = " & _
QueryStrTosqlstr(TextNumber.Text) & " ORDER BY ID"
Set Rs = Executesql(strsql)
If Rs.RecordCount <> 1 Then
MsgBox "输入表单号错误!",vbExclamation
Rs.Close
Set Rs = Nothing
GoTo PROC_EXIT
End If
Else
strsql = "SELECT * FROM 记录 ORDER BY ID"
Set Rs = Executesql(strsql)
Rs.MoveLast
End If
'************************************************************************************
Label3.Caption = "加载模板,请稍候......"
'建立Word应用程序
Set WordAppX = New Word.Application
'建立Word文档,以当前目录下的Authors.dot为模板
Set WordDocX = WordAppX.Documents.Add(App.Path & "/Authors.dot")
'*不必保存文件
'WordAppX.DisplayAlerts = wdAlertsNone
'获得表格
'*表格索引(1)
Set WordTableX = WordDocX.Tables(1)
'*显示WORD
WordAppX.Visible = Check1.Value
WordTableX.Cell(1,1).Range.InsertAfter strNO_Null(Rs("用户住址"))
WordTableX.Cell(1,2).Range.InsertAfter strNO_Null(Rs("用户姓名"))
WordTableX.Cell(3,3).Range.InsertAfter strNO_Null(Rs("水表1底数"))
WordTableX.Cell(3,4).Range.InsertAfter strNO_Null(Rs("水表1底数") - Rs("表1量"))
WordTableX.Cell(3,5).Range.InsertAfter strNO_Null(Rs("表1量"))
WordTableX.Cell(3,6).Range.InsertBefore Trim(Format(Rs("表1价"),"###0.00")) & "/吨"
Dim curWater As Currency
curWater = Rs("表1量") * Rs("表1价")
WordTableX.Cell(4,7).Range.InsertBefore GetOneNum(curWater,1)
WordTableX.Cell(4,8).Range.InsertBefore GetOneNum(curWater,2)
WordTableX.Cell(4,9).Range.InsertBefore GetOneNum(curWater,3)
WordTableX.Cell(4,10).Range.InsertBefore GetOneNum(curWater,4)
WordTableX.Cell(4,11).Range.InsertBefore GetOneNum(curWater,6)
WordTableX.Cell(4,12).Range.InsertBefore GetOneNum(curWater,7)
WordTableX.Cell(5,3).Range.InsertAfter Rs("水表2底数")
WordTableX.Cell(5,4).Range.InsertAfter Rs("水表2底数") - Rs("表2量")
WordTableX.Cell(5,5).Range.InsertAfter Rs("表2量")
WordTableX.Cell(5,6).Range.InsertBefore Trim(Format(Rs("表2价"),"###0.00")) & "/吨"
curWater = Rs("表2量") * Rs("表2价")
WordTableX.Cell(5,1)
WordTableX.Cell(5,2)
WordTableX.Cell(5,3)
WordTableX.Cell(5,4)
WordTableX.Cell(5,6)
WordTableX.Cell(5,7)
WordTableX.Cell(6,4).Range.InsertAfter Rs("本次购电量")
WordTableX.Cell(6,5).Range.InsertAfter Trim(Format(Rs("每度电单价"),"###0.00")) & "/度"
curWater = Rs("本次购电量") * Rs("每度电单价")
WordTableX.Cell(6,6).Range.InsertBefore GetOneNum(curWater,1)
WordTableX.Cell(6,2)
WordTableX.Cell(6,3)
WordTableX.Cell(6,4)
WordTableX.Cell(6,6)
WordTableX.Cell(6,7)
curWater = Rs("管理服务费")
WordTableX.Cell(7,1)
WordTableX.Cell(7,2)
WordTableX.Cell(7,3)
WordTableX.Cell(7,4)
WordTableX.Cell(7,6)
WordTableX.Cell(7,7)
curWater = Rs("住房维修费")
WordTableX.Cell(8,1)
WordTableX.Cell(8,2)
WordTableX.Cell(8,3)
WordTableX.Cell(8,4)
WordTableX.Cell(8,6)
WordTableX.Cell(8,7)
curWater = Rs("应交")
WordTableX.Cell(9,2).Range.InsertBefore ChMoney(curWater)
WordTableX.Cell(9,3).Range.InsertBefore GetOneNum(curWater,1)
WordTableX.Cell(9,4).Range.InsertBefore GetOneNum(curWater,2)
WordTableX.Cell(9,5).Range.InsertBefore GetOneNum(curWater,3)
WordTableX.Cell(9,4)
WordTableX.Cell(9,6)
WordTableX.Cell(9,7)
WordTableX.Cell(3,13).Range.InsertBefore "单据号:" & strNO_Null(Rs("记录号")) & _
" 日期:" & Datetochina(Rs("收费日期")) & _
" 收费员:" & strNO_Null(Rs("售电员"))
' 行 列
'WordTableX.Cell(4,2).Range.InsertAfter "用户编号"
'****************************************************
'*关闭数据集
Rs.Close
Set Rs = Nothing
'****************************************************
If Check1.Value = 0 Then
'*直接打印
WordAppX.PrintOut
'*等待打印完成后退出
'*程序关闭WORD 释放内存
Timer1.Interval = 5000
Timer1.Enabled = True
Else
'打印预览
WordDocX.PrintPreview
WordAppX.DisplayAlerts = False
'*手动关闭WORD
Set WordAppX = Nothing '交还控制给Word
Set WordDocX = Nothing
Set WordTableX = Nothing
'*显示消息
Label3.Caption = "系统就绪..."
End If
PROC_EXIT:
Exit Sub
ConnectionERR:
'错误处理程序
MsgBox "数据库连接错误," & Err.Description,vbCritical,"出错"
GoTo PROC_EXIT
RecordSetERR:
MsgBox "RecordSet生成错误," & Err.Description,"出错"
GoTo PROC_EXIT
DocERR:
MsgBox "填充Word表格错误," & Err.Description,"出错"
If Not WordAppX Is Nothing Then WordAppX.Quit
GoTo PROC_EXIT
End Sub