frmcrossreport.frm

金算盘软件代码

       msgTitle.top = lngTitleTop
       msgAccount.top = msgTitle.top + mclsCross.ColColumns * 225
       msgAccount.Height = Me.Height - 1580 - mclsCross.ColColumns * 225
       LblTitle.Visible = True
   Else
       msgTitle.top = lngTitleTop - 250
       msgAccount.top = msgTitle.top + mclsCross.ColColumns * 225
       msgAccount.Height = Me.Height - 1600 + 250 - mclsCross.ColColumns * 225
       LblTitle.Visible = False
   End If
   LblTitle.Left = (msgAccount.Width - LblTitle.Width) \ 2
   msgAccount.Redraw = True
End Sub

'重置列宽
Private Sub ReSetColWidth()
Dim intCol  As Integer
    msgTitle.Redraw = False
    msgAccount.Redraw = False
    For intCol = 0 To msgTitle.Cols - 1
        msgAccount.ColWidth(intCol) = msgTitle.ColWidth(intCol)
    Next intCol
    msgTitle_Scroll
    msgTitle.Redraw = True
    msgAccount.Redraw = True
End Sub

Private Sub msgAccount_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton Then
         PopupMenu frmMain.mnuListEdit, , msgAccount.Left + x, msgAccount.top + y
    Else
    End If
End Sub

Private Sub msgAccount_Scroll()
    If msgTitle.LeftCol <> msgAccount.LeftCol Then
        msgTitle.LeftCol = msgAccount.LeftCol
    End If
    DealFormat
End Sub

Private Sub msgTitle_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton Then
         PopupMenu frmMain.mnuListEdit, , msgTitle.Left + x, msgTitle.top + y
    Else
    End If
End Sub

Private Sub msgTitle_Scroll()
    If msgTitle.LeftCol <> msgAccount.LeftCol Then
        msgAccount.LeftCol = msgTitle.LeftCol
    End If
End Sub

Public Function HiWord(ByVal l As Long) As Integer
    l = l And &H7FFF0000
    HiWord = l / &H10000
End Function

Public Function LoWord(ByVal l As Long) As Integer
    l = l And &H7FFF
    LoWord = l
End Function

'得到真实的 ColPos(intcol)
'说明： 当有单元合并时，FlexGrid 的属性 ColPos 返回的值不对
Private Function GetRealColPos(grdSource As MSFlexGrid, ByVal intCol As Integer) As Long
  Dim intCount As Integer
    With grdSource
        For intCount = 0 To intCol - 1
             If intCount < .FixedCols Or intCount >= .LeftCol Then
                If intCount = 0 Then
                   GetRealColPos = .ColPos(0) + .ColWidth(intCount)
                Else
                   GetRealColPos = GetRealColPos + .ColWidth(intCount)
                End If
             End If
        Next intCount
    End With
End Function

'msgTitle 的钩子响应程序
Private Sub mclsHook_OnMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCancel As Long)
    Dim lngX As Long
    Dim intCount As Integer
    Static blnColDrag As Boolean
    Static intCol As Integer

    bCancel = False

    If Msg = WM_LBUTTONUP Then           '鼠标左键放开
         If blnColDrag Then
             lngX = LoWord(lParam) * Screen.TwipsPerPixelX
             If lngX - GetRealColPos(msgTitle, intCol) > 90 Then
                 msgTitle.MergeCells = flexMergeNever
                 '得到改变后的列宽
                 msgTitle.ColWidth(intCol) = lngX - GetRealColPos(msgTitle, intCol)
                 If GetRealColPos(msgTitle, msgTitle.Cols) > msgAccount.Width - gclsEniv.VScrollWidth - 100 And _
                   GetRealColPos(msgTitle, msgTitle.Cols) < msgAccount.Width Then
                   msgTitle.ColWidth(msgTitle.Cols - 1) = msgAccount.Width - GetRealColPos(msgTitle, msgTitle.Cols - 1)
                 End If
                 ReSetColWidth
                 msgTitle.MergeCells = flexMergeRestrictColumns
                 ReleaseCapture
                 bCancel = True
                 Me.MousePointer = vbDefault
             Else
                 ReleaseCapture
                 bCancel = True
                 Me.MousePointer = vbDefault
                 msgTitle.Refresh
             End If
             blnColDrag = False
         End If
    End If

    If Msg = WM_LBUTTONDOWN Then        '鼠标左键按下
        blnColDrag = False
        lngX = LoWord(lParam) * Screen.TwipsPerPixelX
        With msgTitle
                bCancel = True
                For intCount = 0 To .Cols - 2
                    'Debug.Print intCount, "ColPos:", GetRealColPos(msgTitle, intCount), "ColWidth:", .ColWidth(intCount), "ColPos(intCount)+ColWidth:", GetRealColPos(msgTitle, intCount) + .ColWidth(intCount), lngX
                    If (intCount < .FixedCols Or intCount >= .LeftCol) And lngX >= GetRealColPos(msgTitle, intCount) And lngX <= GetRealColPos(msgTitle, intCount) + .ColWidth(intCount) Then
                        '判断鼠标是否点中列线以便拖动
                        If lngX >= GetRealColPos(msgTitle, intCount) + .ColWidth(intCount) - 30 _
                           And lngX <= GetRealColPos(msgTitle, intCount) + .ColWidth(intCount) + 30 Then
                            bCancel = False
                            blnColDrag = True
                            intCol = intCount
                        End If
                        mOldCol = intCount
                        Exit For
                    End If
                Next
                If lngX >= GetRealColPos(msgTitle, .Cols - 1) And lngX <= GetRealColPos(msgTitle, .Cols - 1) + .ColWidth(.Cols - 1) + 30 Then
                    '判断鼠标是否点中列线以便拖动
                    If lngX >= GetRealColPos(msgTitle, .Cols - 1) + .ColWidth(.Cols - 1) - 30 And lngX <= GetRealColPos(msgTitle, .Cols - 1) + .ColWidth(.Cols - 1) + 30 Then
                        'Debug.Print .Cols - 1, "ColPos:", GetRealColPos(msgTitle, .Cols - 1), "ColWidth:", .ColWidth(.Cols - 1), "ColPos(.Cols-1)+ColWidth:", GetRealColPos(msgTitle, .Cols - 1) + .ColWidth(.Cols - 1), lngX
                        bCancel = False
                        blnColDrag = True
                        intCol = .Cols - 1
                    End If
                    mOldCol = .Cols - 1
                End If
        End With
    End If

    If Msg = WM_MOUSEMOVE And wParam = MK_LBUTTON Then  '
    End If
End Sub
'处理行列汇总
Private Sub DealRowColTotal()
Dim intRow As Integer, intCol As Integer
Dim sngTotal As Single
    '行合计
    If mclsCross.IsRowSum And mclsCross.RowTotalMethod > 0 Then
    msgTitle.Cols = msgAccount.Cols + 1
    msgAccount.Cols = msgTitle.Cols
        For intRow = 0 To msgTitle.FixedRows - 1
           msgTitle.TextMatrix(intRow, msgTitle.Cols - 1) = "合计"
        Next
        msgTitle.MergeCol(msgTitle.Cols - 1) = True
    Select Case mclsCross.RowTotalMethod
    Case 1   '求和
       For intRow = 1 To msgAccount.Rows - 1
           sngTotal = 0
           For intCol = msgTitle.FixedCols To msgTitle.Cols - 2
              sngTotal = sngTotal + Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intRow
    Case 2    '平均
       For intRow = 1 To msgAccount.Rows - 1
           sngTotal = 0
           For intCol = msgTitle.FixedCols To msgTitle.Cols - 2
              sngTotal = sngTotal + Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal / (intCol - 1)
       Next intRow
    Case 3    '最小值
       For intRow = 1 To msgAccount.Rows - 1
           sngTotal = Val(msgAccount.TextMatrix(intRow, msgTitle.FixedCols))
           For intCol = msgTitle.FixedCols + 1 To msgTitle.Cols - 2
              If sngTotal > Val(msgAccount.TextMatrix(intRow, intCol)) Then _
                    sngTotal = Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intRow
    Case 4    '最大值
        For intRow = 1 To msgAccount.Rows - 1
           sngTotal = Val(msgAccount.TextMatrix(intRow, msgTitle.FixedCols))
           For intCol = msgTitle.FixedCols + 1 To msgTitle.Cols - 2
              If sngTotal < Val(msgAccount.TextMatrix(intRow, intCol)) Then _
                    sngTotal = Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intRow
    End Select
    End If
    
    '列合计
    If mclsCross.IsColSum And mclsCross.ColTotalMethod > 0 Then
        msgAccount.AddItem ""
        msgAccount.TextMatrix(msgAccount.Rows - 1, 0) = "合计"
    Select Case mclsCross.ColTotalMethod
    Case 1   '求和
       For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
           sngTotal = 0
           For intRow = 1 To msgAccount.Rows - 2
              sngTotal = sngTotal + Val(msgAccount.TextMatrix(intRow, intCol))
           Next intRow
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intCol
    Case 2    '平均
       For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
           sngTotal = 0
           For intRow = 1 To msgAccount.Rows - 2
              sngTotal = sngTotal + Val(msgAccount.TextMatrix(intRow, intCol))
           Next intRow
           msgAccount.TextMatrix(intRow, intCol) = sngTotal / (intRow - 1)
       Next intCol
    Case 3    '最小值
       For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
           sngTotal = Val(msgAccount.TextMatrix(intRow, 1))
           For intRow = 2 To msgAccount.Rows - 2
              If sngTotal > Val(msgAccount.TextMatrix(intRow, intCol)) Then _
              sngTotal = Val(msgAccount.TextMatrix(intRow, intCol))
           Next intRow
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intCol
    Case 4    '最大值
        For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
           sngTotal = Val(msgAccount.TextMatrix(intRow, 1))
           For intRow = 2 To msgAccount.Rows - 2
              If sngTotal < Val(msgAccount.TextMatrix(intRow, intCol)) Then _
              sngTotal = Val(msgAccount.TextMatrix(intRow, intCol))
           Next intRow
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intCol
    End Select
       '处理行列合计方式不一致时，最后一个单元的内容显示(始终为空)
       If mclsCross.IsRowSum And mclsCross.RowTotalMethod > 0 And _
          mclsCross.RowTotalMethod <> mclsCross.ColTotalMethod Then _
          msgAccount.TextMatrix(msgAccount.Rows - 1, msgAccount.Cols - 1) = Space(100) & "行列合计方式不同"
    End If
End Sub
'处理数据格式
 Private Sub DealFormat()
   Dim intRow As Integer
   Dim intCol As Integer
   Dim intVisibleRow As Integer
   Dim intEndRow As Integer
'       intVisibleRow = GetVisibleRow
'   With msgAccount
'        If .TopRow + intVisibleRow > .Rows - 1 Then
'          intEndRow = .Rows - 1
'        Else
'          intEndRow = .TopRow + intVisibleRow
'        End If
'   If mintMastDealRow <= intEndRow Then
'       .Redraw = False
'   For intRow = mintMastDealRow To intEndRow
'     For intCol = .FixedCols To .Cols - 1
'
'     '数据格式的处理：是否除以1000，是否显示小数与是否显示零
'        If IsNumeric(.TextMatrix(intRow, intCol)) Or .TextMatrix(intRow, intCol) = "" Then
'            If mclsCross.Divide Then
'              .TextMatrix(intRow, intCol) = CStr(Val(.TextMatrix(intRow, intCol)) / 1000)
'            Else
'            End If
'            If mclsCross.ShowCent Then
'              .TextMatrix(intRow, intCol) = CStr(Format(.TextMatrix(intRow, intCol), "Standard"))
'            Else
'              .TextMatrix(intRow, intCol) = CStr(Format(.TextMatrix(intRow, intCol), "#,###,###,###"))
'            End If
'            If mclsCross.ShowZero = False Then
'              If Val(.TextMatrix(intRow, intCol)) = 0 Then .TextMatrix(intRow, intCol) = ""
'            Else
'              If Val(.TextMatrix(intRow, intCol)) = 0 Then .TextMatrix(intRow, intCol) = "0"
'            End If
'        End If
'
'        '对负数的处理
'         If Val(.TextMatrix(intRow, intCol)) < 0 Then
'          Select Case mclsCross.ShowNegivate
'          Case 0
'          Case 1
'            .Row = intRow
'            .col = intCol
'            .CellForeColor = vbRed
'          Case 2
'            .TextMatrix(intRow, intCol) = "(" & .TextMatrix(intRow, intCol) & ")"
'          Case 3
'            .TextMatrix(intRow, intCol) = "(-)" & Right(.TextMatrix(intRow, intCol), Len(.TextMatrix(intRow, intCol)) - 1)
'          End Select
'        End If    '对负数的处理
'       Next intCol
'  Next intRow
'     mintMastDealRow = intRow
'    .Redraw = True
'  End If
'  End With
End Sub

Private Function GetVisibleRow()
  Dim intRow As Integer
   With msgAccount
        intRow = .TopRow
        Do While .RowIsVisible(intRow)
           GetVisibleRow = GetVisibleRow + 1
           intRow = intRow + 1
           If intRow > .Rows - 1 Then
              Exit Do
           End If
        Loop
   End With
End Function

Private Sub CallReportPopMenu(Optional EditObject As String = " ")
  Dim intCount As Integer

    With frmMain
        For intCount = .mnuListEditMenu.Count - 1 To 1 Step -1
            Unload .mnuListEditMenu(intCount)
        Next
        For intCount = 1 To 5
           Load .mnuListEditMenu(intCount)
        Next intCount
        
        .mnuListEditMenu(0).Caption = "报表设置" & EditObject & "(&S)"
        .mnuListEditMenu(0).Enabled = True
        .mnuListEditMenu(0).Visible = True
        
        .mnuListEditMenu(1).Caption = "显示格式" & EditObject & "(&F)"
        .mnuListEditMenu(1).Enabled = True
        .mnuListEditMenu(1).Visible = True
        
        If mblnHaveHead Then
        .mnuListEditMenu(2).Caption = "隐藏标题" & EditObject & "(&H)"
        Else
        .mnuListEditMenu(2).Caption = "显示标题" & EditObject & "(&I)"
        End If
        .mnuListEditMenu(2).Enabled = True
        .mnuListEditMenu(2).Visible = True
        
        .mnuListEditMenu(3).Checked = False
        .mnuListEditMenu(3).Enabled = True
        .mnuListEditMenu(3).Caption = "-"
        .mnuListEditMenu(3).Enabled = True
        .mnuListEditMenu(3).Visible = True
        
        .mnuListEditMenu(4).Caption = "报表保存" & EditObject & "(&M)"
        .mnuListEditMenu(4).Enabled = True
        .mnuListEditMenu(4).Visible = True
        
        .mnuListEditMenu(5).Caption = "打印" & Space(4) & EditObject & "(&P)"
        .mnuListEditMenu(5).Enabled = True
        .mnuListEditMenu(5).Visible = True
              
   End With
End Sub

Private Sub mclsMainControl_ListEditMenu(ByVal intIndex As Integer)
   Select Case intIndex
   Case 0
        cmdAccSet_Click
   Case 1
        cmdFormatSet_Click
   Case 2
        cmdHide_Click
   Case 4
        cmdSave_Click
   Case 5
        
   End Select
End Sub