frmcurrencynew.frm

金算盘软件代码

           ShowMsg 0, "币种编号“" & txtCurrency(0).Text & "”已经存在,请重新录入币种编号！", _
                         vbExclamation + MB_TASKMODAL, Me.Caption
           txtCurrency(0).SetFocus
        Else
           ShowMsg 0, "币种名称不能为重复！", _
                      vbExclamation + MB_TASKMODAL, Me.Caption
           txtCurrency(1).SetFocus
        End If
        reccur.Close
        IsSame = True
End Function

Private Function UpdateData() As Boolean
    Dim i As Integer, strSql As String, dblRate As Double
    Dim reccur As rdoResultset, lngCurID As Long
    
    On Error GoTo ErrHandle
   
    UpdateData = False
    If Trim$(txtCurrency(0)) = "" Then
        ShowMsg 0, "币种编号不能为空!", vbExclamation + MB_TASKMODAL, Me.Caption
        txtCurrency(0).SetFocus
        Exit Function
    Else
        If InStr(1, txtCurrency(0).Text, "'") <> 0 Then
          ShowMsg 0, "币种编号不能有‘'’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          txtCurrency(0).SetFocus
          Exit Function
       ElseIf InStr(1, txtCurrency(0).Text, "|") <> 0 Then
          ShowMsg 0, "币种编号不能有‘|’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          txtCurrency(0).SetFocus
          Exit Function
       End If
    End If
    If Trim$(txtCurrency(1)) = "" Then
        ShowMsg 0, "币种名称不能为空!", vbExclamation + MB_TASKMODAL, Me.Caption
        txtCurrency(1).SetFocus
        Exit Function
    Else
        If InStr(1, txtCurrency(1).Text, "'") <> 0 Then
          ShowMsg 0, "币种名称不能有‘'’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          txtCurrency(1).SetFocus
          Exit Function
        ElseIf InStr(1, txtCurrency(1).Text, "|") <> 0 Then
          ShowMsg 0, "币种名称不能有‘|’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          txtCurrency(1).SetFocus
          Exit Function
        End If
    End If
    
     If Not mblnIsChanged Then
        UpdateData = True
        Exit Function
    End If
  '  gclsBase.BaseWorkSpace.BeginTrans  '开始写记录操作
    
'    If mblnIsNew Then
       If mCurrencyIsSave = False Then
          strSql = "SELECT * FROM Currencys WHERE strCurrencyCode='" _
            & txtCurrency(0) & "' AND lngCurrencyID<>" & mlngCurID
          Set reccur = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
          If Not reccur.EOF Then
             ShowMsg 0, "币种编号“" & txtCurrency(0).Text & "”已经存在,请重新录入币种编号！", _
                         vbExclamation + MB_TASKMODAL, Me.Caption
             txtCurrency(0).SetFocus
             reccur.Close
             Exit Function
          End If
          reccur.Close
          strSql = "SELECT * FROM Currencys WHERE strCurrencyName='" _
            & txtCurrency(1).Text & "' AND lngCurrencyID<>" & mlngCurID
          Set reccur = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
          If Not reccur.EOF Then
             ShowMsg 0, "币种名称不能为重复！", _
                         vbExclamation + MB_TASKMODAL, Me.Caption
             txtCurrency(1).SetFocus
             reccur.Close
             Exit Function
          End If
          reccur.Close
       Else
          If IsSame Then Exit Function
       End If
'    End If
    
  '  msgRate.TextMatrix(msgRate.Row, msgRate.col) = txtRate.Text
    If mblnIsNew Then
        If mCurrencyIsSave = False Then
            mlngCurID = GetNewID("Currencys")
           strSql = "INSERT INTO Currencys(lngCurrencyID,strCurrencyCode,strCurrencyName," _
             & "blnIsInActive,blnIsIndirect,bytCurrencyDec,bytRateDec," _
             & "bytMatchMethod) VALUES(" & mlngCurID & ",'" & Trim(txtCurrency(0)) & "','" _
             & Trim(txtCurrency(1)) & "'," & chkStop & "," _
             & IIf(optMode(1).Value, 1, 0) & "," & txtspin(0).Text & "," & txtspin(1).Text & "," _
             & cboMode.ItemData(cboMode.ListIndex) & ")"
           If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'           strSql = "SELECT lngCurrencyID as CurID FROM Currencys WHERE " _
'              & "strCurrencyCode='" & txtCurrency(0).Text & "'"
'           Set reccur = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'           mlngCurID = reccur!CurID
'           reccur.Close
        Else
           strSql = "UPDATE Currencys SET strCurrencyCode='" & Trim(txtCurrency(0).Text) _
            & "',strCurrencyName='" & Trim(txtCurrency(1).Text) & "',blnIsInActive=" _
            & chkStop.Value & ",blnIsIndirect=" & IIf(optMode(1).Value, 1, 0) _
            & ",bytCurrencyDec=" & CByte(txtspin(0).Text) & ",bytRateDec=" _
            & CByte(txtspin(1).Text) & ",bytMatchMethod=" _
            & cboMode.ItemData(cboMode.ListIndex) & " where lngCurrencyID=" & mlngCurID
            gclsBase.BaseDB.Execute strSql
        End If
        For i = 1 To msgRate.Rows - 1
            If Trim$(msgRate.TextMatrix(i, 2)) <> "" Then
                dblRate = TxtToDouble(Format(msgRate.TextMatrix(i, 2)))
                strSql = "INSERT INTO Rate(lngCurrencyID,strDate,dblRate) " _
                    & "VALUES(" & mlngCurID & ",'" _
                    & msgRate.TextMatrix(i, 1) & "'," _
                    & dblRate & ")"
                gclsBase.BaseDB.Execute strSql
            End If
        Next i
    Else
        strSql = "UPDATE Currencys SET strCurrencyCode='" & Trim(txtCurrency(0).Text) _
            & "',strCurrencyName='" & Trim(txtCurrency(1).Text) & "',blnIsInActive=" _
            & chkStop.Value & ",blnIsIndirect=" & IIf(optMode(1).Value, 1, 0) _
            & ",bytCurrencyDec=" & CByte(txtspin(0).Text) & ",bytRateDec=" _
            & CByte(txtspin(1).Text) & ",bytMatchMethod=" _
            & cboMode.ItemData(cboMode.ListIndex) & " where lngCurrencyID=" & mlngCurID
        gclsBase.BaseDB.Execute strSql
        For i = 1 To msgRate.Rows - 1
            dblRate = TxtToDouble(Format(msgRate.TextMatrix(i, 2)))
            If msgRate.TextMatrix(i, 0) = "H" And Trim$(msgRate.TextMatrix(i, 2)) _
                = "" Then
                strSql = "DELETE FROM Rate WHERE lngCurrencyID=" & mlngCurID _
                    & " AND strDate='" & msgRate.TextMatrix(i, 1) & "'"
            ElseIf msgRate.TextMatrix(i, 0) <> "H" And Trim$(msgRate.TextMatrix(i, 2)) _
                <> "" Then
                strSql = "INSERT INTO Rate(lngCurrencyID,strDate,dblRate) VALUES(" _
                    & mlngCurID & ",'" & msgRate.TextMatrix(i, 1) & "'," & dblRate & ")"
            ElseIf msgRate.TextMatrix(i, 0) = "H" And Trim$(msgRate.TextMatrix(i, 2)) _
                <> "" Then
                strSql = "UPDATE Rate SET dblRate=" & dblRate _
                    & " WHERE lngCurrencyID=" & mlngCurID & " AND strDate='" _
                    & msgRate.TextMatrix(i, 1) & "'"
            Else
                strSql = ""
            End If
            If strSql <> "" Then gclsBase.ExecSQL (strSql)
        Next i
    End If
   ' gclsBase.BaseWorkSpace.CommitTrans
    mblnIsChanged = False
    UpdateData = True
    'gclsSys.SendMessage Me.hWnd, Message.msgcurrency
    Exit Function
ErrHandle:
    txtCurrency(0).SetFocus
   ' gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Function IsPeriodClose() As Boolean
    Dim strSql As String
    Dim reccur As rdoResultset
    
    IsPeriodClose = False
    strSql = "select lngcloseid from accountPeriod where intYear=" & cboYP(0).Text _
                 & " and bytperiod=" & cboYP(1).Text
    Set reccur = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If reccur.EOF Then
       txtRate.Visible = False
       IsPeriodClose = True
       Exit Function
    ElseIf reccur.rdoColumns(0) > 0 Then
       txtRate.Visible = False
       IsPeriodClose = True
       Exit Function
    Else
       IsPeriodClose = False
       txtRate.Visible = True
    End If
End Function

Private Sub txtRate_GotFocus()
    txtRate.SelStart = 0
    If IsPeriodClose = True Then Exit Sub
End Sub

Private Sub txtRate_KeyUp(KeyCode As Integer, Shift As Integer)
    If msgRate.col = 2 Then
        msgRate.Text = FormatShow(txtRate.Text, C2lng(txtspin(1).Text))
    End If
End Sub

Private Sub txtRate_LostFocus()
    txtRate.Visible = False
    txtRate.Text = ""
End Sub

Private Sub txtSpin_Change(Index As Integer)
    Select Case txtspin(Index).Text
           Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9
           Case Else
                If txtspin(Index).Text <> "" Then
                    txtspin(Index).Text = "0"
                End If
'                SendKeys "{BS}"
'                BKKEY txtspin(Index).hwnd
                Exit Sub
    End Select
    txtRate.MaxLength = 7
    If Index = 1 Then
        UpdateRate
        If txtspin(1).Value > 0 Then
            txtRate.MaxLength = 7 + txtspin(1).Value + 1
        End If
    End If
   If Not mblnIsInit Then mblnIsChanged = True
End Sub

Public Function AddCard(Optional strName As String = "", Optional intModal As Integer = 0) As Long
    Dim lngResult As Integer
    
    gclsBase.BaseWorkSpace.BeginTrans  '开始写记录操作
    mlngCurID = 0
    mCurrencyIsSave = False
    InitCard strName
    Show intModal
    AddCard = mlngCurID
End Function

Private Function CurrencyIsUsed(ByVal lngID As Long) As Boolean
    
    CurrencyIsUsed = True
    If CheckIDUsed("ActivityDetail", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("ItemActivity", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("VoucherDetail", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("PurchaseOrder", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("SaleOrder", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("VoucherDetail", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("ARAPInit", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("BankDetail", "lngCurrencyID", lngID) Then Exit Function
    
    If UsedInAccountDaily("lngCurrencyid", lngID) Then Exit Function
    If CheckIDUsed("BankInit", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("AccountCurrency", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("FixedCost", "lngCurrencyID", lngID) Then Exit Function
    CurrencyIsUsed = False
End Function

Public Function DelCard(ByVal lngID As Long, Optional ByVal lnghWnd As Long = 0, Optional blnFromList As Boolean = False) As Boolean
    Dim strSql As String
    Dim blnIsDel As Boolean
    
    DelCard = False
    
    If lngID = 1 Then
       ShowMsg lnghWnd, "不能删除本位币！", vbExclamation + MB_SYSTEMMODAL, "删除币种汇率"
       Exit Function
    End If
'    If frmCurrencysList.IsShowCard(0) = True Then
'       If lngID = frmCurrencyListCard.GetCurID Then
'          ShowMsg lnghWnd, "不能删除当前正在修改的币种！", vbExclamation + MB_SYSTEMMODAL, "删除币种汇率"
'          Exit Function
'       End If
'    End If
    If CurrencyIsUsed(lngID) Then
        ShowMsg lnghWnd, "该币种已经有业务发生,不能删除!", vbExclamation + MB_TASKMODAL, "删除币种汇率"
        Exit Function
    End If
    If ShowMsg(lnghWnd, "你确实要删除该币种吗?", vbQuestion + vbYesNo + MB_TASKMODAL + vbDefaultButton2, "删除币种汇率") _
        = vbNo Then Exit Function
    
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "DELETE FROM Currencys WHERE lngCurrencyID=" & lngID
    blnIsDel = gclsBase.ExecSQL(strSql)
    If blnIsDel = True Then
       strSql = "delete from rate where lngcurrencyid=" & lngID
       blnIsDel = gclsBase.ExecSQL(strSql)
       If blnIsDel = True Then
          strSql = "Delete from AccountDaily where lngCurrencyid=" & lngID
          blnIsDel = gclsBase.ExecSQL(strSql)
          If Not blnIsDel Then GoTo ErrHandle
          gclsBase.GetBaseInfo
          If Not blnFromList Then gclsSys.SendMessage Me.hwnd, Message.msgcurrency
       Else
          GoTo ErrHandle
       End If
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    DelCard = blnIsDel
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    Exit Function
End Function

Public Property Get GetCurID() As Long
    GetCurID = mlngCurID
End Property

'数据引入
Public Function ImportCurrency(ByVal strCurrencySource As String) As Integer
    Dim recCurrency As rdoResultset
    Dim strSql As String
    Dim strCode As String
    Dim strName As String
    Dim blnInDirect As Boolean, blnIsInActive As Boolean
    Dim bytCurrencydec As Integer
    Dim bytRateDec As Integer
    Dim bytMatchmethod As Integer
    Dim strTemp As String
    
    ImportCurrency = 0
    If GetString(strCurrencySource, strTemp, 1) Then
       strCode = Trim(strTemp)
    Else
       Exit Function
    End If
    
    If GetString(strCurrencySource, strTemp, 2) Then
       strName = Trim(strTemp)
    Else
       Exit Function
    End If
    
    If GetString(strCurrencySource, strTemp, 4) Then
       blnInDirect = (strTemp = "1")
    Else
       Exit Function
    End If
    
    If GetString(strCurrencySource, strTemp, 5) Then
       bytCurrencydec = Val(IIf(strTemp = "", 2, strTemp))
    Else
       Exit Function
    End If
    If GetString(strCurrencySource, strTemp, 6) Then
       bytRateDec = Val(IIf(strTemp = "", 4, strTemp))
    Else
       Exit Function
    End If
    
    If GetString(strCurrencySource, strTemp, 7) Then
       bytMatchmethod = Val(IIf(strTemp = "", 1, strTemp))
    Else
       Exit Function
    End If
    
    strSql = "SELECT * FROM Currencys WHERE strCurrencyCode='" _
             & strCode & "'"
    Set recCurrency = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCurrency.EOF Then
       ImportCurrency = 0
       recCurrency.Close
       Exit Function
    End If
    recCurrency.Close
    strSql = "SELECT * FROM Currencys WHERE strCurrencyName='" _
            & strName & "'"
    Set recCurrency = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recCurrency.EOF Then
       ImportCurrency = 0
       recCurrency.Close
       Exit Function
    End If
    
    strSql = "INSERT INTO Currencys(lngCurrencyID,strCurrencyCode,strCurrencyName," _
             & "blnIsInActive,blnIsIndirect,bytCurrencyDec,bytRateDec," _
             & "bytMatchMethod) VALUES(" & GetNewID("Currencys") & ",'" & strCode & "','" _
             & strName & "'," & IIf(blnIsInActive, 1, 0) & "," _
             & IIf(blnInDirect, 1, 0) & "," & bytCurrencydec & "," & bytRateDec & "," _
             & bytMatchmethod & ")"
    gclsBase.BaseWorkSpace.BeginTrans
    If gclsBase.ExecSQL(strSql) Then
       gclsBase.BaseWorkSpace.CommitTrans
       gclsSys.SendMessage Me.hwnd, Message.msgcurrency
       ImportCurrency = 1
    Else
       gclsBase.BaseWorkSpace.RollBacktrans
       ImportCurrency = 0
    End If
End Function

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

Private Sub txtspin_Validate(Index As Integer, Cancel As Boolean)
    txtspin(0).Text = C2lng(Trim(txtspin(0).Text))
    If C2Dbl(txtspin(0).Text) > 9 Then
        txtspin(0).Text = 9
    End If
    
    txtspin(1).Text = C2lng(Trim(txtspin(1).Text))
    If C2Dbl(txtspin(1).Text) > 9 Then
        txtspin(1).Text = 9
    End If
End Sub