dlgqueryresult.frm

来自「通用书店管理系统」· FRM 代码 · 共 1,356 行 · 第 1/3 页

        End If
    End If
    Me.Hide
    
End Sub

Private Sub cmdFindClose_Click()
    Me.Hide
End Sub

Private Sub cmdFindFind_Click()
    '查找
    Dim row&, Col&
    
    If Me.cboFindFashion.Text = "全部" Then
        If frmQR.fg.Cols = 1 Then
            MsgBox "没有数据可查找！"
            Exit Sub
        End If
        
        For Col = lngFindBeginColumn To frmQR.fg.Cols - 1
            If Col > lngFindBeginColumn Then frmQR.fg.row = frmQR.fg.FixedRows - 1
            row = frmQR.fg.FindRow(Me.txtFindContent.Text, frmQR.fg.RowSel + 1, Col, Me.chkFindUcase.Value, Me.chkFindMatch)
            If row <> -1 Then
                Call frmQR.fg.Select(row, Col)
                frmQR.fg.row = row
                lngFindBeginColumn = Col
                Exit For
            Else
                If Col = frmQR.fg.Cols - 1 Then
                    If MsgBox("要从头开始查找吗？", vbYesNo, "查找") = vbYes Then
                        lngFindBeginColumn = 1
                        Call cmdFindFind_Click
                    End If
                End If
            End If
         Next Col
    Else
        If frmQR.fg.row < frmQR.fg.Rows - 1 Then
            row = frmQR.fg.FindRow(CStr(Me.txtFindContent.Text), frmQR.fg.RowSel + 1, frmQR.fg.ColSel, Me.chkFindUcase.Value, Me.chkFindMatch)
            If row <> -1 Then
                frmQR.fg.row = row
            Else
                MsgBox "搜索完毕，没有发现满足条件的数据！"
                Exit Sub
            End If
        ElseIf frmQR.fg.Rows <= 1 Then
            MsgBox "没有数据！"
            Exit Sub
        Else
            If MsgBox("要从首行开始搜索吗？", vbYesNo, "搜索") = vbYes Then
                frmQR.fg.row = frmQR.fg.FixedRows - 1
                Call cmdFindFind_Click
            Else
                Exit Sub
            End If
        End If
    End If
End Sub

Private Sub cmdGroupAddAll_Click()
    '全部加入
    Dim i%
    
    lstGroupView.Clear
    For i = 0 To lstGroupAll.ListCount - 1
        lstGroupView.AddItem Trim(lstGroupAll.List(i))
    Next i
End Sub

Private Sub cmdGroupAddOne_Click()
    '从项目清单中添加一个选项到显示项目中
    Dim i%
    
    If Me.lstGroupAll.ListCount = 0 Then Exit Sub
    If lstGroupAll.ListIndex = -1 Then Exit Sub
    
    For i = 0 To lstGroupView.ListCount - 1
        If Trim(lstGroupView.List(i)) = Trim(lstGroupAll.List(lstGroupAll.ListIndex)) Then
            Exit For
        End If
    Next i
    
    If i = lstGroupView.ListCount Then
        lstGroupView.AddItem Trim(lstGroupAll.List(lstGroupAll.ListIndex))
    End If
    
End Sub

Private Sub cmdGroupCancel_Click()
    Me.Hide
End Sub

Private Sub cmdGroupDown_Click()
    '向下排序
    If lstGroupView.ListIndex = -1 Then Exit Sub
    
    Dim str$, i%
    i = lstGroupView.ListIndex
    str = lstGroupView.List(lstGroupView.ListIndex)
    
    If i <> lstGroupView.ListCount - 1 Then
        lstGroupView.RemoveItem (lstGroupView.ListIndex)
        lstGroupView.AddItem str, i + 1
        lstGroupView.Selected(i + 1) = True
    End If
    
End Sub

Private Sub cmdGroupOK_Click()
    '自定义分组
    Dim i%
    
    frmQR.fg.MergeCells = flexMergeNever
    
    frmQR.fg.MergeCol(-1) = False
    
    If Me.lstGroupView.ListCount > 0 Then
        frmQR.fg.MergeCells = flexMergeRestrictRows
        For i = 0 To Me.lstGroupView.ListCount - 1
            frmQR.fg.ColPosition(getColPosByKey(Val(Me.lstGroupView.List(i)))) = i + 1
            frmQR.fg.MergeCol(getColPosByKey(Val(Me.lstGroupView.List(i)))) = True
        Next i
    End If
    
    
    Call frmQR.fg.Select(1, 1, frmQR.fg.Rows - 1, Me.lstGroupView.ListCount)
    
    frmQR.fg.Sort = flexSortGenericAscending
    
    Me.Hide
    
End Sub

Private Sub cmdGroupRemoveAll_Click()
    '清空
    lstGroupView.Clear
End Sub

Private Sub cmdGroupRemoveOne_Click()
    '移除一个
    If lstGroupView.ListCount = 0 Then Exit Sub
    If lstGroupView.ListIndex <> -1 Then lstGroupView.RemoveItem (lstGroupView.ListIndex)
End Sub

Private Sub cmdGroupUp_Click()
        '向上排序
    If lstGroupView.ListIndex = -1 Then Exit Sub
    
    Dim str$, i%
    i = lstGroupView.ListIndex
    str = lstGroupView.List(lstGroupView.ListIndex)
    
    If i <> 0 Then
        lstGroupView.RemoveItem (lstGroupView.ListIndex)
        lstGroupView.AddItem str, i - 1
        lstGroupView.Selected(i - 1) = True
    End If
    
End Sub

'列头预处理
Private Function getBareHeader(strColHeader As String) As String
    '把列头去掉空格和换行符
    strColHeader = Trim(strColHeader)
    strColHeader = Replace(strColHeader, Chr(10), "")
    strColHeader = Replace(strColHeader, Chr(13), "")
    getBareHeader = strColHeader
    
End Function

Private Sub cmdHeaderCancel_Click()
    Me.Hide
End Sub

Private Sub cmdHeaderOK_Click()
    '列头定义
    
    Dim strBefore$, strBack$    '存放临时标题切分后的前后字符串
    Dim intArrNum               '存放分行设置的个数
    Dim iRows%                  '存放每个标题的分行数
    Dim iMaxRows%               '存放标题的最大分行数
    Dim i%, j%
    
    If Trim(Me.txtHeaderWrap.Text) <> "" Then

        iMaxRows = 1 '最大分行数初始化为1

        txtHeaderWrap.Text = Replace(txtHeaderWrap.Text, "，", ",")     '逗号统一
        intArrNum = Split(txtHeaderWrap.Text, ",")

        '检测输入数据合法性
        For j = 0 To UBound(intArrNum)
            If Not IsNumeric(intArrNum(j)) Then
                MsgBox "列头分行输入数据不合法！", vbInformation, "提示"
                Exit Sub
            End If
        Next j

        '进行逐个单列处理
        For i = 0 To frmQR.fg.Cols - 1
            iRows = 1
            strBefore = ""
            strBack = getBareHeader(frmQR.fg.Cell(flexcpText, frmQR.fg.FixedRows - 1, i))
            For j = 0 To UBound(intArrNum)
                If Len(strBack) > intArrNum(j) And intArrNum(j) > -1 Then
                    strBefore = strBefore + Left(strBack, intArrNum(j)) & Chr(13) & Chr(10)
                    strBack = Mid(strBack, intArrNum(j) + 1)
                    iRows = iRows + 1
                    If iRows > iMaxRows Then iMaxRows = iRows   '把所有列中最大行数放入iMaxRows
                End If
            Next j
            frmQR.fg.Cell(flexcpText, frmQR.fg.FixedRows - 1, i) = strBefore & strBack
        Next i

        frmQR.fg.RowHeight(0) = iMaxRows * Me.TextHeight("A") + 100     '行比例调整
    Else
        For i = 0 To frmQR.fg.Cols - 1
            frmQR.fg.Cell(flexcpText, frmQR.fg.FixedRows - 1, i) = getBareHeader(frmQR.fg.Cell(flexcpText, frmQR.fg.FixedRows - 1, i))
        Next i
    End If
    
    Me.Hide
End Sub

Private Sub cmdLocateCancle_Click()
    Me.Hide
End Sub

Private Sub cmdLocateOK_Click()
    '定位
    If Not IsNumeric(Me.txtLocateCol.Text) Then MsgBox "输入数据不合法！": Exit Sub
    If Not IsNumeric(Me.txtLocateRow.Text) Then MsgBox "输入数据不合法！": Exit Sub
    
    If Me.txtLocateCol.Text < 1 Or Me.txtLocateCol.Text > frmQR.fg.Cols - 1 Then _
        MsgBox "输入列值超出范围！": Exit Sub
    If Me.txtLocateCol.Text < 1 Or Me.txtLocateRow.Text > frmQR.fg.Cols - 1 Then _
        MsgBox "输入行值超出范围！": Exit Sub
        
    Call frmQR.fg.Select(Val(Me.txtLocateRow.Text), Val(Me.txtLocateCol.Text))
    
    Me.Hide
End Sub

Private Sub cmdSubtotalCancel_Click()
    Me.Hide
End Sub

'取颜色函数
Public Function iForeColor(ByVal intIndex As Long) As Long
    intIndex = intIndex Mod 6
    Select Case intIndex
    Case 0 '红色
        iForeColor = &HFF
    Case 1 '兰色
        iForeColor = &HFF0000
    Case 2 '洋红
        iForeColor = &HFF00FF
    Case 3 '青色
        iForeColor = &HFFFF00
    Case 4 '黄色
        iForeColor = &HFFFF
    Case 5 '绿色
        iForeColor = &HFF00
    End Select
End Function

'汇总函数
Private Sub SetSubtotal(ByVal lngFunction As Long, ByVal lngLstIndex As Long, strCaption As String)
    Dim j%
    If Me.chkSubtotalGroup.Value = vbChecked Then
        For j = 0 To Me.lstGroupView.ListCount - 1
            Call frmQR.fg.Subtotal(Function:=lngFunction, GroupOn:=getColPosByKey(Val(Me.lstGroupView.List(j))), _
                TotalOn:=getColPosByKey(Val(Me.lstSubtotalVer.List(lngLstIndex))), _
                ForeColor:=iForeColor(j)) ', Caption:="小组" & strCaption)
        Next j
    End If
    Call frmQR.fg.Subtotal(Function:=lngFunction, GroupOn:=-1, _
        TotalOn:=getColPosByKey(Val(Me.lstSubtotalVer.List(lngLstIndex))), _
        ForeColor:=vbRed) ', Caption:="总计" & strCaption)

End Sub

Private Sub cmdSubtotalOK_Click()
    '汇总
    
    On Error Resume Next        '有数据出错不处理
    
    Dim i%, j%
    
    '-----------纵向汇总
    Call frmQR.fg.Subtotal(flexSTClear)
    For i = 0 To Me.lstSubtotalVer.ListCount - 1
        
        Select Case Trim(Me.cboSubtotalVer.List(Me.lstSubtotalVer.ItemData(i) - 1)) '在ItemData中存放的是cboSubtotalVer索引减1的值
        Case "求和"
            Call SetSubtotal(flexSTSum, i, "求和")
        
        Case "均值"
            Call SetSubtotal(flexSTAverage, i, "均值")
        
        Case "计数"
            Call SetSubtotal(flexSTCount, i, "计数")
            
        Case "最大值"
            Call SetSubtotal(flexSTMax, i, "最大值")
        
        Case "最小值"
            Call SetSubtotal(flexSTMin, i, "最小值")
            
        Case "百分率"
            Call SetSubtotal(flexSTPercent, i, "百分率")
            
        Case "标准偏差"
            Call SetSubtotal(flexSTStd, i, "标准偏差")
            
        Case "方差"
            Call SetSubtotal(flexSTVar, i, "方差")
            
        End Select
    Next i
    
    '----------横向汇总
    
    Dim sum As Double
    Dim sumCols As Integer
    Dim row As Long
        
    Select Case Trim(Me.cboSubtotalHor.Text)
    Case "求和"
        For i = 0 To Me.lstSubtotalHor.ListCount - 1
            If Me.lstSubtotalHor.Selected(i) Then
                sumCols = sumCols + 1
            End If
        Next i
               
        If sumCols > 0 Then
            '插入一列和相应关键字
            frmQR.fg.Cols = frmQR.fg.Cols + 1
            frmQR.lngColKey = frmQR.lngColKey + 1
            frmQR.fg.ColKey(frmQR.fg.Cols - 1) = frmQR.lngColKey
            frmQR.fg.Cell(flexcpText, 0, frmQR.fg.Cols - 1) = "求和"
            
            For row = frmQR.fg.FixedRows To frmQR.fg.Rows - 1
                sum = 0
                For i = 0 To Me.lstSubtotalHor.ListCount - 1
                    If Me.lstSubtotalHor.Selected(i) Then
                        sumCols = sumCols + 1
                        sum = sum + CDbl(frmQR.fg.Cell(flexcpValue, row, getColPosByKey(Val(Me.lstSubtotalHor.List(i)))))
                    End If
                Next i
                frmQR.fg.Cell(flexcpText, row, frmQR.fg.Cols - 1) = sum
            Next row
        End If
        
    Case "均值"
        For i = 0 To Me.lstSubtotalHor.ListCount - 1
            If Me.lstSubtotalHor.Selected(i) Then
                sumCols = sumCols + 1
            End If
        Next i
               
        If sumCols > 0 Then
            '插入一列和相应关键字
            frmQR.fg.Cols = frmQR.fg.Cols + 1
            frmQR.lngColKey = frmQR.lngColKey + 1
            frmQR.fg.ColKey(frmQR.fg.Cols - 1) = frmQR.lngColKey
            frmQR.fg.Cell(flexcpText, 0, frmQR.fg.Cols - 1) = "均值"
            
            For row = frmQR.fg.FixedRows To frmQR.fg.Rows - 1
                sum = 0
                For i = 0 To Me.lstSubtotalHor.ListCount - 1
                    If Me.lstSubtotalHor.Selected(i) Then
                        sumCols = sumCols + 1
                        sum = sum + CDbl(frmQR.fg.Cell(flexcpValue, row, getColPosByKey(Val(Me.lstSubtotalHor.List(i)))))
                    End If
                Next i
                sum = sum / sumCols
                frmQR.fg.Cell(flexcpValue, row, frmQR.fg.Cols - 1) = sum
            Next row
        End If
    
    End Select
    
    Me.Hide
    Exit Sub
    
End Sub

Private Sub Form_Load()
    
    Call iniControls    '初始化控件
    
End Sub

Public Sub ShowSetup(strTitle As String)
    Dim var
    
    For Each var In Me.Controls
        If TypeName(var.Container) = Me.Name Then
            If var.Caption <> ">> " & Trim(strTitle) Then
                var.Visible = False
            Else
                var.Visible = True
                Me.Top = frmQR.Top + 1500
                Me.Width = var.Width + 200
                Me.Height = var.Height + 550
                var.Move 50, 100
            End If
        End If
    Next
    
'    Select Case Trim(strTitle)
'    Case "查找"
'
'    Case "替换"
'
'    Case "定位"
'
'    Case "自定义分组"
'
'    Case "表格运算"
'
'    Case "汇总"
'
'    Case "列头定义"
'
'    End Select
    
    Call iniControls
    
    Me.ZOrder (0)
    Me.Show vbModal
    
End Sub

Private Function getColPosByKey(strKey As String) As Long
    If frmQR.fg.Cols = 0 Then getColPosByKey = -1: Exit Function
    
    Dim i%
    For i = 0 To frmQR.fg.Cols - 1
        If frmQR.fg.ColKey(i) = strKey Then
            getColPosByKey = i
            Exit Function
        End If
    Next i
    
    getColPosByKey = -1
    
End Function