clsr_p.cls

金算盘软件代码

'在GRID上确定行是否可见
Private Function blnColIsVisible(ByVal colNo As Integer) As Boolean
    Dim blnHscroll As Boolean, blnVscroll As Boolean, lngUsableWidth As Long
    '该行高度完全可视时为TRUE
    With frmName.grdCol
        If colNo = 1 Then '第一列
            blnColIsVisible = True
            Exit Function
        ElseIf .ColWidth(colNo) = 0 Then '宽度为0列
            blnColIsVisible = False
            Exit Function
        ElseIf .LeftCol > colNo Then '小于GRDCOL的最左可视列
            blnColIsVisible = False
            Exit Function
        ElseIf .Cols - 1 = colNo Then 'GRDCOL最后列
            blnColIsVisible = False
            Exit Function
        ElseIf .ColIsVisible(colNo) = False Then 'GRDCOL最后列
            blnColIsVisible = False
            Exit Function
        Else
            '列可视
            If .ColIsVisible(colNo + 1) And .ColWidth(colNo + 1) > 0 Then
                '其右一列可视
                blnColIsVisible = True
                Exit Function
            Else
                Call ScrollBarExist(blnHscroll, blnVscroll) '判断是否滚动条
                lngUsableWidth = IIf(blnVscroll, .width - gclsEniv.VScrollWidth, .width)
                If ColProperty(colNo).lngCtrType = TRefer Or ColProperty(colNo).lngCtrType = tdate Or ColProperty(colNo).lngCtrType = TSpinText Then
                    If lngUsableWidth - .ColPos(colNo) >= 500 Then
                        blnColIsVisible = True
                        Exit Function
                    Else
                        blnColIsVisible = False
                        Exit Function
                    End If
                Else
                    If lngUsableWidth - .ColPos(colNo) > 100 Then
                        blnColIsVisible = True
                        Exit Function
                    Else
                        blnColIsVisible = False
                        Exit Function
                    End If
                End If
            End If
        End If
        
    End With
 End Function

'各列宽度之和
Private Function lngSumOfColWidth() As Long
    Dim i As Integer, lngSum As Long
    lngSum = 0
    For i = 0 To frmName.grdCol.Cols - 1
        lngSum = lngSum + frmName.grdCol.ColWidth(i)
    Next i
    lngSumOfColWidth = lngSum
End Function

Private Function dblTotalOfCol(ByVal intCol As Integer) As Double
'GRID列合计
    Dim lngRow As Long
    Dim dblTmp As Double
    dblTmp = 0
    For lngRow = 1 To frmName.grdCol.Rows - 1
        dblTmp = dblTmp + C2Dbl(strGrdCell(lngRow, intCol))
    Next lngRow
    dblTotalOfCol = dblTmp
End Function
Private Sub Class_Initialize()
    intGrdBorderWidth = Screen.TwipsPerPixelX
    intGrdBorderHeight = Screen.TwipsPerPixelY
End Sub
'---------------------------------
'确定GRID上的某一行是否为空行
'出口：为TRUE时不是空行,为FALSE时是空行
'---------------------------------
Public Function blnNotNullRow(ByVal lngRow As Long) As Boolean
    Dim intI As Integer
    If C2Dbl(TextMatrix(lngRow, 11)) = 0 And C2Dbl(TextMatrix(lngRow, 13)) = 0 And C2Dbl(TextMatrix(lngRow, 20)) = 0 Then
        blnNotNullRow = False
    Else
        blnNotNullRow = IIf(frmName.Visible And Trim(TextMatrix(lngRow, 1)) = "", False, True)
    End If
End Function
'--------------------------------------
'在GRID上删除一行
'入口：行号
'--------------------------------------
Public Function blnDeleteARow(ByVal lngRow As Long) As Boolean
    Dim i As Long
    Dim j As Long
    Dim strTmp As String
    With frmName.grdCol
        If .Row = 0 Then Exit Function
        If .Rows <= 2 Then
            InsertARow False
            .Row = lngRow
        End If
        
        i = .Row
        For j = i + 1 To UBound(RowNo)
            RowNo(j - 1) = RowNo(j)
        Next j
        RowNo(UBound(RowNo)) = 0
        
        .RemoveItem .Row
        My.bytRegion = FcmdButton
        My.bytIndex = 0
        InputCtrInvisible
        BuildNoteMsg True
        WriteTotalRow
        blnDeleteARow = True
        My.blnIsChanged = True
    End With
End Function
Public Sub WriteTotalRow()
    '重新计算合计行
    Dim i%
    Dim lngI As Long
    Dim strTmp As String
    Dim blnOldRefresh As Boolean
    blnOldRefresh = My.blnRefresh
    
    My.blnRefresh = False
        For i% = 6 To 13
            If i% = 6 Or i% = 7 Or i% = 8 Or i% = 9 Or i% = 10 Or i% = 11 Or i% = 12 Or i% = 13 Then
                strTmp = CStr(dblTotalOfCol(i%))
                If C2Dbl(strTmp) = 0 Then
                    strTmp = ""
                Else
                    If i% <= 9 Then
                        strTmp = Format(strTmp, FormatString(intCurDec))
                    Else
                        strTmp = Format(strTmp, FormatString(gclsBase.NaturalCurDec))
                    End If
                End If
                WriteLabel frmName.lblTotal(i%), strTmp
            End If
        Next i%
        '-------------------------------------
        If blnQuantityTotal = False Then
            frmName.lblTotal(19).Caption = ""
            frmName.lblTotal(20).Caption = ""
        Else
            Dim blnUnitIsSame As Boolean
            Dim strOneUnit As String
            blnUnitIsSame = True
            strOneUnit = ""
            For lngI = 1 To frmName.grdCol.Rows - 1
                If Trim(TextMatrix(lngI, 18)) = "" Then
                Else
                    If strOneUnit = "" Then
                        strOneUnit = Trim(TextMatrix(lngI, 18))
                    ElseIf strOneUnit <> Trim(TextMatrix(lngI, 18)) Then
                        blnUnitIsSame = False
                        Exit For
                    End If
                End If
            Next
            If blnUnitIsSame Then
                strTmp = CStr(dblTotalOfCol(19))
                If C2Dbl(strTmp) = 0 Then
                    strTmp = ""
                Else
                    lngI = InStr(1, strTmp, ".")
                    If lngI > 0 Then
                        lngI = StrLen(strTmp) - lngI
                    End If
                    strTmp = Format(strTmp, FormatString(lngI))
                End If
                WriteLabel frmName.lblTotal(19), strTmp
                strTmp = CStr(dblTotalOfCol(20))
                If C2Dbl(strTmp) = 0 Then
                    strTmp = ""
                Else
                    lngI = InStr(1, strTmp, ".")
                    If lngI > 0 Then
                        lngI = StrLen(strTmp) - lngI
                    End If
                    strTmp = Format(strTmp, FormatString(lngI))
                End If
                WriteLabel frmName.lblTotal(20), strTmp
            Else
                WriteLabel frmName.lblTotal(19), ""
                WriteLabel frmName.lblTotal(20), ""
            End If
        End If
        '-------------------------------------
    
    My.blnRefresh = blnOldRefresh

End Sub

'------------------------------
'在GRID上写红字
'------------------------------
Public Sub WriteGrd(ByVal strText As String, ByVal lngRow As Long, ByVal lngCol As Long, Optional ByVal blnReturnOldCell As Boolean = True)
    Dim lngR As Long, lngC As Long
    Dim blnB As Boolean
    Dim strNew As String
    Dim blnOldRefresh As Boolean
    If lngRow = 0 Then
        frmName.grdCol.TextMatrix(lngRow, lngCol) = strText
        Exit Sub
    End If
    If lngRow > 0 Then
        PutTextToRowProperty lngRow, lngCol, strText
    End If
    With frmName.grdCol
 
    blnOldRefresh = My.blnRefresh
    If lngRow > .Rows - 1 Or lngCol > .Cols - 1 Or lngRow <= 0 Or lngCol <= 0 Then
        Exit Sub
    End If
'    If lngCol = 0 Then
'        If C2lng(strText) = 0 Then
'            frmName.GrdCol.TextMatrix(lngRow, lngCol) = ""
'        Else
'           frmName.GrdCol.TextMatrix(lngRow, lngCol) = "√"
'        End If
'        Exit Sub
'    End If
    strText = Trim(strText)
    If blnReturnOldCell = False Then
        If strText = "" Then
            Exit Sub
        ElseIf Left(strText, 1) <> "-" Then
            .TextMatrix(lngRow, lngCol) = strText
            Exit Sub
        End If
    End If
    If ColProperty(lngCol).lngCtrType = tCurrency And Len(strText) > 0 Then
        My.blnRefresh = False
        strNew = Left(strText, 1)
        If blnReturnOldCell = False Then
            If strNew <> "-" Then
                .TextMatrix(lngRow, lngCol) = strText
                Exit Sub
            End If
        End If
        
        If blnReturnOldCell Then
            lngR = .Row
            lngC = .col
        End If
        .Row = lngRow
        .col = lngCol
        If strNew = "-" Then
            .CellForeColor = RGB(255, 0, 0)
            .TextMatrix(lngRow, lngCol) = Mid(strText, 2)
        ElseIf Val(strText) = 0 Then
            .CellForeColor = RGB(0, 0, 0)
            .TextMatrix(lngRow, lngCol) = ""
        Else
            .TextMatrix(lngRow, lngCol) = strText
            .CellForeColor = RGB(0, 0, 0)
        End If
        If blnReturnOldCell Then
            .Row = lngR
            .col = lngC
        End If
        My.blnRefresh = blnOldRefresh
    Else
        .TextMatrix(lngRow, lngCol) = strText
    End If
    End With
End Sub
'------------------------------
'从GRID上某一单元格内取出字符串
'------------------------------
Public Function strGrdCell(ByVal lngRow As Long, ByVal lngCol As Long, Optional ByVal blnFilterCama As Boolean = True) As String
    If lngRow = 0 Then
        strGrdCell = frmName.grdCol.TextMatrix(lngRow, lngCol)
        Exit Function
    End If
    Dim strTmp As String
    strTmp = GetTextFromRowProperty(lngRow, lngCol)
    If lngCol >= 5 And lngCol <= 20 Then
        If ColProperty(lngCol).lngCtrType = tCurrency Then
            If C2Dbl(strTmp) = 0 Then
                strTmp = ""
            End If
        End If
    End If
    If blnFilterCama Then
        strGrdCell = FilterString(strTmp, ",")
    Else
        strGrdCell = strTmp
    End If
End Function

Private Sub Class_Terminate()
    Set mclsSubClass = Nothing
    Set mclsHook = Nothing
    Set HookHe = Nothing
    Erase Field
'    Erase PicLbl
    Erase ColProperty
    Erase lngPosition
    Erase strColRow
    Set ColBill = Nothing  '单据内容集合(不包括ActivityID和DetailID)
    Set ctrInput = Nothing
    Set ctrPicInput = Nothing
    Set frmName = Nothing
    Set clsRecord = Nothing
End Sub
Public Sub Form_key_Down(ByVal KeyCode As Long)
    Dim bCancel As Long
    HookHe_OnMessage frmName.hWnd, WM_KEYDOWN, KeyCode, 0, bCancel
End Sub

Private Sub HookHe_OnMessage(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCancel As Long)
    On Error Resume Next
    If Msg = WM_CHAR Or Msg = WM_KEYDOWN Or Msg = WM_KEYUP Then
        If m_bBusy Then