frmstandardreport.frm

金算盘软件代码

       msgAccount.Height = Me.Height - 2000
       LblTitle.Visible = True
   Else
       msgTitle.top = lngTitleTop - 250
       msgAccount.top = lngAccountTop - 250
       msgAccount.Height = Me.Height - 2000 + 250
       LblTitle.Visible = False
   End If
   LblTitle.Left = (msgAccount.Width - LblTitle.Width) \ 2
   msgTitle.Left = msgAccount.Left
   msgAccount.Redraw = True
   msgTitle.Redraw = True
   
End Sub


'重置列宽
Private Sub ReSetColWidth()
  Dim intCol  As Integer
    msgTitle.Redraw = False
    msgAccount.Redraw = False
    msgAccount.ColWidth(0) = msgTitle.ColWidth(0)
    For intCol = 1 To msgTitle.Cols - 1
        msgAccount.ColWidth(intCol) = msgTitle.ColWidth(intCol)
        mclsStandard.ColumnWidth(intCol - 1) = msgAccount.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
'        CoverTail
    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 = flexMergeFree
                 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 = 1 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 GetLoc()
    Dim intCol As Integer
    For intCol = 0 To 2
     mintLend(intCol) = 0
     mintLoan(intCol) = 0
     mintBalance(intCol) = 0
    Next intCol
    For intCol = 1 To msgAccount.Cols - 1
     Select Case mclsStandard.ColumnFieldDesc(intCol - 1)
     Case "日期"
       mintDate = intCol
     Case "方向"
       mintDirection = intCol
     Case "借方数量"
       mintLend(0) = intCol
     Case "借方金额"
       mintLend(1) = intCol
     Case "借方外币"
       mintLend(2) = intCol
     Case "贷方数量"
       mintLoan(0) = intCol
     Case "贷方金额"
       mintLoan(1) = intCol
     Case "贷方外币"
       mintLoan(2) = intCol
     Case "余额数量"
       mintBalance(0) = intCol
     Case "余额金额"
       mintBalance(1) = intCol
     Case "余额外币"
       mintBalance(2) = intCol
     End Select
    Next intCol
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
'     If intCol = mintDate Or mclsStandard.ColumnFieldType(intCol - 1) = "Code" _
'            Or mclsStandard.ColumnFieldType(intCol - 1) = "String" Then
'     Else
     '数据格式的处理：是否除以1000，是否显示小数与是否显示零
'        If IsNumeric(.TextMatrix(intRow, intCol)) Or .TextMatrix(intRow, intCol) = "" Then
'            If mclsStandard.Divide Then
'              .TextMatrix(intRow, intCol) = CStr(.TextMatrix(intRow, intCol) / 1000)
'            Else
'            End If
'            If mclsStandard.ShowCent Then
'              .TextMatrix(intRow, intCol) = CStr(Format(.TextMatrix(intRow, intCol), "Standard"))
'            Else
'              .TextMatrix(intRow, intCol) = CStr(Format(.TextMatrix(intRow, intCol), "#,###,###,###"))
'            End If
'
'            If mclsStandard.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 mclsStandard.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    '对负数的处理
'        End If      '对年月日的处理
'       Next intCol
'  Next intRow
'     mintMastDealRow = intRow
'    .Redraw = True
'  End If
'  End With
End Sub

'余额计算
Private Sub DealBalance()
  Dim intRow As Integer, intCount As Integer
 
   With msgAccount
    .Redraw = False
        For intRow = 1 To .Rows - 1
        For intCount = 0 To 2
            If mintBalance(intCount) > 0 Then
                .TextMatrix(intRow, mintBalance(intCount)) = Val(.TextMatrix(intRow - 1, mintBalance(intCount))) _
                     + Val(.TextMatrix(intRow, mintBalance(intCount)))
            End If
        Next intCount
        Next intRow
        .Redraw = True
   End With
End Sub
'期初余额
Private Sub GetBeginBanlance()
   With msgAccount
       .Redraw = False
       .AddItem "", 0
       If mintDescribe > 0 Then
           .TextMatrix(0, mintDescribe) = "期初余额"
       End If
       .Redraw = True
   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