|
楼上几位老大介绍的方法使用excel比报表更加灵活
推荐使用,不过导出数据的速度没有报表快
下面的是根据已经设置好的模板,然后把数据导出对应的格子就可以啦
Private Sub cmd打印_Click()
On Error Resume Next
'设定行起始值
Dim Row As Integer
'设定列起始值
Dim Col As Integer
Dim i As Integer
Dim Conn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim Strsql As String
Dim ExcelApp As Excel.Application
Dim ExcelWst As Excel.Worksheet
Dim Exltemple As String
Dim Exloutput As String
Dim StrRange As String
Dim txtID As Double
Dim txtYear As String
Dim txtname As String
Set Conn = CurrentProject.Connection
Set Rs = New ADODB.Recordset
txtID = [Forms]![frm人员分类统计]![txtID]
txtname = [Forms]![frm人员分类统计]![txt单位]
txtYear = [Forms]![frm人员分类统计]![txt年度]
Strsql = "SELECT qry分类统计.* FROM qry分类统计 WHERE (((qry分类统计.ID) = '" & txtID & "') And ((qry分类统计.年度) = '" & txtYear & "')) Or (((qry分类统计.IDparent) = '" & txtID & "') And ((qry分类统计.年度) = '" & txtYear & "')) ORDER BY qry分类统计.IDparent, qry分类统计.ID"
Rs.Open Strsql, Conn, 1
Screen.MousePointer = 11
Exltemple = IIf(Len(Application.CurrentProject.Path) = 3, Left(Application.CurrentProject.Path, 2), Application.CurrentProject.Path) & "\rpt\人员分类统计表.xls"
Exloutput = IIf(Len(Application.CurrentProject.Path) = 3, Left(Application.CurrentProject.Path, 2), Application.CurrentProject.Path) & "\temp\" & txtYear & txtname & "_人员分类统计表.xls"
If IsFileName(Exltemple) = True Then
'直接覆盖临时文件中的模板文件
If IsFileName(Exloutput) = True Then
'先删除该文件 , 然后再复制
Kill Exloutput
FileCopy Exltemple, Exloutput
Else
'直接复制
FileCopy Exltemple, Exloutput
End If
Else
'提示选择模板文件的位置
MsgBox Exltemple & "文件不存在," & vbCrLf & "请重新选择该文件所在位置!" & vbCrLf & _
"该文件应该位于" & IIf(Len(Application.CurrentProject.Path) = 3, Left(Application.CurrentProject.Path, 2), Application.CurrentProject.Path) & "\rpt目录中"
' Me.dlgCommon.CancelError = True
' Me.dlgCommon.ShowOpen
'
Dim tmpFileName As String, XLSfile As String
XLSfile = SelectFileName("人员分类统计表 (*.xls)", "选择模板文件", "选择文件")
tmpFileName = IIf(InStrRev(XLSfile, "\") > 0, Right(XLSfile, Len(XLSfile) - k), XLSfile)
If tmpFileName <> "人员分类统计表.xls" Then
MsgBox "模板文件丢失或选择错误,你不能导出数据!"
Exit Sub
End If
End If
Err.Clear
Set ExcelApp = GetObject("", "Excel.Application")
If Err.Number <> 0 Then
Set ExcelApp = New Excel.Application
End If
Err.Clear
' Set ExcelWst = ExcelApp.Workbooks.Add.Worksheets(1)
'Debug.Print Application.CurrentProject.Path
Set ExcelWst = ExcelApp.Workbooks.Add(Exloutput).Worksheets(1)
With ExcelWst
.NAME = txtname
Row = 6
While Not Rs.EOF
.Cells(Row, 1) = Rs("sname")
'将字段的内容赋值给相应表格
For i = 0 + 5 To Rs.Fields.Count - 1
Select Case i
Case 5
Col = 3
Case 8
Col = Col + 3
Case 6, 11, 20, 22, 24, 26
Col = Col + 2
Case Else
Col = Col + 1
End Select
'填入所有相关的值,如果为0的话,就不填啦
If Rs.Fields(i) > 0 Then
.Cells(Row, Col) = Rs.Fields(i)
End If
Next i
Row = Row + 1
Rs.MoveNext
Wend
'设定打印的格式化
StrRange = "a6:" & .Cells(Row - 1, Col).Address
.Range(StrRange).Font.Size = 9
.Range(StrRange).Orientation = 0
.Range(StrRange).Borders.LineStyle = xlContinuous
.Range(StrRange).Borders.Weight = xlThin
.Range(StrRange).Borders.ColorIndex = xlAutomatic
' |
|