frmprojectcard.frm

金算盘软件代码

    Dim blnIsDetail As Boolean
    
    strPCode = CodePrefix(strCode)
    If strPCode = "" Then
        ChangeHigherSum = True
        Exit Function
    End If
    
    strSql = "SELECT * FROM Project WHERE strProjectCode='" & strPCode & "'"
    Set recP = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not recP.EOF Then
        blnIsDetail = (recP("blnIsDetail") = 1)
        dblValue = recP("dblBudgetAmount")
    Else
        blnIsDetail = False
        dblValue = 0
    End If
    recP.Close
    
    If blnIsDetail Then
        strSql = "UPDATE Project SET dblBudgetAmount=" _
            & dblSum & " WHERE strProjectCode='" & strPCode & "'"
        dblSum = dblSum - dblValue
    Else
        strSql = "UPDATE Project SET dblBudgetAmount=dblBudgetAmount+" _
            & dblSum & " WHERE strProjectCode='" & strPCode & "'"
    End If
    ChangeHigherSum = gclsBase.ExecSQL(strSql)
    If Not ChangeHigherSum(strPCode, dblSum) Then Exit Function
End Function

Private Function TransActivity(ByVal lngPID As Long) As Boolean
    Dim intLevel As Integer, lngID(0 To 2) As Long
    Dim recProject As rdoResultset
    Dim strSql As String, strFullName As String
    
    strSql = "SELECT * FROM Project WHERE lngProjectID=" & lngPID
    Set recProject = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With recProject
    mblnIsDetail = False
'    mblnIsInActive = !blnIsInActive
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strProjectCode
    mstrName = !strProjectName
    mstrPrincipal = !strPrincipal
    mdblBudgetAmount = !dblBudgetAmount
    lngID(0) = Format(!lngAccountID, "@;0;")
    lngID(1) = Format(!lngClassID1, "@;0;")
    lngID(2) = Format(!lngClassID2, "@;0;")
    strFullName = !strFullName
    End With
    recProject.Close
    
    intLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    strSql = "UPDATE Project SET strProjectCode='" & Trim(txtInput(0).Text) & "',strFullName='" & mstrFullName _
        & "',strProjectName='" & Trim(txtInput(1).Text) & "',strPrincipal='" & IIf(txtInput(2).Text = "", " ", txtInput(2).Text) _
        & "',dblBudgetAmount=" & TxtToDouble(txtInput(3).Text) & ",blnIsInActive=" _
        & chkPause.Value & ",intLevel =" & intLevel & ",lngAccountID=" & mlngLstID(0) _
        & ",lngClassID1=" & mlngLstID(1) & ",lngClassID2=" & mlngLstID(2) & ",strStartDate='" _
        & Format(gclsBase.BaseDate, "YYYY-MM-DD") & "' WHERE lngProjectID=" & lngPID
    TransActivity = gclsBase.ExecSQL(strSql)
    If TransActivity Then
        mlngLstID(0) = lngID(0)
        mlngLstID(1) = lngID(1)
        mlngLstID(2) = lngID(2)
        mstrFullName = strFullName
    End If
End Function

Private Sub RefreshLst(ByVal Index As Integer)
    Select Case Index
    Case 0: setlistbox lstText(0), 0, mlngLstID(0)
    Case 1: setlistbox lstText(1), 36, mlngLstID(1)
    Case 2: setlistbox lstText(2), 37, mlngLstID(2)
    End Select
End Sub

Private Sub lstText_AddNew(Index As Integer)
    Dim lngID As Long
    
    Select Case Index
    Case 0: lngID = frmAccountCard.AddCard(, , vbModal, , True)
    Case 1: lngID = frmClass1Card.AddCard(, vbModal, True)
    Case 2: lngID = frmClass2Card.AddCard(, vbModal, True)
    End Select
    If lngID <> 0 Then mlngLstID(Index) = lngID
    RefreshLst Index
    mblnIsChanged = True
End Sub

Private Sub lstText_Change(Index As Integer)
    If ContainErrorChar(lstText(Index).Text, "`~!@#$%^&*=+'"";:,./?|\") Then BKKEY lstText(Index).hwnd
End Sub

Private Sub lstText_Choose(Index As Integer)
    If Not mblnIsEdit Then
        mlngLstID(Index) = lstText(Index).ID
        mblnIsChanged = Not mblnIsInit
    End If
End Sub

Private Sub lstText_Delete(Index As Integer)
    Select Case Index
    Case 0:
        If frmAccountCard.DelCard(mlngLstID(0), Me.hwnd) Then mlngLstID(0) = 0
    Case 1:
        If frmClass1Card.DelCard(mlngLstID(1)) Then mlngLstID(1) = 0
    Case 2:
        If frmClass2Card.DelCard(mlngLstID(2)) Then mlngLstID(2) = 0
    End Select
    RefreshLst Index
    mblnIsChanged = True
End Sub

Private Sub lstText_Edit(Index As Integer)
    mblnIsEdit = True
    If Format(mlngLstID(Index), "@;0;") = 0 Then
        Select Case Index
        Case 0:
            ShowMsg hwnd, "请先选择会计科目再进行修改！", vbExclamation, Caption
        Case 1:
            ShowMsg hwnd, "请先选择统计核算再进行修改！", vbExclamation, Caption
        Case 2:
            ShowMsg hwnd, "请先选择项目核算再进行修改！", vbExclamation, Caption
        End Select
    Else
        Select Case Index
        Case 0:
            frmAccountCard.EditCard mlngLstID(0), vbModal
        Case 1:
            frmClass1Card.EditCard mlngLstID(1), vbModal
        Case 2:
            frmClass2Card.EditCard mlngLstID(2), vbModal
        End Select
        RefreshLst Index
        mblnIsChanged = True
    End If
    mblnIsEdit = False
End Sub

Private Sub lstText_GotFocus(Index As Integer)
    If lstText(Index).Referrows <= 1 Then
        RefreshLst Index
    End If
    mblnIsInit = False
End Sub

Private Sub lstText_ItemNotExist(Index As Integer)
    Dim lngID As Long
    
    mblnNotExit = True
    Select Case Index
    Case 0:
        If frmMsgAdd.MsgAddShow("所属科目不存在", "科目列表中没有“" _
            & lstText(0).Text & "”！") = vbOK Then
            lngID = frmAccountCard.AddCard(lstText(0).Text, , vbModal, , True)
            If lngID <> 0 Then mlngLstID(0) = lngID
            RefreshLst 0
        Else
            lstText(0).Text = ""
        End If
    Case 1:
        If frmMsgAdd.MsgAddShow("所属统计核算不存在", "统计核算列表中没有“" _
            & lstText(1).Text & "”！") = vbOK Then
            lngID = frmClass1Card.AddCard(lstText(1).Text, vbModal, True)
            If lngID <> 0 Then mlngLstID(1) = lngID
            RefreshLst 1
        Else
            lstText(1).Text = ""
        End If
    Case 2:
        If frmMsgAdd.MsgAddShow("所属项目核算不存在", "项目核算列表中没有“" _
            & lstText(2).Text & "”！") = vbOK Then
            lngID = frmClass2Card.AddCard(lstText(2).Text, vbModal, True)
            If lngID <> 0 Then mlngLstID(2) = lngID
            RefreshLst 2
        Else
            lstText(2).Text = ""
        End If
    End Select
    mblnIsChanged = True
    mblnNotExit = False
End Sub

Private Sub lstText_LostFocus(Index As Integer)
    Dim strName As String
    If mblnIsEdit Then Exit Sub
    If Trim(lstText(Index).Text) = "" Then
        mlngLstID(Index) = 0
    Else
        If mblnIsNew And Trim(txtInput(1).Text) = "" Then
            strName = lstText(0).Text
            StringOut strName
            txtInput(1).Text = strName
        End If
    End If
    lstText(Index).MoveFocus
End Sub

Private Sub txtInput_Change(Index As Integer)
    
    Select Case Index
    Case 0
        If ContainErrorChar(txtInput(Index).Text, "'""|?`~!^*") Then BKKEY txtInput(Index).hwnd
    Case 1, 2
        If ContainErrorChar(txtInput(Index).Text, "'""|?`~-!^*") Then BKKEY txtInput(Index).hwnd
    Case 3
        If Not IsNum(txtInput(3).Text, 2, True) Then BKKEY txtInput(3).hwnd
    End Select
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub txtInput_GotFocus(Index As Integer)
    Select Case Index
    Case 3, 5: txtInput(Index).MaxLength = 12
    End Select
End Sub

Private Sub txtInput_KeyPress(Index As Integer, KeyAscii As Integer)
    Select Case Index
    Case 0
        If InStr("'""|?`~!^*", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    Case 1, 2
        If InStr("'""|?`~-!^*", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    Case 3
        If InStr("0123456789.", Chr(KeyAscii)) = 0 And KeyAscii <> 8 Then KeyAscii = 0
    End Select
End Sub

Private Sub txtInput_LostFocus(Index As Integer)
    Select Case Index
    Case 3, 5
        txtInput(Index).MaxLength = 18
        If Index = 3 Then
            txtInput(3).Text = Format(txtInput(3).Text, gclsBase.GetFormat(gclsBase.NaturalCurDec))
        Else
            txtInput(5).Text = Format(txtInput(5).Text, gclsBase.GetFormat(gclsBase.QuantityDec))
        End If
    End Select
End Sub

Private Sub SetTabIndex()
    Dim b As Byte
    Dim conX As Control
    
    On Error Resume Next
    For Each conX In Me.Controls
        Select Case conX.Name
        Case "cmdOKCancel", "sstProject", "chkPause"
        Case Else
            conX.TabStop = False
        End Select
    Next conX
    Select Case sstProject.Tab
    Case 0
        For b = 0 To 5
            txtInput(b).TabStop = True
            If b < 3 Then lstText(b).TabStop = True
        Next b
        txtNotes.TabStop = False
'        lstText.TabStop = True
        chkClose.TabStop = True
        dteClose.TabStop = dteClose.Enabled
        If dteClose.TabStop Then
            SetCmdIndex chkClose.TabIndex + 1
        Else
            SetCmdIndex dteClose.TabIndex + 1
        End If
    Case 1
        txtNotes.TabStop = True
        SetCmdIndex txtNotes.TabIndex + 1
    End Select
End Sub

Private Sub SetCmdIndex(ByVal Index As Integer)
    cmdOkCancel(0).TabIndex = Index
    cmdOkCancel(1).TabIndex = cmdOkCancel(0).TabIndex + 1
    cmdOkCancel(2).TabIndex = cmdOkCancel(1).TabIndex + 1
    chkPause.TabIndex = cmdOkCancel(2).TabIndex + 1
End Sub

Private Function ChangeHigherClose(ByVal strCode As String) As Boolean
    Dim recX As rdoResultset, strPCode As String, strSql As String
    
    ChangeHigherClose = True
    strPCode = CodePrefix(strCode)
    strSql = "SELECT * FROM Project WHERE strProjectCode='" & strPCode & "'"
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until strPCode = "" Or recX.EOF
        If recX!blnIsClosed = 0 Then Exit Do
        recX.Close
        strSql = "UPDATE Project SET blnIsClosed=0,strCloseDate=' '" & " WHERE " _
            & "strProjectCode='" & strPCode & "'"
        If Not gclsBase.ExecSQL(strSql) Then
            ChangeHigherClose = False
            Exit Function
        Else
            strPCode = CodePrefix(strPCode)
            strSql = "SELECT * FROM Project WHERE strProjectCode='" _
                & strPCode & "'"
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        End If
    Loop
    recX.Close
End Function

Private Sub txtNotes_Change()
    If ContainErrorChar(txtNotes.Text, "'""") Then BKKEY txtNotes.hwnd
End Sub

Private Sub txtNotes_KeyPress(KeyAscii As Integer)
    If InStr("'""", Chr(KeyAscii)) > 0 Then KeyAscii = 0
End Sub