frmadaptcard.frm

金算盘软件代码

        If msgItem.col < msgItem.Cols - 1 Then
            BKKEY msgItem.hwnd, vbKeyRight
        ElseIf msgItem.Row < msgItem.Rows - 1 Then
            msgItem.Row = msgItem.Row + 1
            BKKEY msgItem.hwnd, vbKeyHome
        End If
    ElseIf KeyAscii <> vbKeyRight And KeyAscii <> vbKeyHome Then
        If InStr(1, msgItem.TextMatrix(0, msgItem.col), "新") > 0 Then
            EditGrid KeyAscii
        ElseIf msgItem.col = 1 And KeyAscii = Asc(" ") Then
            If msgItem.TextMatrix(msgItem.Row, 1) = "√" Then
                msgItem.TextMatrix(msgItem.Row, 1) = ""
                mintSelCount = mintSelCount - 1
            Else
                msgItem.TextMatrix(msgItem.Row, 1) = "√"
                mintSelCount = mintSelCount + 1
            End If
            SetButton
        End If
    End If
End Sub

Private Sub msgItem_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgItem
        If .MouseCol = 1 Then
            .MousePointer = vbCustom
        Else
            .MousePointer = vbDefault
        End If
    End With
End Sub

Private Sub msgItem_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgItem
        If y < .RowHeight(0) Or y > .Rows * .RowHeight(0) Or .Row = 0 Then Exit Sub
        If .MouseCol = 1 Then
            If .TextMatrix(.Row, 1) = "√" Then
                .TextMatrix(.Row, 1) = ""
                mintSelCount = mintSelCount - 1
            Else
                .TextMatrix(.Row, 1) = "√"
                mintSelCount = mintSelCount + 1
            End If
            SetButton
        End If
    End With
End Sub

Private Sub msgItem_Scroll()
    txtInput.Visible = False
End Sub

Private Sub txtInput_Change()
    On Error Resume Next
    If txtInput.Text = "" Then Exit Sub
    If Left(txtInput.Text, 1) = "-" Then txtInput.Text = ""
    If Not IsNum(txtInput.Text, mbytDec) Then BKKEY txtInput.hwnd
    mblnIsChanged = True
End Sub

Private Sub EditGrid(ByVal KeyCode As Integer)
    On Error Resume Next
    With msgItem
    If .RowHeight(.Row) = 0 Or .col = 0 Then Exit Sub
    txtInput.Move .Left + .CellLeft, .top + .CellTop, .CellWidth, .CellHeight
    If Chr(KeyCode) >= "0" And Chr(KeyCode) <= "9" Then
        txtInput.Text = Chr(KeyCode)
    Else
        txtInput.Text = Format(.Text, "0." & String(mbytDec, "0")) & Chr(KeyCode)
    End If
    txtInput.Visible = True
    txtInput.SetFocus
    txtInput.SelStart = Len(txtInput.Text)
    End With
End Sub

Private Function SaveCard() As Boolean
    Dim i As Integer, b As Byte, strSql As String, iCol As Integer, blnC As Boolean
    Dim dblPrice(0 To 3) As Double, strColName(0 To 3) As String
    Dim recTax As rdoResultset, dblTax As Double
    
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    iCol = GetColNO
    For i = 0 To 3
        strColName(i) = ""
    Next i
    blnC = True
    If mblnIsAdjust Then
        Select Case mstrArr(mlngcboID(1))
        Case "Plan"
            strColName(0) = "dblPlanPrice"
        Case "Purchase"
            strColName(0) = "dblPurchasePrice1"
            strColName(1) = "dblPurchasePrice"
            strColName(2) = "dblRecenetPurchasePrice"
            strColName(3) = "lngRecentPurchaseDetailID"
        Case "Sale"
            strColName(0) = "dblSalePrice1"
            strColName(1) = "dblSalePrice"
            strColName(2) = "dblRecenetSalePrice"
            strColName(3) = "lngRecentSaleReceiptDetailID"
        Case "Retain"
            strColName(0) = "dblRetainPrice"
            blnC = False
        End Select
    Else
        Select Case mstrArr(cboItem(1).ListIndex)
        Case "Plan"
            strColName(0) = "dblPlanPrice"
        Case "Purchase"
            strColName(0) = "dblPurchasePrice1"
            strColName(1) = "dblPurchasePrice"
            strColName(2) = "dblRecenetPurchasePrice"
            strColName(3) = "lngRecentPurchaseDetailID"
        Case "Sale"
            strColName(0) = "dblSalePrice1"
            strColName(1) = "dblSalePrice"
            strColName(2) = "dblRecenetSalePrice"
            strColName(3) = "lngRecentSaleReceiptDetailID"
        Case "Retain"
            strColName(0) = "dblRetainPrice"
            blnC = False
        End Select
    End If
    
    SaveCard = True
    For i = 1 To msgItem.Rows - 1
        If msgItem.RowData(i) = -1 Then   '价格被修改过
            If blnC Then
                strSql = "SELECT ItemNature.*,Tax.dblPurchaseTaxRate,Tax.dblSaleTaxRate " _
                    & "FROM Item,ItemNature,Tax WHERE Item.lngItemNatureID=ItemNature.lngItemNatureID " _
                    & "AND ItemNature.lngTaxID=Tax.lngTaxID AND lngItemID=" & msgItem.TextMatrix(i, 0)
                Set recTax = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
                dblTax = IIf(strColName(0) = "dblSalePrice1", recTax!dblSaleTaxRate, recTax!dblPurchaseTaxRate)
                recTax.Close
            End If
            dblPrice(0) = TxtToDouble(msgItem.TextMatrix(i, iCol))
            If blnC Then
                If strColName(1) = "" Then
'                    dblPrice(0) = dblPrice(0) / (1 + dblTax / 100)
                Else
                    dblPrice(1) = dblPrice(0) / (1 + dblTax / 100)
                    dblPrice(2) = dblPrice(1)
                    dblPrice(3) = 0
                End If
            End If
            strSql = "UPDATE Item SET "
            For b = 0 To 3
                If strColName(b) <> "" Then
                    strSql = strSql & strColName(b) & "=" & dblPrice(b) & ","
                End If
            Next b
            strSql = Left(strSql, Len(strSql) - 1) & " WHERE lngItemID=" _
                & msgItem.TextMatrix(i, 0)
        Else
            strSql = ""
        End If
        If strSql <> "" Then
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            If strColName(1) <> "" Then
                strSql = "UPDATE ItemPrice SET dblRecentPrice=0,dblRecentPriceTax=0 WHERE lngItemID=" & msgItem.TextMatrix(i, 0)
                gclsBase.BaseDB.Execute strSql
            End If
            strSql = "INSERT INTO ItemHPrice(lngItemID,strDate,"
            For b = 0 To 1
                If strColName(b) <> "" Then
                    strSql = strSql & strColName(b) & ","
                End If
            Next b
            strSql = Left(strSql, Len(strSql) - 1) & ") VALUES(" & msgItem.TextMatrix(i, 0) & ",'" & dtePrice.Text & "',"
            For b = 0 To 1
                If strColName(b) <> "" Then
                    strSql = strSql & dblPrice(b) & ","
                End If
            Next b
            strSql = Left(strSql, Len(strSql) - 1) & ")"
            If Not gclsBase.ExecSQL(strSql) Then
                strSql = "UPDATE ItemHPrice SET "
                For b = 0 To 1
                    If strColName(b) <> "" Then
                        strSql = strSql & strColName(b) & "=" & dblPrice(b) & ","
                    End If
                Next b
                strSql = Left(strSql, Len(strSql) - 1) & " WHERE lngItemID=" _
                & msgItem.TextMatrix(i, 0) & " AND strDate='" & dtePrice.Text & "'"
                gclsBase.ExecSQL strSql
            End If
        End If
    Next i
    gclsBase.BaseWorkSpace.CommitTrans
    mblnIsChanged = False
    mblnIsAdjust = False
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    SaveCard = False
End Function

Private Function GetTypeID(ByVal lngTypeID) As String
    Dim recItemType As rdoResultset, strItemTypeCode As String, strSql As String, strTypeID As String
    
    strTypeID = lngTypeID
    
    strSql = "SELECT * FROM ItemType WHERE lngItemTypeID=" & lngTypeID
    Set recItemType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    strItemTypeCode = recItemType!strItemTypeCode
    recItemType.Close
    
    strSql = "SELECT * FROM ItemType WHERE strItemTypeCode LIKE '" & strItemTypeCode & "-%'"
    Set recItemType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recItemType.EOF
        strTypeID = strTypeID & "," & recItemType!lngItemTypeID
        recItemType.MoveNext
    Loop
    recItemType.Close
    GetTypeID = strTypeID
End Function

Private Function GetItemNatureID() As String
    Dim strCostMethod As String, recI As rdoResultset, strSql As String
    Dim strIDStr As String
    
    GetItemNatureID = ""
    Select Case mstrArr(cboItem(1).ListIndex)
    Case "Plan"
        strCostMethod = "6"
    Case "Purchase"
        Exit Function
    Case "Sale"
        Exit Function
    Case "Retain"
        strCostMethod = "7"
    End Select
    
    strSql = "SELECT * FROM ItemNature WHERE strCostMethod ='" & strCostMethod & "'"
    Set recI = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    While Not recI.EOF
        strIDStr = strIDStr & recI("lngItemNatureID") & ","
        recI.MoveNext
    Wend
    recI.Close
    GetItemNatureID = strIDStr
End Function

Private Function GetRecordset(ByVal lngTypeID As Long, Optional ByVal strCon As String = "") As rdoResultset
    Dim strSql As String
    
    With mclsGrid.ListSet
        strSql = "SELECT DISTINCT Item.lngItemID AS ID,'' AS 选取," _
            & .SelectOfSql & .FromOfSql _
            & " WHERE Item.lngItemTypeID IN (" & GetTypeID(lngTypeID) & ")"
'        If Trim(.WhereOfSql) <> "" Then strSql = strSql & " AND " & Trim(.WhereOfSql)
    End With
    If strCon <> "" Then strSql = strSql & " AND " & strCon
    strSql = strSql & " ORDER BY Item.lngItemID"
    Set GetRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Function

Private Sub SetCboItem()
    Dim i As Integer
    
    cboItem(1).Clear
    For i = 1 To mclsGrid.ListSet.Columns
        If mclsGrid.ListSet.ColumnFieldName(i) = "Item.dblSalePrice1" Then
            cboItem(1).AddItem mclsGrid.ListSet.ColumnDesc(i)
            cboItem(1).ItemData(cboItem(1).NewIndex) = cboItem(1).ListCount - 1
            mstrArr(cboItem(1).ListCount - 1) = "Sale"
        End If
        If mclsGrid.ListSet.ColumnFieldName(i) = "Item.dblPurchasePrice1" Then
            cboItem(1).AddItem mclsGrid.ListSet.ColumnDesc(i)
            cboItem(1).ItemData(cboItem(1).NewIndex) = cboItem(1).ListCount - 1
            mstrArr(cboItem(1).ListCount - 1) = "Purchase"
        End If
        If mclsGrid.ListSet.ColumnFieldName(i) = "Item.dblPlanPrice" Then
            cboItem(1).AddItem mclsGrid.ListSet.ColumnDesc(i)
            cboItem(1).ItemData(cboItem(1).NewIndex) = cboItem(1).ListCount - 1
            mstrArr(cboItem(1).ListCount - 1) = "Plan"
        End If
        If mclsGrid.ListSet.ColumnFieldName(i) = "Item.dblRetainPrice" Then
            cboItem(1).AddItem mclsGrid.ListSet.ColumnDesc(i)
            cboItem(1).ItemData(cboItem(1).NewIndex) = cboItem(1).ListCount - 1
            mstrArr(cboItem(1).ListCount - 1) = "Retain"
        End If
    Next i
    cboItem(1).ListIndex = 0
End Sub

Private Sub SetButton()
    If mintSelCount > 0 Then
        cmdOK(5).Enabled = True
        cmdOK(6).Enabled = True
        cmdOK(7).Enabled = True
    Else
        cmdOK(5).Enabled = False
        cmdOK(6).Enabled = False
        cmdOK(7).Enabled = False
    End If
End Sub

Private Sub txtInput_KeyUp(KeyCode As Integer, Shift As Integer)
    With msgItem
    Select Case KeyCode
    Case vbKeyReturn
        If .Row < .Rows - 1 Then .Row = .Row + 1
        EditGrid Asc(" ")
    Case vbKeyUp
        If .Row > 1 Then
            .Row = .Row - 1
            msgItem.SetFocus
        End If
    Case vbKeyDown
        If .Row < .Rows - 1 Then
            .Row = .Row + 1
            msgItem.SetFocus
        End If
'    Case vbKey0, vbKey1, vbKey2, vbKey3, vbKey4, vbKey5, vbKey6, vbKey7, vbKey8, vbKey9, vbKeyDecimal
'        .TextMatrix(mlngRow, GetColNO) = FormatShow(txtInput.Text, mbytDec)
'        .RowData(mlngRow) = -1
    Case Else
        .TextMatrix(mlngRow, GetColNO) = FormatShow(txtInput.Text, mbytDec)
        .RowData(mlngRow) = -1
'        KeyCode = 0
    End Select
    End With
End Sub

Private Sub txtInput_LostFocus()
    txtInput.Visible = False
End Sub