itemclass.cls

金算盘软件代码

        Else
            blnVscroll = False
        End If
        GoTo EndProc
    End If
    
    If intTotalColsWidth < frmName.GrdCol.width - 2 * intGrdBorderWidth _
        And intTotalColsWidth > frmName.GrdCol.width - 2 * intGrdBorderWidth - gclsEniv.VScrollWidth Then
        If frmName.GrdCol.RowPos(frmName.GrdCol.Rows - 1) + frmName.GrdCol.RowHeight(frmName.GrdCol.Rows - 1) >= frmName.GrdCol.Height - 2 * intGrdBorderHeight Then
            blnVscroll = True
            blnHscroll = True
        Else
            blnVscroll = False
            blnHscroll = False
        End If
    End If

EndProc:
    If frmName.GrdCol.ScrollBars = flexScrollBarNone Or _
       frmName.GrdCol.ScrollBars = flexScrollBarVertical Then
        blnHscroll = False
    End If
    If frmName.GrdCol.ScrollBars = flexScrollBarNone Or _
       frmName.GrdCol.ScrollBars = flexScrollBarHorizontal Then
        blnVscroll = False
    End If

End Sub
'在GRID上确定行是否可见
Public Function blnRowIsVisible(ByVal RowNo As Integer) As Boolean
    '该行高度完全可视时为TRUE
    Dim blnHscroll As Boolean, blnVscroll As Boolean
    If frmName.GrdCol.Rows <= 1 Then
        frmName.GrdCol.Rows = 2
    End If
    If RowNo > frmName.GrdCol.Rows - 1 Then
        blnRowIsVisible = False
    End If
    If frmName.GrdCol.RowIsVisible(RowNo) = False Then
        blnRowIsVisible = False
        Exit Function
    End If
    Call ScrollBarExist(blnHscroll, blnVscroll) '判断是否滚动条
    If blnHscroll Then
        '下边有滚动水平条
        If frmName.GrdCol.RowPos(RowNo) + frmName.GrdCol.RowHeight(RowNo) > frmName.GrdCol.Height - gclsEniv.HScrollHeight Then
            blnRowIsVisible = False
        Else
            blnRowIsVisible = True
        End If
   Else
        '下边无水平滚动条
        If frmName.GrdCol.RowPos(RowNo) + frmName.GrdCol.RowHeight(RowNo) > frmName.GrdCol.Height Then
            blnRowIsVisible = False
        Else
            blnRowIsVisible = True
        End If
   End If
End Function

'各列宽度之和
Public 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

Public Function dblTotalOfCol(ByVal intCol As Integer) As Double
'GRID列合计
    Dim lngRow As Long
    Dim dblTmp As Double
    dblTmp = 0
    My.blnRefresh = False
    For lngRow = 1 To frmName.GrdCol.Rows - 1
        dblTmp = dblTmp + C2Dbl(strGrdCell(lngRow, intCol, False))
    Next lngRow
    My.blnRefresh = True
    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(C2lng(TextOfGrid(lngRow, 28)) <= 0, False, True)
End Function
'--------------------------------------
'在GRID上删除一行
'入口：行号
'--------------------------------------
Public Function blnDeleteARow(ByVal lngRow As Long) As Boolean
    Dim i%
    Dim strTmp As String
    With frmName.GrdCol

'    #If conVersionType <> 16 Then
        If m_lngReceiptTypeID > 12 Then
            AdjustDiscInfoRowNO DiscInfos, lngRow, False
        End If
'    #End If
        If blnRowCanEdit(lngRow) = False Then
           ShowMsgOther frmName.hwnd, "第" & lngRow & "行选择的单据已经生成凭证，不能删除！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "修改单据"
           Exit Function
        End If
        If .Rows <= 2 Then
            .Rows = 1
            ClearRowProperty
            InsertARow False
            On Error Resume Next
            .Row = 1
        Else
            For i = lngRow To .Rows - 2
               Row2Position(i) = Row2Position(i + 1)
            Next
            ReDim Preserve Row2Position(UBound(Row2Position) - 1)
            .RemoveItem lngRow
        End If
        
        My.bytRegion = FcmdButton
        My.bytIndex = 0
        UpdateMainEditMenu
        InputCtrInvisible
        setAllItemproperty
        BuildNoteMsg True
        WriteTotalRow
        blnDeleteARow = True
        My.blnIsChanged = True
        .Row = IIf(lngRow > .Rows - 1, .Rows - 1, lngRow)
        .col = 1
        grdCol_EnterCell
    End With
    ModiRateReadOnly
End Function
Public Sub WriteTotalRow()
    '重新计算合计行
    Dim i%
    Dim lngRowBak As Long
    Dim lngColBak As Long
    
    Dim strTmp As String

        lngRowBak = frmName.GrdCol.Row
        lngColBak = frmName.GrdCol.col
        
        For i% = 9 To 16
            If i% = 9 Or i% = 10 Or i% = 12 Or i% = 13 Or i% = 14 Or i% = 15 Or i% = 16 Then
                strTmp = CStr(dblTotalOfCol(i%))
                If C2Dbl(strTmp) = 0 Then
                    strTmp = ""
                Else
                    If i% = 9 Or i% = 12 Or i% = 14 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%
        frmName.GrdCol.Row = lngRowBak
        frmName.GrdCol.col = lngColBak
        WriteTotalQuantity
End Sub

'------------------------------
'在GRID上写红字
'------------------------------
Public Sub WriteGrd(ByVal strText As String, ByVal lngRow As Long, ByVal lngCol As Long, Optional blnBackRowCol As Boolean = True)
    Dim lngR As Long, lngC As Long
    Dim blnB As Boolean
    Dim blnRefreshBak As Boolean
    Dim strNew As String
    
    If lngCol > frmName.GrdCol.Cols - 1 Then
         PutTextToRowProperty lngRow, lngCol, strText
         Exit Sub
    End If
    If lngRow = 0 Then
      frmName.GrdCol.TextMatrix(lngRow, lngCol) = strText
      Exit Sub
    End If
    
    blnRefreshBak = My.blnRefresh
    If lngRow > frmName.GrdCol.Rows - 1 Or lngCol > frmName.GrdCol.Cols - 1 Or _
       lngRow < 0 Or lngCol < 0 Then
        Exit Sub
    End If
    strText = Trim(strText)
    If blnBackRowCol Then
        lngR = frmName.GrdCol.Row
        lngC = frmName.GrdCol.col
    Else
        lngR = 0
        lngC = 0
    End If
    My.blnRefresh = False
    Select Case lngCol
    Case 6, 7   '单价
        strText = Format(C2Dbl(strText), FormatString(gclsBase.PriceDec))
    Case 8      '扣率
        strText = Format(C2Dbl(strText), "0.00")
    Case 9, 12, 14  '原币
        strText = Format(C2Dbl(strText), FormatString(intCurDec))
    Case 10, 13, 15, 16 '本币
        strText = Format(C2Dbl(strText), FormatString(gclsBase.NaturalCurDec))
    Case Else
    End Select
    
    Dim strOldText As String
    strOldText = TextOfGrid(lngRow, lngCol)
    PutTextToRowProperty lngRow, lngCol, strText
    With frmName.GrdCol
        If .ColAlignment(lngCol) = flexAlignRightCenter Then
            If C2Dbl(strOldText) >= 0 And C2Dbl(strText) < 0 Then
               If lngR <> lngRow Then
                   .Row = lngRow
               End If
               If lngC <> lngCol Then
                   .col = lngCol
               End If
               .CellForeColor = RGB(255, 0, 0)
               .TextMatrix(lngRow, lngCol) = Mid(strText, 2)
            ElseIf C2Dbl(strOldText) <= 0 And C2Dbl(strText) >= 0 Then
               If lngR <> lngRow Then
                   .Row = lngRow
               End If
               If lngC <> lngCol Then
                   .col = lngCol
               End If
               .CellForeColor = RGB(0, 0, 0)
               If C2Dbl(strText) = 0 Then
                  strText = ""
               End If
               .TextMatrix(lngRow, lngCol) = strText
            Else
               If C2Dbl(strText) = 0 Then
                  strText = ""
               ElseIf C2Dbl(strText) < 0 Then
                  strText = Mid(strText, 2)
               End If
               .TextMatrix(lngRow, lngCol) = strText
            End If
            If blnBackRowCol Then
                If lngR <> lngRow Then
                    .Row = lngR
                End If
                If lngC <> lngCol Then
                    .col = lngC
                End If
            End If
        Else
            If lngCol = 20 Then
                .TextMatrix(lngRow, lngCol) = IIf(C2lng(strText) = 0, "", C2lng(strText))
            Else
                .TextMatrix(lngRow, lngCol) = strText
            End If
        End If
    End With
    My.blnRefresh = blnRefreshBak
End Sub
'------------------------------
'从GRID上某一单元格内取出字符串
'------------------------------
Public Function strGrdCell(ByVal lngRow As Long, ByVal lngCol As Long, Optional blnBackRowCol As Boolean = True) As String
   If lngRow = 0 Then
      If lngCol < frmName.GrdCol.Cols Then
         strGrdCell = frmName.GrdCol.TextMatrix(lngRow, lngCol)
      End If
      Exit Function
   End If
   strGrdCell = GetTextFromRowProperty(lngRow, lngCol)
   Select Case lngCol
   Case 5, 6, 7, 9, 10, 12, 13, 14, 15, 16, 20
      If C2Dbl(strGrdCell) = 0 Then
         strGrdCell = ""
      End If
   End Select
End Function
Public Function strGrdCellReal(ByVal lngRow As Long, ByVal lngCol As Long, Optional blnBackRowCol As Boolean = True) As String
    Dim lngR As Long, lngC As Long
    Dim blnB As Boolean
    Dim blnRefreshBak As Boolean
    Dim strTmp As String
    
    blnRefreshBak = My.blnRefresh
    
    With frmName.GrdCol
        If lngRow > .Rows - 1 Or lngCol > .Cols - 1 Or _
           lngRow < 0 Or lngCol < 0 Then
            Exit Function
        End If
        If .ColAlignment(lngCol) = flexAlignRightCenter Then
            My.blnRefresh = False
            If blnBackRowCol Then
                lngR = .Row
                lngC = .col
            End If
            If lngR <> lngRow Then
                .Row = lngRow
            End If
            If lngC <> lngCol Then