📄 frmreport.frm
字号:
strTitle = "流量累计统计表(" & DTPicker1.Value & ")"
lblReport.Caption = strTitle 'lblReport.Caption & "(" & DTPicker1.Value & ")"
rs.OPEN Cmd, , adOpenStatic, adLockReadOnly
lstReport.ListItems.Clear
If rs.RecordCount = 0 Then
rs.Close
Set rs = Nothing
Exit Sub
End If
While Not rs.EOF
If Hour(rs("WTime")) = 0 Then
For i = 1 To frmMain.LED_Flux.UBound + 1
If IsNull(rs("D" & i)) Then
Fluxtemp(i - 1) = 0
Else
Fluxtemp(i - 1) = rs("D" & i)
End If
Next
UPList = True
ElseIf Hour(rs("WTime")) = 23 And Minute(rs("WTime")) = 59 Then
If UPList = True Then
Set xItem = lstReport.ListItems.Add(, , rs("WDate"))
For i = 1 To 10
If IsNull(rs("D" & i)) Then
xItem.SubItems(i) = 0
Else
xItem.SubItems(i) = Val(rs("D" & i)) - Fluxtemp(i - 1)
End If
Next
UPList = False
End If
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Case 5
Dim TempTJ(0 To 5) As Single, CountTemp As Long, A As Long, B As Long
If UPdata Then
lstReport.ColumnHeaders.Clear
lstReport.ColumnHeaders.Add , , "班次", 1000, 0
lstReport.ColumnHeaders.Add , , "班组", 1000, 2
lstReport.ColumnHeaders.Add , , "耗蒸汽(t)", 2000, 2
lstReport.ColumnHeaders.Add , , "外送蒸汽(t)", 2000, 2
lstReport.ColumnHeaders.Add , , "净用蒸汽(t)", 2000, 2
lstReport.ColumnHeaders.Add , , "入炉煤(t)", 2000, 2
lstReport.ColumnHeaders.Add , , "半水煤气产量(km3)", 2000, 2
End If
If IsAcess Then
Cmd.CommandText = "Select * from Change where WDate=CDATE('" & DTPicker1.Value & "') order by WTime"
Else
Cmd.CommandText = "Select * from Change where WDate='" & DTPicker1.Value & "' order by WTime"
If rs.State = 1 Then
rs.Close
Set rs = Nothing
End If
End If
strTitle = "消耗产量日报表(" & DTPicker1.Value & ")"
lblReport.Caption = strTitle 'lblReport.Caption & "(" & DTPicker1.Value & ")"
rs.OPEN Cmd, , adOpenStatic, adLockReadOnly
lstReport.ListItems.Clear
If rs.RecordCount = 0 Then
rs.Close
Set rs = Nothing
Exit Sub
End If
While Not rs.EOF
If CountTemp = 0 Then
If Hour(rs("WTime")) = 7 Or Hour(rs("WTime")) = 8 Then
A = 7: B = 8
Set xItem = lstReport.ListItems.Add(, , "一班")
CountTemp = 1
GoTo N1
Else
Set xItem = lstReport.ListItems.Add(, , "一班")
xItem.SubItems(2) = 0
xItem.SubItems(3) = 0
xItem.SubItems(4) = 0
xItem.SubItems(5) = 0
xItem.SubItems(6) = 0
CountTemp = 1
End If
End If
If CountTemp = 1 Then
If Hour(rs("WTime")) = 15 Or Hour(rs("WTime")) = 16 Then
A = 15: B = 16
Set xItem = lstReport.ListItems.Add(, , "二班")
CountTemp = 2
GoTo N1
Else
Set xItem = lstReport.ListItems.Add(, , "二班")
xItem.SubItems(2) = 0
xItem.SubItems(3) = 0
xItem.SubItems(4) = 0
xItem.SubItems(5) = 0
xItem.SubItems(6) = 0
CountTemp = 2
End If
End If
If CountTemp = 2 Then
If Hour(rs("WTime")) = 23 Or Hour(rs("WTime")) = 23 Then
A = 23: B = 23
Set xItem = lstReport.ListItems.Add(, , "三班")
CountTemp = 3
GoTo N1
Else
Set xItem = lstReport.ListItems.Add(, , "三班")
xItem.SubItems(2) = 0
xItem.SubItems(3) = 0
xItem.SubItems(4) = 0
xItem.SubItems(5) = 0
xItem.SubItems(6) = 0
CountTemp = 3
End If
End If
N1: If Hour(rs("WTime")) = A Or Hour(rs("WTime")) = B Then
If IsNull(rs("UserID")) Then
xItem.SubItems(1) = 0
Else
xItem.SubItems(1) = rs("UserID")
End If
If IsNull(rs("D14")) Then
xItem.SubItems(2) = 0
Else
xItem.SubItems(2) = rs("D14")
TempTJ(0) = TempTJ(0) + Val(rs("D14"))
End If
If IsNull(rs("D15")) Then
xItem.SubItems(3) = 0
Else
xItem.SubItems(3) = rs("D15")
TempTJ(1) = TempTJ(1) + Val(rs("D15"))
End If
If IsNull(rs("D7")) Then
xItem.SubItems(4) = 0
Else
xItem.SubItems(4) = rs("D7")
TempTJ(2) = TempTJ(2) + Val(rs("D7"))
End If
If IsNull(rs("D1")) Then
xItem.SubItems(5) = 0
Else
xItem.SubItems(5) = rs("D1")
TempTJ(3) = TempTJ(3) + Val(rs("D1"))
End If
If IsNull(rs("D16")) Then
xItem.SubItems(6) = 0
Else
xItem.SubItems(6) = rs("D16")
TempTJ(4) = TempTJ(4) + Val(rs("D16"))
End If
End If
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
If CountTemp = 0 Then
Set xItem = lstReport.ListItems.Add(, , "一班")
xItem.SubItems(2) = 0
xItem.SubItems(3) = 0
xItem.SubItems(4) = 0
xItem.SubItems(5) = 0
xItem.SubItems(6) = 0
CountTemp = CountTemp + 1
End If
If CountTemp = 1 Then
Set xItem = lstReport.ListItems.Add(, , "二班")
xItem.SubItems(2) = 0
xItem.SubItems(3) = 0
xItem.SubItems(4) = 0
xItem.SubItems(5) = 0
xItem.SubItems(6) = 0
CountTemp = CountTemp + 1
End If
If CountTemp = 2 Then
Set xItem = lstReport.ListItems.Add(, , "三班")
xItem.SubItems(2) = 0
xItem.SubItems(3) = 0
xItem.SubItems(4) = 0
xItem.SubItems(5) = 0
xItem.SubItems(6) = 0
CountTemp = CountTemp + 1
End If
If CountTemp >= 3 Then
Set xItem = lstReport.ListItems.Add(, , "合计")
xItem.SubItems(2) = TempTJ(0)
xItem.SubItems(3) = TempTJ(1)
xItem.SubItems(4) = TempTJ(2)
xItem.SubItems(5) = TempTJ(3)
xItem.SubItems(6) = TempTJ(4)
End If
End Select
Exit Sub
N:
If rs.State = 1 Then
rs.Close
Set rs = Nothing
End If
Err.Clear
End Sub
'打印内容代码。预览或打印都是调用该代码的，也是大部分打印方法的演示
Public Sub PrintContent(Optional PrintDevice As Printer)
If Not PrintDevice Is Nothing Then
CurtPrinter1.StartPrint PrintDevice '打印到打印机
Else
CurtPrinter1.StartPrint '缺省是预览
End If
With CurtPrinter1
'第一页，编程打印，其实也是非常简单 '重新开始一页，直接打印报表，注意，它会自动换页，如果你设定了标题，它也自动打哦:)
.NewPage
'根据控件的DirectPrint方法写的代码，大家可以参考来写自己的DirectPrint方法
.TitleOut strTitle, 20, vbCenter
RefDirectPrint lstReport, strTitle, 20, vbCenter
.NewRow
' 支持DATEGRID的直接打印，用法同上，不提供例子了'结束打印
.EndDoc
End With
End Sub
'预览的代码'两行代码可选，一个会调用打印对话框，一个直接打印了。'点击了预览控件上的关闭，引发该事件，关闭预览窗体
Private Sub curtprinter1_ClosePreview()
CurtPrinter1.Visible = False
Frame1.Visible = True
End Sub
'如果每次调整预览比例好重新生成预览的话，请将AutoRedraw设置为FALSE，然后在下面的事件添入要重画的代码
Private Sub curtprinter1_NeedRedraw()
PrintContent
End Sub
'写入打印叶脚的代码
Private Sub curtprinter1_PrintFooter(CurrentPage As Long)
'CurtPrinter1.FooterOut "tubPrinter打印/预览控件", "页脚测试", "其他信息"
End Sub
'写入打印页眉的代码
Private Sub curtprinter1_PrintHeader(CurrentPage As Long)
'CurtPrinter1.HeaderOut "tubPrinter打印/预览控件", "页眉测试", "第" & CurrentPage & "页"
End Sub
'点击了预览窗体或直接调用ShowPrinter后，点击了打印机窗口的确定，引发打印代码，打印到打印机上！
Private Sub curtprinter1_RealPrint()
PrintContent Printer
End Sub
'如果隐藏工具条，仍可以通过简单的编程控制预
'预览控件尺寸根据窗口调整
Private Sub Form_Resize()
CurtPrinter1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub Form_Unload(Cancel As Integer)
If CurtPrinter1.Busy = True Then '打印预览控件忙则取消打印任务，然后就可以退出了
CurtPrinter1.CancelPrint
MsgBox "打印控件忙，稍后重试。", vbInformation
Cancel = True
End If
Set frmReport = Nothing
End Sub
'大家打印自己的控件可参考下面代码(从DirectPrint修改而来）
Private Sub RefDirectPrint(objToPrint As Object, Optional TITLE As String, _
Optional tFontSize As Long = 12, Optional titleAlignment As AlignmentConstants = vbCenter)
Dim i As Long, j As Long, k As Long, oldFont As New StdFont
'保存打印控件使用的字体，并使用新字体
CloneFont oldFont, CurtPrinter1.Font
CloneFont CurtPrinter1.Font, objToPrint.Font
If Not CurtPrinter1.IsPrinter Then CurtPrinter1.Font.Size = CurtPrinter1.FontSize * CurtPrinter1.Zoom / 100
With objToPrint
If TypeName(objToPrint) = "ListView" Then
'先打印ColumnHeaders
If .ListItems.Count < 1 Or .View < 1 Then GoTo EndP
CurtPrinter1.CellOut .ColumnHeaders(1).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4422", vbButtonFace '边缘单元格
For j = 2 To .ColumnHeaders().Count - 1
CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2422", vbButtonFace '边缘单元格
Next j
CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2442", vbButtonFace '边缘单元格
CurtPrinter1.NewCellRow
'打印实际表格部分
For i = 1 To .ListItems.Count - 1
If CurtPrinter1.CurrentY + TextHeight("人") * 3 > CurtPrinter1.ScaleHeight - CurtPrinter1.TopMargin - CurtPrinter1.BottomMargin Then
'最后一行的单元格
CurtPrinter1.CellOut .ListItems(i).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4224"
For j = 1 To .ListItems(i).ListSubItems().Count - 1
CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2224"
Next j
CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2244"
'重新打印表头
CurtPrinter1.NewPage
If TITLE <> "" Then CurtPrinter1.TitleOut TITLE, tFontSize, titleAlignment
CurtPrinter1.CellOut .ColumnHeaders(1).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4422", vbButtonFace '边缘单元格
For j = 2 To .ColumnHeaders().Count - 1
CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2422", vbButtonFace '边缘单元格
Next j
CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2442", vbButtonFace '边缘单元格
Else
'打印非边缘的单元格
CurtPrinter1.CellOut .ListItems(i).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4222"
For j = 1 To .ListItems(i).ListSubItems().Count - 1
CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2222"
Next j
CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2242"
End If
CurtPrinter1.NewCellRow
Next i
'打印最后一行
CurtPrinter1.CellOut .ListItems(i).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4224"
For j = 1 To .ListItems(i).ListSubItems().Count - 1
CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2224"
Next j
CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2244"
End If
End With
EndP:
'恢复打印控件原来使用的字体
CloneFont CurtPrinter1.Font, oldFont
Set oldFont = Nothing
End Sub
'复制字体属性
Private Sub CloneFont(Dest As StdFont, Src As StdFont)
With Dest
.Bold = Src.Bold
.Charset = Src.Charset
.Italic = Src.Italic
.Name = Src.Name
.Size = Src.Size
.Strikethrough = Src.Strikethrough
.Underline = Src.Underline
.Weight = Src.Weight
End With
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -