frmqueryresult.frm

通用书店管理系统

    
    fg.Rows = fg.Rows + 1
    Call setStatusBar
    
    
End Sub

Public Sub Insert_Column_Click()
    '插入列
    fg.Cols = fg.Cols + 1
    lngColKey = lngColKey + 1
    fg.ColKey(fg.Cols - 1) = lngColKey + 1
    
    fg.ColPosition(fg.Cols - 1) = fg.ColSel
    
End Sub

Private Sub Insert_PicturePaste_Click()
    '粘贴图片
    
    
End Sub

Private Sub Insert_Row_Click()
    '插入行
    fg.AddItem "", fg.RowSel
    
    Call setStatusBar
    
End Sub

Private Sub View_AutoSizeColumn_Click()
    '自动调整列宽
    Me.fg.AutoSizeMode = flexAutoSizeColWidth
    If Me.fg.Cols <= 1 Then Exit Sub
    Call Me.fg.AutoSize(1, fg.Cols - 1)
    
End Sub

Private Sub View_AutoSizeColumnSingle_Click()
    '单列调整列宽
    Me.fg.AutoSizeMode = flexAutoSizeColWidth
    If Me.fg.Cols <= 1 Then Exit Sub
    Call Me.fg.AutoSize(fg.ColSel)
    
End Sub

Private Sub View_AutoSizeRow_Click()
    '自动调整行高
    
    If Me.View_AutoSizeRow.Checked = False Then
        With fg
            .AutoSizeMode = flexAutoSizeRowHeight
            .WordWrap = True
            Call .AutoSize(1, fg.Cols - 1)
        End With
        Me.View_AutoSizeRow.Checked = True
    Else
        fg.WordWrap = False
        fg.AutoResize = False
        Me.View_AutoSizeRow.Checked = False
    End If

End Sub

Private Sub View_HeaderCustom_Click()
    dlg.ShowSetup ("列头定义")
End Sub

Private Sub View_NodeExtend_Click()
    '节点展开
    Dim nd As VSFlexNode
    Dim row&
    On Error GoTo Err
    
    If Me.fg.OutlineBar = flexOutlineBarComplete Then
        For row = fg.FixedRows To fg.Rows - 1
            Set nd = Me.fg.GetNode(row)
            nd.Expanded = True
        Next row
    Else
        GoTo Err
    End If
    
    Exit Sub
Err:
    MsgBox "节点展开失败，请确认是否已进行汇总且在树型结构模式下。"
End Sub

Private Sub View_NodeShrink_Click()
    '节点收缩
    Dim nd As VSFlexNode
    Dim row&
    
    On Error GoTo Err
    
    If Me.fg.OutlineBar = flexOutlineBarComplete Then
        If Me.fg.ColWidth(Me.fg.OutlineCol) = 0 Then GoTo Err
        For row = fg.FixedRows To fg.Rows - 1
            Set nd = Me.fg.GetNode(row)
            nd.Expanded = False
        Next row
    Else
        GoTo Err
    End If
    
    Exit Sub
Err:
    MsgBox "节点收缩失败，请确认是否已进行汇总且在树型结构模式下。"
End Sub

Private Sub View_NormalView_Click()
    '普通显示
    Me.fg.FixedCols = 0
    Me.fg.FixedCols = 1
    Me.fg.ColWidth(0) = 0
    
    'Me.fg.SubtotalPosition = flexSTBelow
    Me.fg.OutlineBar = flexOutlineBarNone
    
End Sub

Private Sub View_TreeView_Click()
    '树型显示
    
    Dim i&
    
    Call Me.fg.Select(0, 0, fg.Rows - 1, 0)
    Call Me.fg.Clear(flexClearSelection, flexClearText)
    Me.fg.ColWidth(0) = 0
    
    'Me.fg.SubtotalPosition = flexSTAbove
    Me.fg.OutlineBar = flexOutlineBarComplete
    If Me.fg.ColWidth(Me.fg.OutlineCol) = 0 Then
        MsgBox "请确认是否已基于自定义分组进行了相关汇总！"
        Me.fg.OutlineBar = flexOutlineBarNone
    End If
    
    Me.Edit_Number.Checked = False
End Sub

Private Sub setStatusBar()
    Me.sb.Panels(2).Text = "记录数: " & fg.Rows - 1
End Sub

Private Sub PreExcute()
    Dim i%, j%
    
    On Error GoTo Err
    
    '处理分组
    If Not IsEmpty(arrGroup) Then
        For i = 0 To UBound(arrGroup)
            With fg
                .ColSort(getColPosByKey(arrGroup(i))) = flexSortGenericAscending
                .ColPosition(getColPosByKey(arrGroup(i))) = i + 1
            End With
        Next i
        Call fg.Select(fg.FixedRows, 1, fg.Rows - 1, UBound(arrGroup) + 1)
        fg.Sort = flexSortUseColSort
        
        fg.MergeCells = flexMergeRestrictRows
        
        For i = 1 To UBound(arrGroup) + 1
            fg.MergeCol(i) = True
        Next i
        
        fg.Col = 1
        
    End If
    
    '处理排序
    If Not IsEmpty(arrSort) Then
        For i = 0 To UBound(arrSort)
            With fg
                .ColSort(getColPosByKey(arrSort(i))) = flexSortGenericAscending
                If Not IsEmpty(arrGroup) Then
                    .ColPosition(getColPosByKey(arrSort(i))) = UBound(arrGroup) + i + 2
                Else
                    .ColPosition(getColPosByKey(arrSort(i))) = i + 1
                End If
            End With
        Next i
        
        If Not IsEmpty(arrGroup) Then
            Call fg.Select(fg.FixedRows, 1, fg.Rows - 1, UBound(arrSort) + UBound(arrGroup) + 2)
        Else
            Call fg.Select(fg.FixedRows, 1, fg.Rows - 1, UBound(arrSort) + 1)
        End If
        
        fg.Sort = flexSortUseColSort
        
        If Not IsEmpty(arrGroup) Then
            For i = 1 To fg.Cols - 1
                For j = i To fg.Cols - 1
                    If Val(fg.ColKey(j)) = i Then
                        fg.ColPosition(j) = i
                    End If
                Next j
            Next i
            
            For i = 0 To UBound(arrGroup)
                fg.ColPosition(getColPosByKey(arrGroup(i))) = i + 1
            Next i
        Else
            For i = 1 To fg.Cols - 1
                For j = i To fg.Cols - 1
                    If Val(fg.ColKey(j)) = i Then
                        fg.ColPosition(j) = i
                    End If
                Next j
            Next i
        End If
        fg.Col = 1
        
    End If
    
    '处理汇总
    If Not IsEmpty(Me.arrSubtotal) Then
        For i = 0 To UBound(arrSubtotal, 1)
            If Trim(arrSubtotal(i, 1)) <> "" Then
                Call fg.Subtotal(Function:=arrSubtotal(i, 0), GroupOn:=getColPosByKey(arrSubtotal(i, 1)), TotalOn:=getColPosByKey(arrSubtotal(i, 2)), ForeColor:=dlg.iForeColor(i))
            Else
                Call fg.Subtotal(Function:=arrSubtotal(i, 0), TotalOn:=getColPosByKey(arrSubtotal(i, 2)), ForeColor:=dlg.iForeColor(i))
            End If
        Next i
    End If
        
    '处理自动列宽调整
    If Not IsEmpty(Me.arrResizeColWidth) Then
        For i = 0 To UBound(arrResizeColWidth)
            With fg
                .AutoSizeMode = flexAutoSizeColWidth
                .AutoSize (getColPosByKey(arrResizeColWidth(i)))
            End With
        Next i
    End If
    
    '处理自动行高调整
    If Not IsEmpty(Me.arrResizeRowHeight) Then
        For i = 0 To UBound(arrResizeRowHeight)
            With fg
                .AutoSizeMode = flexAutoSizeRowHeight
                .WordWrap = True
                .AutoSize (getColPosByKey(arrResizeRowHeight(i)))
            End With
        Next i
    End If
    
    Exit Sub
Err:
    MsgBox "信息设置有误", vbInformation, "警告"
    Resume Next
End Sub

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

Private Sub MergeHeader(strHeaderMerge As String)
    '列头合并,以|号作为组群分割符号
    If Trim(strHeaderMerge) = "" Then Exit Sub
        
    Call MergeHeaderColumn(strHeaderMerge)
    
    '替换空列头
    Dim i%, j%
    
'    If Me.fg.FixedRows <= 2 Then
'        For i = 1 To Me.fg.Cols - 1
'            For j = Me.fg.FixedRows - 2 To 0 Step -1
'                If Trim(Me.fg.Cell(flexcpText, j, i)) = "" Then
'                    Me.fg.Cell(flexcpText, j, i) = Me.fg.Cell(flexcpText, j + 1, i)
'                End If
'            Next j
'        Next i
'    End If
    
    '进行合并
        
    Me.fg.MergeCells = flexMergeFixedOnly
    
    For i = 0 To Me.fg.Cols - 1
        Me.fg.MergeCol(i) = True
    Next i
    
    For i = 0 To Me.fg.FixedRows - 1
        Me.fg.MergeRow(i) = True
    Next i
    

    
End Sub

Private Sub MergeHeaderColumn(strHeaderColumns As Variant)
    '以{}作为一组，以逗号作为分割符
    Dim i%, j%
    
    Dim start%  '标题开始位置
    Dim Bef%    '前括弧位置
    Dim Bck%    '后括弧位置
    
    Dim strSingle$  '单个合并列内容
    Dim strName     '列头名称
    Dim strColIndexs    '列索引
    Bck = InStr(1, strHeaderColumns, "}")
    If Bck = 0 Then Exit Sub      '递归结束条件
    Bef = InStrRev(strHeaderColumns, "{", Bck)
    
    For i = Bef - 1 To 1 Step -1
        If Mid(strHeaderColumns, i, 1) = "{" _
            Or Mid(strHeaderColumns, i, 1) = "}" _
            Or Mid(strHeaderColumns, i, 1) = "," Then
                
            start = i + 1: Exit For
                
        End If
    Next i
    
    If i = 0 Then start = 1 '如果一个都找不到，说明是第一个
    
    strSingle = Mid(strHeaderColumns, start, Bck - start + 1)
    strName = Mid(strHeaderColumns, start, Bef - start)
    strColIndexs = Mid(strHeaderColumns, Bef + 1, Bck - Bef - 1)
    
    Dim arrIndex
    arrIndex = Split(strColIndexs, ",")
    
    For i = Me.fg.FixedRows - 1 To 0 Step -1
        If Trim(Me.fg.Cell(flexcpText, i, CLng(arrIndex(0)))) = "" Then
            For j = CLng(arrIndex(0)) To CLng(arrIndex(UBound(arrIndex)))
                Me.fg.Cell(flexcpText, i, CLng(j)) = strName
            Next j
            Exit For
        End If
    Next i
    
    '如果固定行不够，则需新添一行
    If i = -1 Then
        Me.fg.FixedRows = Me.fg.FixedRows + 1
        
        '表头下移一行
        For i = 1 To Me.fg.Cols - 1
            For j = Me.fg.FixedRows - 1 To 0 Step -1
                If j = 0 Then
                    Me.fg.Cell(flexcpText, j, i) = ""
                Else
                    Me.fg.Cell(flexcpText, j, i) = Me.fg.Cell(flexcpText, j - 1, i)
                End If
            Next j
        Next i
        
        '设新列头内容
        For j = CLng(arrIndex(0)) To CLng(arrIndex(UBound(arrIndex)))
            Me.fg.Cell(flexcpText, 0, CLng(j)) = strName
        Next j
        
            
    End If
    
    '要求合并列从小到大排列
    strHeaderColumns = Replace(strHeaderColumns, strSingle, strColIndexs)
    
    Call MergeHeaderColumn(strHeaderColumns)
    
End Sub