frmtjrsfrm.frm

vb源代码

End Sub

Private Sub cmdClearLimtTxt_Click()
    txtTxt.Text = ""
End Sub

Private Sub cmdClearOrder_Click()
    txtTxtOrder.Text = ""
End Sub

Private Sub cmdCount_Click()
    Dim i As Integer, j As Integer, k As Integer
    Dim iGroup As Integer, iCount As Integer '记载参加分组和统计的字段数目
    Dim aMyTotal(5, 5)  '用来累计（第0行存分组项目的名称，第6行存需不需要进行统计,第6列存需要统计的项目类型）
    Dim tmpSqlGroup As String
    Dim rsTmp As New ADODB.Recordset
        
    lstTj.ColumnHeaders.Clear
    '   添加列标头
    '添加分组项
    iGroup = 0
    For j = 0 To 3
        If cobGroup(j).ListIndex > 0 Then
            lstTj.ColumnHeaders.Add , , Trim(Left(cobGroup(j).Text, Len(cobGroup(j).Text) - 50))
            iGroup = iGroup + 1
        End If
    Next j
    If iGroup = 0 Then
        MsgBox "您至少得选择一个字段进行分组！"
        Exit Sub
    End If
    '添加统计项
    iCount = 0
    For j = 0 To 3
        If cobCount(j).ListIndex > 0 Then
            sSql = Trim(Left(cobCount(j).Text, Len(cobCount(j).Text) - 50))
            sSql = sSql & "(" & Trim(Left(cobCountSort(j).Text, Len(cobCountSort(j).Text) - 50)) & ")"
            lstTj.ColumnHeaders.Add , , sSql
            iCount = iCount + 1
            aMyTotal(iCount, 5) = Trim(Right(cobCountSort(j).Text, 10))         '进行统计的项目是计数、求和、还是最大值最小值
            If aMyTotal(iCount, 5) = "count" Then aMyTotal(iCount, 5) = "sum"
        End If
    Next j
    If iCount = 0 Then
        MsgBox "您至少得选择一个项目进行统计！"
        Exit Sub
    End If

    '构造分组字段
    sSql = ""
    For j = 0 To 3
        If cobGroup(j).ListIndex > 0 Then
            If sSql <> "" Then sSql = sSql & ","
            sSql = sSql & Trim(Left(cobGroup(j).Text, Len(cobGroup(j).Text) - 50))
        End If
    Next j
    tmpSqlGroup = sSql
    
    '构造统计字段
    For j = 0 To 3
        If cobCount(j).ListIndex > 0 Then
            sSql = sSql & "," & Trim(Right(cobCountSort(j).Text, 10)) & "("
            If cobCountSort(j).ListIndex = 0 Then
                If chkCountSort(j).Value Then sSql = sSql & "distinct "
            End If
            sSql = sSql & Trim(Left(cobCount(j).Text, Len(cobCount(j).Text) - 50)) & ")"
        End If
    Next j
    '构造sql语句
    sSql = "select " & sSql & " from " & tmpTableName
    If Not Trim(txtTxt.Text) = "" Then
        sSql = sSql & " where  " & RTrim(txtTxt.Text)
    End If
    sSql = sSql & " group by " & tmpSqlGroup & " order by " & tmpSqlGroup
    
    rsTmp.Open sSql, adoCn
    
    '初始化数组
    For j = 0 To iGroup
        aMyTotal(0, j) = "" '进行分组的项目
    Next j
    k = 0
    For j = 0 To 3
        If cobGroup(j).ListIndex > 0 Then
            aMyTotal(5, k) = chkGroupCount(j).Value  '进行统计的项目是否需要合计
            k = k + 1
        End If
    Next j
    
    sSql = "第一次"
    lstTj.Sorted = False
    lstTj.ListItems.Clear
    Do While Not rsTmp.EOF()
            '用数组进行累计，第0行存分组项的名称(每列一个分组项，最后一列总计);第1行-第4行累计（每行累计一个统计项）
            For k = iGroup - 1 To 0 Step -1 '每一个分组项

                For j = 1 To iCount  '每一个统计项
                    
                    If aMyTotal(0, k) <> rsTmp(k) And aMyTotal(5, k) Then
                        '添加小计
                        If aMyTotal(0, 0) <> "" Then '第一次进入时，第一行不添加小计
                            If j = 1 Then   'j<>1时，只添加统计项
                                If k = 0 Then
                                    Set lv = lstTj.ListItems.Add(, , "*小计[" & aMyTotal(0, 0) & "]")
                                Else
                                    Set lv = lstTj.ListItems.Add(, , aMyTotal(0, 0))
                                End If
                                For i = 1 To k - 1
                                    lv.ListSubItems.Add , , aMyTotal(0, i)
                                Next i
                                If k <> 0 Then lv.ListSubItems.Add , , "*小计[" & aMyTotal(0, k) & "]"
                                For i = k + 1 To iGroup - 1
                                    lv.ListSubItems.Add , , ""
                                Next i
                                lv.ListSubItems.Add , , aMyTotal(j, k)
                            Else
                                lv.ListSubItems.Add , , aMyTotal(j, k)
                            End If
                        End If
                        aMyTotal(j, k) = rsTmp(j + iGroup - 1)
                    Else
                        Select Case aMyTotal(j, 5)
                            Case "sum"
                                aMyTotal(j, k) = aMyTotal(j, k) + rsTmp(j + iGroup - 1)     '小计
                            Case "avg"
                                aMyTotal(j, k) = (aMyTotal(j, k) + rsTmp(j + iGroup - 1)) / 2   '小计
                            Case "max"
                                If aMyTotal(j, k) < rsTmp(j + iGroup - 1) Then aMyTotal(j, k) = rsTmp(j + iGroup - 1)   '小计
                            Case "min"
                                If aMyTotal(j, k) > rsTmp(j + iGroup - 1) Then aMyTotal(j, k) = rsTmp(j + iGroup - 1)   '小计
                            Case Else
                                aMyTotal(j, k) = "统计错"
                        End Select
                                
                    End If
                    If k = 0 Then   '最后一个分组项时进行累计
                        If sSql = "第一次" Then
                            aMyTotal(j, iGroup) = rsTmp(j + iGroup - 1)     '第1条记录时先初始化累计项
                        Else
                            Select Case aMyTotal(j, 5)
                                Case "sum"
                                    aMyTotal(j, iGroup) = aMyTotal(j, iGroup) + rsTmp(j + iGroup - 1)      '总计
                                Case "avg"
                                    aMyTotal(j, iGroup) = (aMyTotal(j, iGroup) + rsTmp(j + iGroup - 1)) / 2    '总计
                                Case "max"
                                    If aMyTotal(j, iGroup) < rsTmp(j + iGroup - 1) Then aMyTotal(j, iGroup) = rsTmp(j + iGroup - 1)    '总计
                                Case "min"
                                    If aMyTotal(j, iGroup) > rsTmp(j + iGroup - 1) Then aMyTotal(j, iGroup) = rsTmp(j + iGroup - 1)    '总计
                                Case Else
                                    aMyTotal(j, iGroup) = "统计错"
                            End Select
                        End If
                    End If
                    
                Next j
   
            Next k
            
        '用数组的第0行记录需要进行合计的项目名称
        For j = 0 To iGroup - 1
            aMyTotal(0, j) = rsTmp(j)
        Next j
        
        '向列表框添加项
        Set lv = lstTj.ListItems.Add(, , IIf(IsNull(Trim(rsTmp(0))), "", Trim(rsTmp(0))))
        For i = 1 To rsTmp.Fields.count - 1
            lv.ListSubItems.Add , , IIf(IsNull(Trim(rsTmp(i))), "", Trim(rsTmp(i)))
        Next i
        rsTmp.MoveNext
        sSql = "不是第一次了"
    Loop
    '添加小计（当eof时应该添加小计，但是已经出循环）
    For k = iGroup - 1 To 0 Step -1 '每一个分组项
        
        If aMyTotal(5, k) Then
            For j = 1 To iCount  '每一个统计项
                '添加小计
                 If j = 1 Then   'j<>1时，只添加统计项
                    If k = 0 Then
                        Set lv = lstTj.ListItems.Add(, , "*小计[" & aMyTotal(0, 0) & "]")
                    Else
                        Set lv = lstTj.ListItems.Add(, , aMyTotal(0, 0))
                    End If
                    For i = 1 To k - 1
                        lv.ListSubItems.Add , , aMyTotal(0, i)
                    Next i
                    If k <> 0 Then lv.ListSubItems.Add , , "*小计[" & aMyTotal(0, k) & "]"
                    For i = k + 1 To iGroup - 1
                        lv.ListSubItems.Add , , ""
                    Next i
                    lv.ListSubItems.Add , , aMyTotal(j, k)
                Else
                    lv.ListSubItems.Add , , aMyTotal(j, k)
                End If
            Next j
        End If
        
    Next k
    
    '添加总计
    Set lv = lstTj.ListItems.Add(, , "*总计：")
    For i = 1 To iGroup - 1
        lv.ListSubItems.Add , , ""
    Next i
    For i = 1 To iCount
        lv.ListSubItems.Add , , aMyTotal(i, iGroup)
    Next i
    rsTmp.Close
    
    Call SetListItemColor(lstTj, picList)
    
End Sub

Private Sub cmdExport_Click()
   '调出excel表格准备打印
    Dim i As Integer
    Dim j As Integer
    Dim ii As Integer
    Dim sRow As Integer
    Dim sCol As Integer
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Screen.MousePointer = 11
    
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    '页面设置
    With xlApp.ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .CenterFooter = "第 &P 页，共 &N 页"
        .RightFooter = ""
        .TopMargin = Application.InchesToPoints(0.708661417322835)
        .BottomMargin = Application.InchesToPoints(0.708661417322835)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
    End With
    
    'excel列格式设置
    
    '根据字段类型定每一列的文本还是数值
    For j = 1 To lstXs.ColumnHeaders.count
        If lstXs.ColumnHeaders(j).Tag = "|C" Then xlApp.Columns(j).NumberFormatLocal = "@"
    Next j
    
    With xlApp.Cells.Font
        .Name = "宋体"
        .Size = 11
    End With
    '第一行标题
    With xlApp.Rows(1).Font
        .Name = "宋体"
        .Size = 12
        .Bold = True
    End With
    
    '添加excel表头
    i = 1
    For j = 1 To lstXs.ColumnHeaders.count
        If j < 27 Then
                p = Chr(65 + j - 1) & i
            Else
                p = "A" & Chr(65 + j - 1 - 26) & i
        End If
        xlApp.Range(p).FormulaR1C1 = lstXs.ColumnHeaders(j).Text
    Next j
    
    '添加excel内容(从listview中取出)
    i = 2
    j = 0
    For ii = 1 To lstXs.ListItems.count
        p = Chr(65 + j) & i
        xlApp.Range(p).FormulaR1C1 = lstXs.ListItems(ii)
        For j = 1 To lstXs.ColumnHeaders.count - 1
            If j < 26 Then
                p = Chr(65 + j) & i
            Else
                p = "A" & Chr(65 + j - 26) & i
            End If
            xlApp.Range(p).FormulaR1C1 = lstXs.ListItems(ii).SubItems(j)
        Next j

        j = 0
        i = i + 1
    Next ii
    
    xlApp.Visible = True
    Set xlApp = Nothing
    Screen.MousePointer = vbDefault
End Sub

Private Sub cmdExportDirt_Click()
    Dim rsTmp As New ADODB.Recordset
    Screen.MousePointer = 11

    sSql = ""
    Dim myObjChk As Control
    For Each myObjChk In frmTjRs.Controls()
            If Left(myObjChk.Name, 8) = "chkField" Then
                If myObjChk.Value = 1 Then
                    If sSql <> "" Then sSql = sSql & ","
                    sSql = sSql & Trim(myObjChk.Caption)
                End If
            End If
    Next myObjChk
    If sSql = "" Then
        MsgBox "请选择你想要导出的项目(字段)"
        Screen.MousePointer = vbDefault
        Exit Sub
    End If
    
    sSql = "select " & sSql & " from " & tmpTableName
    If Not Trim(txtTxt.Text) = "" Then sSql = sSql & " where  " & RTrim(txtTxt.Text)
    If Not Trim(txtTxtOrder.Text) = "" Then sSql = sSql & " order by  " & RTrim(txtTxtOrder.Text)
        
    With rsTmp
        .ActiveConnection = adoCn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = sSql
        .Open
    End With
  
   If rsTmp.RecordCount = 0 Then
        MsgBox "没有需要导出的数据"
        Screen.MousePointer = vbDefault
        rsTmp.Close
        Exit Sub
    End If
   
   '调出excel表格准备打印
    Dim i As Integer
    Dim j As Integer
    Dim ii As Integer
    Dim sRow As Integer
    Dim sCol As Integer
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    Screen.MousePointer = 11
        
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    '页面设置
    With xlApp.ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .CenterFooter = "第 &P 页，共 &N 页"
        .RightFooter = ""
        .TopMargin = Application.InchesToPoints(0.708661417322835)
        .BottomMargin = Application.InchesToPoints(0.708661417322835)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
    End With
    
    
    
    'excel列格式设置
    With xlApp.Cells.Font
        .Name = "宋体"
        .Size = 11
    End With
    '第一行标题为粗体
    With xlApp.Rows(1).Font
        .Name = "宋体"
        .Size = 12
        .Bold = True
    End With
    
    Set xlQuery = xlSheet.QueryTables.Add(rsTmp, xlApp.Range("A1"))
    With xlQuery
        .FieldNames = True
        .RowNumbers = True
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With

    xlQuery.Refresh

    rsTmp.Close
    xlApp.Visible = True
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Screen.MousePointer = vbDefault
    
End Sub

Private Sub cmdExpTj_Click()
   '调出excel表格准备打印
    Dim i As Integer