frmtjrsfrm.frm

vb源代码

    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 lstTj.ColumnHeaders.count
        If InStr(1, lstTj.ColumnHeaders(j).Text, "(", vbTextCompare) = 0 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 lstTj.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 = lstTj.ColumnHeaders(j).Text

    Next j
    
    '添加excel内容(从listview中取出)
    i = 2
    j = 0
    For ii = 1 To lstTj.ListItems.count
        p = Chr(65 + j) & i
        xlApp.Range(p).FormulaR1C1 = lstTj.ListItems(ii)
       '字体设计
        If Left(xlApp.Range(p).FormulaR1C1, 3) = "*小计" Or Left(xlApp.Range(p).FormulaR1C1, 3) = "*总计" Then
            With xlApp.Rows(i).Font
                .Name = "宋体"
                .Size = 12
                .Bold = True
            End With
        End If
        For j = 1 To lstTj.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 = lstTj.ListItems(ii).SubItems(j)
            '字体设计
            If Left(xlApp.Range(p).FormulaR1C1, 3) = "*小计" Or Left(xlApp.Range(p).FormulaR1C1, 3) = "*总计" Then
                With xlApp.Rows(i).Font
                    .Name = "宋体"
                    .Size = 12
                    .Bold = True
                End With
            End If
        Next j

        j = 0
        i = i + 1
    Next ii
    '打印格式设置
    
    xlApp.Visible = True
    Set xlApp = Nothing
    Screen.MousePointer = vbDefault
End Sub

Private Sub cmdOr_Click()
    Dim tmpTxt As String
    Dim tmpTxtOf As String
    tmpTxt = cobTxt.Text
    If tmpTxt = "" Then
        MsgBox ("请选择或输入要查找的内容")
        Exit Sub
    End If
    If cobOperator.Text = "like" Then tmpTxt = "%" & tmpTxt & "%"
    If Not txtTxt.Text = "" Then
        txtTxt.Text = txtTxt.Text & " Or "
    End If
    txtTxt.Text = txtTxt.Text & Trim(Left(cobField.Text, Len(cobField.Text) - 50))
    txtTxt.Text = txtTxt.Text & " " & Trim(cobOperator.Text) & " "
    Select Case Right(cobField.Text, 1)
        Case "C"
            tmpTxtOf = "'"
        Case "N"
            tmpTxtOf = ""
        Case Else
            tmpTxtOf = ""
    End Select
    txtTxt.Text = txtTxt.Text & tmpTxtOf & tmpTxt & tmpTxtOf
End Sub

Private Sub cmdQuery_Click()
    Dim rsTmp As New ADODB.Recordset
    Dim i As Integer

    Screen.MousePointer = 11
    If Trim(txtTxt.Text) = "" Then
        sSql = "请指定查询条件！" & Chr(13) & Chr(13) & "如果不指定查询条件，记录数会很多，"
        sSql = sSql & Chr(13) & Chr(13) & "这样会导致结果需要很长时间才能出来，"
        sSql = sSql & Chr(13) & Chr(13) & "如果只是为了统计或导出数据，你可以终止查询，直接进行统计或导出即可！"
        sSql = sSql & Chr(13) & Chr(13) & "确定要列出所有记录吗？"
        If MsgBox(sSql, vbDefaultButton2 + vbExclamation + vbYesNo, "提示信息...") = vbNo Then
            Screen.MousePointer = vbDefault
            Exit Sub
        End If
    End If
    
    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)
        
    rsTmp.Open sSql, adoCn, adOpenKeyset, adLockBatchOptimistic, adCmdText
    If rsTmp.RecordCount > 5000 Then
        sSql = "你共查询到 " & rsTmp.RecordCount & " 条记录"
        sSql = sSql & Chr(13) & Chr(13) & "需要等相对长的时间才能看到查询结果"
        sSql = sSql & Chr(13) & Chr(13) & "如果只是为了统计或导出数据，你可以终止查询，直接进行统计或导出即可！"
        sSql = sSql & Chr(13) & Chr(13) & "你确定要继续进行查询吗？"
        If MsgBox(sSql, vbInformation + vbDefaultButton2 + vbYesNo, "提示信息") = vbNo Then
            rsTmp.Close
            Screen.MousePointer = vbDefault
            Exit Sub
        End If
    End If
    
    labQueryR.Caption = "记录数： " & rsTmp.RecordCount
    frameQuery(3).ZOrder 0          '转到查询页面
    frameQuery(3).Refresh
    
    '添加表头
    lstXs.ColumnHeaders.Clear
    For i = 0 To rsTmp.Fields.count - 1
        lstXs.ColumnHeaders.Add , , RTrim(rsTmp.Fields(i).Name), IIf(rsTmp.Fields(i).DefinedSize * 200 < 3000, rsTmp.Fields(i).DefinedSize * 200, 1400)
        '用columnheaders的tag来标志数据的类型是否是字符型
        Select Case rsTmp.Fields(i).Type
            Case 129
                lstXs.ColumnHeaders(i + 1).Tag = "|C"
            Case 200
                lstXs.ColumnHeaders(i + 1).Tag = "|C"
            Case 131
                lstXs.ColumnHeaders(i + 1).Tag = "|N"
            Case 3
                lstXs.ColumnHeaders(i + 1).Tag = "|N"
            Case 131
                lstXs.ColumnHeaders(i + 1).Tag = "|X"
        End Select
    Next i
    '添加内容
    lstXs.Sorted = False
    lstXs.ListItems.Clear
    Do While Not rsTmp.EOF()
        Set lv = lstXs.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
    Loop
    rsTmp.Close
    Screen.MousePointer = vbDefault
End Sub

Private Sub cmdSelectAll_Click()
    Dim myObjChk As Control
     For Each myObjChk In frmTjRs.Controls()
            If Left(myObjChk.Name, 8) = "chkField" Then myObjChk.Value = 1
     Next myObjChk
End Sub

Private Sub cmdSelectNoAll_Click()
    Dim myObjChk As Control
     For Each myObjChk In frmTjRs.Controls()
            If Left(myObjChk.Name, 8) = "chkField" Then myObjChk.Value = 0
     Next myObjChk
End Sub

Private Sub cobCount_Click(Index As Integer)
    cobCountSort_Click (Index)
End Sub

Private Sub cobCountSort_Click(Index As Integer)
    chkCountSort(Index).Enabled = False
    If cobCount(Index).ListIndex < 1 Then cobCountSort(Index).ListIndex = 0
    If Right(cobCount(Index).Text, 1) <> "N" And cobCountSort(Index).ListIndex <> 0 Then
       MsgBox ("对字符串只能进行计数功能！")
       cobCountSort(Index).ListIndex = 0
    End If
    If cobCountSort(Index).ListIndex = 0 Then chkCountSort(Index).Enabled = True
End Sub

Private Sub Command1_Click()

End Sub

Private Sub Form_Load()
    Left = (Screen.Width - Width) / 2
    Top = (Screen.Height - Height) / 2
    Dim rsTmp As New ADODB.Recordset
    Dim i As Integer
    Dim j As Integer
    
    ' 挑出一条记录，为了取得字段名
    sSql = "select top 1 " & tmpStrSqlField & tmpStrSqlTable
    rsTmp.Open sSql, adoCn, adOpenKeyset, adLockBatchOptimistic, adCmdText
    
    '添加列表框中的值
    For j = 0 To 3
        cobGroup(j).AddItem "不分组"
        cobCount(j).AddItem "不进行统计"
        cobCountSort(j).AddItem "计数" & Space(50) & "count"
        cobCountSort(j).AddItem "求和" & Space(50) & "sum"
        cobCountSort(j).AddItem "平均值" & Space(50) & "avg"
        cobCountSort(j).AddItem "最大值" & Space(50) & "max"
        cobCountSort(j).AddItem "最小值" & Space(50) & "min"
    Next j
    
    
    For i = 0 To rsTmp.Fields.count - 1
        '取得字段类型，我是基于SQL SERVER做的，如果要联接其它类型的数据库，请更改
        Select Case rsTmp.Fields(i).Type
            Case 129
                sSql = "|C"
            Case 200
                sSql = "|C"
            Case 131
                sSql = "|N"
            Case 3
                sSql = "|N"
            Case 131
                sSql = "|N"
            Case Else
                sSql = "|C"
        End Select
        '填充制定查询条件的cob框
        cobField.AddItem RTrim(rsTmp.Fields(i).Name) & Space(50) & sSql
        '填充统计用的cob框
        For j = 0 To 3
            cobGroup(j).AddItem RTrim(rsTmp.Fields(i).Name) & Space(50) & sSql
            cobCount(j).AddItem RTrim(rsTmp.Fields(i).Name) & Space(50) & sSql
        Next j
        '动态生成chk对象，供字段选择
        Set chk = Controls.Add("VB.checkbox", "chkField" & i, frameQuery(1))
        With chk
            .Visible = True
            .Width = 2000
            .Height = 375
            .Caption = RTrim(rsTmp.Fields(i).Name)
            .Top = 400 + (i Mod 16) * 400
            .Left = 400 + (i \ 16) * 2600
        End With
    Next i
    rsTmp.Close

    cobField.ListIndex = 0
    cobOperator.ListIndex = 0
    For j = 0 To 3
        cobCountSort(j).ListIndex = 0
    Next j
    
    On Error Resume Next
    '如果存在临时表，先删除
    sSql = " drop table " & tmpTableName
    adoCn.Execute sSql
    
    '生成临时表，以备查询用
    sSql = "select " & tmpStrSqlField
    sSql = sSql & " into " & tmpTableName & " "
    sSql = sSql & tmpStrSqlTable

    adoCn.Execute sSql
 
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    '如果存在临时表，先删除
    sSql = " drop table " & tmpTableName
    adoCn.Execute sSql
End Sub

Private Sub lstTj_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    lstTj.SortKey = ColumnHeader.Index - 1
    If lstTj.SortOrder = lvwAscending Then
        lstTj.SortOrder = lvwDescending
    Else
        lstTj.SortOrder = lvwAscending
    End If
    lstTj.Sorted = True
End Sub

Private Sub lstXs_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    lstXs.SortKey = ColumnHeader.Index - 1
    If lstXs.SortOrder = lvwAscending Then
        lstXs.SortOrder = lvwDescending
    Else
        lstXs.SortOrder = lvwAscending
    End If
    lstXs.Sorted = True
End Sub

Private Sub tabPage_Click()
    frameQuery(tabPage.SelectedItem.Index).ZOrder 0
End Sub


'设定 统计listview框 的颜色
Private Sub SetListItemColor(lv As ListView, picBg As PictureBox)

    Dim i As Integer

    Dim myItem As String

    picBg.BackColor = lv.BackColor

    lv.Parent.ScaleMode = vbTwips

    picBg.ScaleMode = vbTwips

    picBg.BorderStyle = vbBSNone

    picBg.AutoRedraw = True

    picBg.Visible = False

    

    picBg.Width = lv.Width

    picBg.Height = lv.ListItems(1).Height * (lv.ListItems.count)

    picBg.ScaleHeight = lv.ListItems.count

    picBg.ScaleWidth = 1

    picBg.DrawWidth = 1

    '-----------------------------

    '开始绘制图形，让*小计行不一样

    '------------------------------

    For i = 1 To lv.ListItems.count
        For j = 0 To 2
            If j = 0 Then
                myItem = lv.ListItems(i)
            Else
                myItem = lv.ListItems(i).SubItems(j)
            End If

            If Left(myItem, 3) = "*小计" Then
    
                Select Case j
                    Case 0
                        picBg.Line (0, i - 1)-(1, i), vbMagenta, BF
                    Case 1
                        picBg.Line (0, i - 1)-(1, i), vbMagenta, BF
                    Case 2
                        picBg.Line (0, i - 1)-(1, i), vbMagenta, BF
                End Select
    
            End If
        Next j

    Next i
 
    lv.Picture = picBg.Image

End Sub