frmcurrencylistcard.frm

金算盘软件代码

'Private Sub spin_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
'    mblnIsChanged = True
'End Sub

Private Sub txtCurrency_Change(Index As Integer)
    Select Case Index
           Case 0
                If strLen(txtCurrency(Index).Text) > 4 Then
                   SendKeys "{BS}"
                   Exit Sub
                End If
           Case 1
                If strLen(txtCurrency(Index).Text) > 10 Then
                   SendKeys "{BS}"
                   Exit Sub
                End If
    End Select
    
End Sub

Private Sub txtCurrency_KeyPress(Index As Integer, KeyAscii As Integer)
 mblnIsChanged = True

End Sub


Private Sub txtCurrency_LostFocus(Index As Integer)
'    mblnIsChanged = True
End Sub

Private Sub txtCurrency_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    mblnIsChanged = True
End Sub

Private Sub txtRate_Change()
    Dim i As Integer
    
        For i = 1 To strLen(txtRate.Text)
            If InStr(1, ".0123456789", Mid(txtRate, i, 1)) = 0 Then
               BKKEY txtRate.hwnd
               Exit Sub
            End If
        Next
        If Left(txtRate.Text, 1) = "-" Then
            BKKEY txtRate.hwnd
            Exit Sub
        ElseIf Not IsNum(Trim(txtRate.Text), TxtToDouble(txtspin(1).Text)) Then
            BKKEY txtRate.hwnd
            Exit Sub
        End If
        
        mblnIsChanged = True
End Sub

Private Function UpdateData() As Boolean
    Dim i As Integer, strSql As String
    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
       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
       End If
    End If
    
    For i = 0 To 1
        If Len(txtspin(i).Text) = 0 Then
           txtspin(i).Text = 0
        End If
    Next
     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) & "'"
          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 & "'"
          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
       End If
    End If
    
    gclsBase.BaseWorkSpace.BeginTrans  '开始写记录操作
  '  msgRate.TextMatrix(msgRate.Row, msgRate.col) = txtRate.Text
    If mblnIsNew Then
        If mCurrencyIsSave = False Then
           strSql = "INSERT INTO Currencys(strCurrencyCode,strCurrencyName," _
             & "blnIsInActive,blnIsIndirect,bytCurrencyDec,bytRateDec," _
             & "bytMatchMethod) VALUES('" & txtCurrency(0) & "','" _
             & txtCurrency(1) & "'," & chkStop & "," _
             & IIf(optMode(1), 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
        End If
        For i = 1 To msgRate.Rows - 1
            If Trim$(msgRate.TextMatrix(i, 2)) <> "" Then
                strSql = "INSERT INTO Rate(lngCurrencyID,strDate,dblRate) " _
                    & "VALUES(" & mlngCurID & ",'" _
                    & msgRate.TextMatrix(i, 1) & "'," _
                    & msgRate.TextMatrix(i, 2) & ")"
               gclsBase.ExecSQL (strSql)        'Then GoTo ErrHandle
            End If
        Next i
    Else
        strSql = "select strCurrencyCode from Currencys where lngCurrencyID<>" & mlngCurID _
                & " and strCurrencyCode='" & txtCurrency(0).Text & "'"
        Set recCur = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recCur.EOF Then
           ShowMsg Me.hwnd, "本币种编码已经存在，请重新输入！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
           GoTo ErrHandle
'           txtCurrency(0).SetFocus
'           Exit Function
        End If
        recCur.Close
        
        strSql = "UPDATE Currencys SET strCurrencyCode='" & txtCurrency(0).Text _
            & "',strCurrencyName='" & 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
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle   'gclsBase.BaseDB.Execute strSql
        For i = 1 To msgRate.Rows - 1
            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) & "'," _
                    & msgRate.TextMatrix(i, 2) & ")"
            ElseIf msgRate.TextMatrix(i, 0) = "H" And Trim$(msgRate.TextMatrix(i, 2)) _
                <> "" Then
                strSql = "UPDATE Rate SET dblRate=" & msgRate.TextMatrix(i, 2) _
                    & " WHERE lngCurrencyID=" & mlngCurID & " AND strDate='" _
                    & msgRate.TextMatrix(i, 1) & "'"
            Else
                strSql = ""
            End If
            If strSql <> "" Then
               If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle    'gclsBase.ExecSQL (strSql)
            End If
        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 Sub txtRate_KeyUp(KeyCode As Integer, Shift As Integer)
    If msgRate.col = 2 Then
        msgRate.Text = FormatShow(txtRate.Text, txtspin(1).Value)
    End If
End Sub

Private Sub txtRate_LostFocus()
    Dim i As Integer
    Dim strRate As String

    If Not ChickIsRight(txtRate.Text) Then Exit Sub
    If txtspin(1).Text = 0 Then
       strRate = "0"
    Else
       strRate = "0."
       For i = 1 To Val(txtspin(1).Text)
           strRate = strRate & "0"
       Next
    End If
    txtRate.Text = ""
    'If txtRate.Text <> "" Then
       'txtRate.Text = Format(txtRate.Text, strRate)
      msgRate.TextMatrix(msgRate.Row, 2) = Format(msgRate.TextMatrix(msgRate.Row, 2), strRate) ' txtRate.Text
      'txtRate.Visible = False
   ' End If
    
End Sub

Private Sub txtSpin_Change(Index As Integer)
'    If Len(txtspin(Index).Text) = 0 Then txtspin(Index).Text = 0
'    If Not ChickIsRight(txtspin(Index).Text) Then Exit Sub
'    If InStr(1, txtspin(Index).Text, ".") <> 0 Then
'       BKKEY txtspin(Index).hwnd
'       Exit Sub
'    End If
    Select Case txtspin(Index).Text
           Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9
           Case Else
                SendKeys "{BS}"
                'BKKEY txtspin(Index).hwnd
                Exit Sub
    End Select
    If Index = 1 Then
        UpdateRate
     End If
'
'    If Val(txtspin(Index).Text) > 9 Then
'       BKKEY txtspin(Index).hwnd  'SendKeys "{BS}"
'       Exit Sub
'    End If
'
End Sub

Public Function AddCard(Optional strName As String = "", Optional intModal As Integer = 0) As Long
    Dim lngResult As Integer
    
    'mblnIsNew = True
    If mblnIsChanged = True Then
       If mlngCurID > 0 Then
          lngResult = ShowMsg(0, "上一次修改的币种汇率还未保存，是否继续修改它？", _
                          vbYesNoCancel + vbQuestion + MB_TASKMODAL, "新增币种汇率")
          If lngResult = vbYes Then       '继续编辑上一次的固定资产类别
             Me.Show
             Exit Function
          ElseIf lngResult = vbNo Then
            ' gclsBase.BaseWorkSpace.RollBack
             Unload Me
          Else
             Me.Hide
             Exit Function
          End If
       Else
          lngResult = ShowMsg(0, "上一次新增的币种汇率还未保存，是否继续修改它？", _
                          vbYesNoCancel + vbQuestion + MB_TASKMODAL, "新增币种汇率")
          If lngResult = vbYes Then       '继续编辑上一次的固定资产类别
             Me.Show
             Exit Function
          ElseIf lngResult = vbNo Then
            ' gclsBase.BaseWorkSpace.RollBack
             Unload Me
          Else
             Me.Hide
             Exit Function
          End If
       End If
    End If
  '  gclsBase.BaseWorkSpace.BeginTrans  '开始写记录操作
    mlngCurID = 0
    mCurrencyIsSave = False
    InitCard strName
    cmdOk(2).Default = True
    If Me.WindowState = 1 Then Me.WindowState = 0
    Show
    'AddCard = mlngCurID
    Refresh
    ZOrder 0
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 CheckIDUsed("AccountBalance", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("BankInit", "lngCurrencyID", lngID) Then Exit Function
    If CheckIDUsed("AccountCurrency", "lngCurrencyID", lngID) Then Exit Function
    CurrencyIsUsed = False
End Function

Public Function DelCard(lngID As Long) As Boolean
    Dim strSql As String
    Dim blnIsDel As Boolean
    
    DelCard = False
    
    If CurrencyIsUsed(lngID) Then
        ShowMsg 0, "该币种已经有业务发生,不能删除!", vbExclamation + MB_TASKMODAL, "删除币种汇率"
        Exit Function
    End If
    If frmCurrencysList.IsShowCard(0) = True Then
       If lngID = frmCurrencyListCard.GetCurID Then
          ShowMsg Me.hwnd, "不能删除当前正在修改的币种！", vbExclamation + MB_SYSTEMMODAL, "删除币种汇率"
          Exit Function
       End If
    End If
    If ShowMsg(0, "你确实要删除该币种吗?", vbQuestion + vbYesNo + MB_TASKMODAL, "删除币种汇率") _
        = vbNo Then Exit Function
    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
          'gclsSys.SendMessage Me.hwnd, Message.msgcurrency
       End If
    End If
    DelCard = blnIsDel
End Function

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

Private Sub txtSpin_GotFocus(Index As Integer)
    txtspin(Index).SelStart = 0
    txtspin(Index).SelLenth = strLen(txtspin(Index).Text)
    mblnIsChanged = True
End Sub

Private Sub txtspin_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer, bCancel As Long)
    mblnIsChanged = True
End Sub

Private Sub txtSpin_LostFocus(Index As Integer)
   mblnIsChanged = True
End Sub

Private Sub txtspin_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Integer, y As Integer, bCancel As Long)
    mblnIsChanged = True
End Sub

Private Sub txtspin_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Integer, y As Integer, bCancel As Long)
   mblnIsChanged = True
End Sub