clsstartperiod.cls

金算盘软件代码

                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
    blnNotNullRow = IIf(frmName.Visible And Trim(TextMatrix(lngRow, 1)) = "" Or C2lng(TextMatrix(lngRow, 28)) <= 0, False, True)
'    For inti = 0 To frmName.grdCol.Cols - 1
'        If TextMatrix(lngRow, inti) <> "" TextMatrix(lngRow, inti) <> "0" Then
'            blnNotNullRow = True
'            Exit Function
'        End If
'    Next
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
        setAllItemproperty
        BuildNoteMsg True
        WriteTotalRow
        blnDeleteARow = True
        My.blnIsChanged = True
    End With
End Function
Public Sub WriteTotalRow()
    '重新计算合计行
    Dim lngI As Long
    Dim strTmp As String
    Dim blnOldRefresh As Boolean
    blnOldRefresh = My.blnRefresh
    My.blnRefresh = False
        For lngI = 9 To 16
            If lngI = 9 Or lngI = 10 Or lngI = 12 Or lngI = 13 Or lngI = 14 Or lngI = 15 Or lngI = 16 Then
                strTmp = CStr(dblTotalOfCol(lngI))
                If C2Dbl(strTmp) = 0 Then
                    strTmp = ""
                Else
                    If lngI = 9 Or lngI = 12 Or lngI = 14 Then
                        strTmp = Format(strTmp, FormatString(intCurDec))
                    Else
                        strTmp = Format(strTmp, FormatString(gclsBase.NaturalCurDec))
                    End If
                End If
                WriteLabel frmName.lblTotal(lngI), strTmp
            End If
        Next lngI
        '-------------------------------------
        If blnQuantityTotal = False Then
            frmName.lblTotal(5).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, 4)) = "" Then
                Else
                    If strOneUnit = "" Then
                        strOneUnit = Trim(TextMatrix(lngI, 4))
                    ElseIf strOneUnit <> Trim(TextMatrix(lngI, 4)) Then
                        blnUnitIsSame = False
                        Exit For
                    End If
                End If
            Next
            If blnUnitIsSame Then
                strTmp = CStr(dblTotalOfCol(5))
                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(5), strTmp
            Else
                WriteLabel frmName.lblTotal(5), ""
            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
    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 .ColAlignment(lngCol) = flexAlignRightCenter 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
    Erase arrItemProperty
    Erase RowPropertys
    Erase RowNo
    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
            bCancel = 1
            Exit Sub
        End If
        If mblnNotRespondKeyPress Then
            Exit Sub
        End If
    End If
    
    If Msg = WM_KEYDOWN Then
        If Not (frmName.refInput.ReferVisible Or frmName.refInput1.ReferVisible Or frmName.refInput2.ReferVisible Or frmName.dtmInput.IsDropDown = 1) Then
            If wParam = 38 Or wParam = 40 Then
                mblnReadOnly = (Not My.blnMayChange) Or frmName.chkPrint(1).Value = 1 '权限控制
                If mblnReadOnly Then
                    If My.bytRegion = FNote Then
                        If wParam = 38 Then
                            If frmName.GrdCol.Row = 1 Then
                                mblnKeyDown = True
                            End If
                        ElseIf wParam = 40 Then
                            If frmName.GrdCol.Row = frmName.GrdCol.Rows - 1 Then
                                mblnKeyDown = True
                            End If
                        End If
                    Else
                        mblnKeyDown = True
                    End If
                Else
                    mblnKeyDown = True
                End If
            ElseIf wParam = 37 Then ' left
                If My.bytRegion = FField Or My.bytRegion = FHead Or My.bytRegion = FNote Or My.bytRegion = FGrid Or My.bytRegion = FcmdFooter Or My.bytRegion = FFooter Then
                    If Not ctrInput Is Nothing Then
                        If ctrInput.Name = "picInput" Then
                            If NewQ.SelStart = 0 Then
                                mblnKeyDown = True
                            End If
                        Else
                            If ctrInput.SelStart = 0 Then
                                mblnKeyDown = True
                            End If
                        End If
                    Else
                        mblnKeyDown = True
                    End If
                Else
                    mblnKeyDown = True
                End If
            ElseIf wParam = 39 Then 'right
                If My.bytRegion = FField Or My.bytRegion = FHead Or My.bytRegion = FNote Or My.bytRegion = FGrid Or My.bytRegion = FcmdFooter Or My.bytRegion = FFooter Then
                    If Not ctrInput Is Nothing Then
                        If ctrInput.Name = "picInput" Then
                            If NewQ.SelStart = Len(NewQ.Text) Then
                                mblnKeyDown = True
                            End If
                        Else
                            If ctrInput.SelStart = Len(ctrInput.Text) Then
                                mblnKeyDown = True
                            End If
                        End If
                    Else
                        mblnKeyDown = True
                    End If