frmmuticurr.frm

金算盘软件代码

                ElseIf strCurr <> "" And (dblAmount <= 0 Or dblCurrAmount <= 0) Then
                    DataIsVoid = False
                    Msg = "金额必须大于0！"
                End If
                If DataIsVoid Then
                    For lngRow1 = 1 To .Rows - 1
                        If .RowHeight(lngRow1) > 100 And GetValue(lngRow1, mlngColCurr, "String") = strCurr And lngRow1 <> lngRow Then
                            DataIsVoid = False
                            Msg = "原值的币种不能重复！"
                            Exit For
                        End If
                    Next lngRow1
                End If
            End If
            If Msg = "" Then
                If blnCheckAfterSave And strCurr <> "" Then
                    strSql = "SELECT lngCurrencyID FROM Currencys WHERE lngCurrencyID=" & C2lng(.TextMatrix(lngRow, mlngColCurrID))
                    Set recCurrency = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    If recCurrency.EOF Then
                        Msg = "币种不存在或已作废或已被删除！"
                    End If
                    recCurrency.Close
                End If
            End If
            If Msg <> "" Then Exit For
        Next lngRow
    End With
    
    If DataIsVoid Then
        If lngCnt = 0 Then
            DataIsVoid = False
            Msg = "币种不能为空！"
        End If
    End If
End Function

'按钮数组的Click事件处理
Private Sub cmdOk_Click(Index As Integer)
    Dim strMsg As String
    Select Case Index
        Case 0 '确定
            If Not mblnLocked Then
                If DataIsVoid(strMsg) Then
                    Save -1
                    Hide
                Else
                    ShowMsg hwnd, strMsg, vbInformation, Caption
                End If
            Else
                Hide
            End If
        Case 1 '取消
            mclsList.CancelSave
            Hide
            RefreshGrid
    End Select
End Sub


Private Sub Form_Activate()
    On Error Resume Next
    SetHelpID HelpContextID
    frmMain.SetEditUnEnabled
    msgMutiCurr.SetFocus
End Sub

Private Sub Form_Load()
    On Error Resume Next
    mlngAlterID = -1
    mblnLocked = True
    mblnChanged = False
    RefreshLtxtCurr
    Set mclsList = New Grid
    Set mclsList.Grid = msgMutiCurr
    mclsList.SetupStyle
    Me.HelpContextID = 60134
    Utility.LoadFormResPicture Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim strSql As String
    On Error Resume Next
    strSql = "DELETE FROM FixedCost WHERE lngFixedAlterID=-1"
    gclsBase.ExecSQL strSql
    Utility.UnLoadFormResPicture Me
    If Not ltxtCurr.Recordset Is Nothing Then
        Set ltxtCurr.Recordset = Nothing
    End If
End Sub

Private Sub ltxtCurr_AddNew()
    Dim lngID As Long
    
    lngID = Card.AddCard(15) '调用卡片
    RefreshLtxtCurr
    ltxtCurr.Visible = True
    ltxtCurr.SeekId lngID
End Sub

'币种参照
Private Sub ltxtCurr_Choose()
    Dim lngCol As Long
    Dim dblRate As Double
    Dim strSql As String
    Dim recCurrencys As rdoResultset
    
    mlngCurrID = ltxtCurr.ID
    strSql = "SELECT * FROM Currencys WHERE lngCurrencyID=" & mlngCurrID
    Set recCurrencys = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCurrencys.EOF Then
        With msgMutiCurr
            .TextMatrix(.Row, .col) = ltxtCurr.Text
            .TextMatrix(.Row, mlngColInDirect) = recCurrencys!blnIsIndirect
            .TextMatrix(.Row, mlngColCurrDec) = recCurrencys!bytCurrencydec
            .TextMatrix(.Row, mlngColRateDec) = recCurrencys!bytRateDec
            If GetValue(.Row, mlngColAmount) = 0 Then
            If mlngCurrID = gclsBase.NaturalCurId Then
                .TextMatrix(.Row, mlngColRate) = 1
            Else
                dblRate = BillPublic.RateValue(mlngCurrID, gclsBase.BaseDate)
                If dblRate <> 0 Then
                    .TextMatrix(.Row, mlngColRate) = dblRate
                End If
            End If
            End If
        End With
    End If
    recCurrencys.Close
    Set recCurrencys = Nothing
End Sub

Private Sub ltxtCurr_Delete()
    If mlngCurrID = 0 Then
        ShowMsg hwnd, "没有可供删除的项目", vbExclamation, Me.Caption
    Else
        Card.DelCard msgcurrency, mlngCurrID, Me.hwnd
        RefreshLtxtCurr
    End If
End Sub

Private Sub ltxtCurr_Edit()
    If mlngCurrID = 0 Then
        ShowMsg hwnd, "没有可供修改的项目", vbExclamation, Me.Caption
    Else
        Card.EditCard msgcurrency, mlngCurrID
        RefreshLtxtCurr mlngCurrID
        mclsList.BeginEdit
    End If
End Sub

'刷新币种参照
Private Sub RefreshLtxtCurr(Optional lngID As Long)
    Dim strSql As String
    Dim lngRow As Long
    Dim i As Byte
    On Error Resume Next
    
    strSql = "SELECT lngCurrencyID,strCurrencyName FROM Currencys" _
        & " WHERE blnIsInActive = 0 ORDER BY lngCurrencyID"
    With ltxtCurr
        .ClearRefer
        Set .Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        .Comparts = 2
        .AddRefer "<新增>"
        .AddRefer "<修改>"
        .AddRefer "<删除>"
    End With
    If lngID > 0 Then
        ltxtCurr.SeekId lngID
        If ltxtCurr.ID <> lngID Then
            lngRow = 1
            Do While lngRow <= msgMutiCurr.Rows - 1
                If C2lng(msgMutiCurr.TextMatrix(lngRow, mlngColCurrID)) = lngID Then
                    If mlngAlterID = 0 Then
                        strSql = "DELETE FROM FixedCost WHERE lngFixedAlterID=-1 AND lngCurrencyID=" & lngID
                    Else
                        strSql = "DELETE FROM FixedCost WHERE lngFixedAlterID=" & mlngAlterID & " AND lngCurrencyID=" & lngID
                    End If
                    gclsBase.ExecSQL strSql
                    With msgMutiCurr
                        If .Rows = 2 Then
                            For i = 0 To .Cols - 1
                                .TextMatrix(lngRow, i) = ""
                            Next i
                        Else
                            .RemoveItem lngRow
                            lngRow = lngRow - 1
                        End If
                    End With
                End If
                lngRow = lngRow + 1
            Loop
        End If
    End If
End Sub

Private Sub ltxtCurrItemNotExist()
    Dim lngID As Long
    
    If frmMsgAdd.MsgAddShow("增加币种", "币种“" & Trim(ltxtCurr.Text) & "”不存在或不可用，是否新增?") = vbOK Then
        lngID = Card.AddCard(msgcurrency) '调用卡片
        RefreshLtxtCurr
        mclsList.BeginEdit
    Else
        ltxtCurr.Text = ""
    End If
End Sub

Private Sub mclsList_AfterRefresh(lngRow As Long)
    Dim intDec As Integer
    
    With msgMutiCurr
        If GetValue(lngRow, mlngColCurrID) = gclsBase.NaturalCurId Then
            intDec = gclsBase.NaturalCurDec
        Else
            intDec = GetValue(lngRow, mlngColRateDec)
        End If
        If intDec > 0 Then
            .TextMatrix(lngRow, mlngColRate) = Format(GetValue(lngRow, mlngColRate), "0." & String(intDec, "0"))
        End If
        intDec = GetValue(lngRow, mlngColCurrDec)
        If intDec > 0 Then
            .TextMatrix(lngRow, mlngColCurrAmount) = Format(GetValue(lngRow, mlngColCurrAmount), "0." & String(intDec, "0"))
        End If
        intDec = gclsBase.NaturalCurDec
        If intDec > 0 Then
            If GetValue(lngRow, mlngColAmount) <> 0 Then
                .TextMatrix(lngRow, mlngColAmount) = Format(GetValue(lngRow, mlngColAmount), "0." & String(intDec, "0"))
            Else
                .TextMatrix(lngRow, mlngColAmount) = ""
            End If
        End If
    End With
End Sub

Private Sub mclsList_AfterSave()
    mclsList_AfterRefresh msgMutiCurr.Row
    ShowTotalRow
End Sub

Private Sub mclsList_BeforeEdit(blnCancel As Boolean)
    If msgMutiCurr.col = mlngColRate Then
        If GetValue(msgMutiCurr.Row, mlngColCurrID) = gclsBase.NaturalCurId Then
            blnCancel = True
        End If
    End If
End Sub

Private Sub mclsList_BeforeSave(blnCancel As Boolean)
    On Error Resume Next
    With msgMutiCurr
        If .Row = .Rows - 1 Then
            If .col = mlngColAmount Or .col = mlngColCurrAmount Then
                If .TextMatrix(msgMutiCurr.Row, mlngColCurr) <> "" Then
                    .Rows = .Rows + 1
                End If
            ElseIf .col = mlngColCurr Then
                If C2Dbl(.TextMatrix(.Row, mlngColAmount)) > 0 Then
                    .Rows = .Rows + 1
                End If
            End If
        End If
        If ltxtCurr.Visible Then
            .TextMatrix(.Row, mlngColCurrID) = ltxtCurr.ID
        End If
        If .col = mlngColRate Then
            If CBool(GetValue(.Row, mlngColInDirect, "Boolean")) Then
                .TextMatrix(.Row, mlngColAmount) = GetValue(.Row, mlngColCurrAmount) / txtEdit.Value
            Else
                .TextMatrix(.Row, mlngColAmount) = GetValue(.Row, mlngColCurrAmount) * txtEdit.Value
            End If
        End If
        If .col = mlngColCurrAmount Then
            If GetValue(.Row, mlngColRate) > 0 Then
                If CBool(GetValue(.Row, mlngColInDirect, "String")) Then
                    .TextMatrix(.Row, mlngColAmount) = txtEdit.Value / GetValue(.Row, mlngColRate)
                Else
                    .TextMatrix(.Row, mlngColAmount) = txtEdit.Value * GetValue(.Row, mlngColRate)
                End If
            End If
        End If
        If .col = mlngColAmount Then
            If GetValue(.Row, mlngColRate) > 0 Then
                If CBool(GetValue(.Row, mlngColInDirect, "String")) Then
                    .TextMatrix(.Row, mlngColCurrAmount) = txtEdit.Value * GetValue(.Row, mlngColRate)
                Else
                    .TextMatrix(.Row, mlngColCurrAmount) = txtEdit.Value / GetValue(.Row, mlngColRate)
                End If
            End If
            hLb(mlngColAmount) = C2Dbl(hLb(mlngColAmount)) + (txtEdit.Value - GetValue(msgMutiCurr.Row, mlngColAmount))
        End If
    End With
    mblnChanged = True
End Sub

Private Sub mclsList_DataValid(blnCancel As Boolean)
    Dim lngRow As Long
    
    If ltxtCurr.Visible Then
        If ltxtCurr.ReferRow < 4 Then
            blnCancel = True
            msgMutiCurr.TextMatrix(msgMutiCurr.Row, mlngColCurr) = ""
            If Trim$(ltxtCurr.Text) <> "" Then
                ltxtCurrItemNotExist
            End If
        End If
    ElseIf txtEdit.Visible Then
        If txtEdit.Value <= 0 Then
            blnCancel = True
            ShowMsg hwnd, "汇率金额必须大于0！", vbExclamation, Me.Caption
        End If
    Else
        For lngRow = 1 To msgMutiCurr.Rows - 1
            If lngRow <> msgMutiCurr.Row And GetValue(lngRow, mlngColCurr, "String") = Trim(ltxtCurr.Text) Then
                blnCancel = True
                ShowMsg hwnd, "币种重复,请重新输入！", vbExclamation, Me.Caption
                msgMutiCurr.TextMatrix(msgMutiCurr.Row, mlngColCurr) = ""
                Exit For
            End If
        Next lngRow
    End If
    If Not blnCancel And msgMutiCurr.col <> mlngColCurr Then
        If msgMutiCurr.TextMatrix(msgMutiCurr.Row, mlngColCurr) = "" Then
            blnCancel = True
            ShowMsg hwnd, "请先输入币种！", vbExclamation, Me.Caption
        End If
    End If
End Sub

Private Function GetValue(lngRow As Long, intCol As Integer, Optional strType As String = "Double") As Variant
    GetValue = GetGridValue(lngRow, intCol, strType, msgMutiCurr)
End Function

Private Sub RefreshGrid()
    msgMutiCurr.FixedCols = 0
    Set datCurr.Resultset = GetCost()
    If Not mblnCopyMode Then
        mclsList.SetupStyle
        With msgMutiCurr
            .Rows = .Rows + 1
            .ColWidth(1) = 0
            .ColWidth(2) = 0
            .ColWidth(3) = 0
            .ColWidth(4) = 0
            .ColWidth(5) = 0.3 * .width
            .ColWidth(6) = 0.2 * .width
            .ColWidth(7) = 0.2 * .width
            .ColWidth(8) = 0.2 * .width
            .ColAlignment(6) = flexAlignRightCenter
            .ColAlignment(7) = flexAlignRightCenter
            .ColAlignment(8) = flexAlignRightCenter
            mclsList.SetEditText "币种", , , , ltxtCurr
            mclsList.SetEditText "汇率", , , , txtEdit
            mclsList.SetEditText "原币金额", , , , txtEdit
            mclsList.SetEditText "本币金额", , , , txtEdit
            .Row = 1
            .col = mlngColCurr
        End With
        mclsList.ShowTotal = True
        Set mclsList.Form = Me
        ShowTotalRow
    End If
    datCurr.Resultset.Close
    Set datCurr.Resultset = Nothing
End Sub

Private Sub ShowTotalRow()
    Dim lngRow As Long
    
    mdblTotal = 0
    With msgMutiCurr
        For lngRow = 1 To .Rows - 1
            mdblTotal = mdblTotal + GetValue(lngRow, mlngColAmount)
            mclsList_AfterRefresh lngRow
        Next lngRow
        If .Rows > .FixedRows Then
            hLb(mlngColAmount) = Format(mdblTotal, "0.00")
        Else
            hLb(mlngColAmount) = ""
        End If
    End With
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And (Not mblnLocked) Then
        If msgMutiCurr.Row >= 1 And Trim(msgMutiCurr.TextMatrix(msgMutiCurr.Row, mlngColCurr)) <> "" Then
            mnuDelete.Enabled = True
        Else
            mnuDelete.Enabled = False
        End If
        PopupMenu mnuPopup, 1, x, y
    End If
End Sub

Private Sub msgMutiCurr_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And (Not mblnLocked) Then
        If msgMutiCurr.Row >= 1 And Trim(msgMutiCurr.TextMatrix(msgMutiCurr.Row, mlngColCurr)) <> "" Then
            mnuDelete.Enabled = True
        Else
            mnuDelete.Enabled = False
        End If
        PopupMenu mnuPopup, , x, y
    End If
End Sub

Private Sub mnuNew_Click()
    mblnChanged = True
    With msgMutiCurr
        If .TextMatrix(.Rows - 1, mlngColCurr) <> "" And C2Dbl(.TextMatrix(.Rows - 1, mlngColAmount)) > 0 Or .RowHeight(.Rows - 1) < 100 Then
            .AddItem .Row
            .Row = .Rows - 1
            .col = mlngColCurr
        Else
            .Row = .Rows - 1
            If .TextMatrix(.Rows - 1, mlngColCurr) <> "" Then
                .col = mlngColAmount
            Else
                .col = mlngColCurr
            End If
        End If
        mclsList.BeginEdit
    End With
End Sub

Private Sub mnuDelete_Click()
    If msgMutiCurr.Rows > msgMutiCurr.FixedRows Then
        mblnChanged = True
        msgMutiCurr.TextMatrix(msgMutiCurr.Row, mlngColAmount) = 0
        msgMutiCurr.RowHeight(msgMutiCurr.Row) = 0
        If msgMutiCurr.Row > msgMutiCurr.FixedRows Then
            msgMutiCurr.Row = msgMutiCurr.Row - 1
        End If
        ShowTotalRow
    End If
End Sub