frmprojectcard.frm

金算盘软件代码

        If Trim(strType) <> "" Then
            strMess = "“" & strType & "”"
        Else
            strMess = "该"
        End If
        ShowMsg 0, strMess & mstrTitle & "不存在,不能进行修改!", vbExclamation + MB_TASKMODAL, "修改" & mstrTitle
        Unload Me
    Else
        mblnIsNew = False
        mblnIsChanged = False
        mlngProjectID = lngID
        Caption = "修改" & mstrTitle
        cmdOkCancel(2).Visible = False
        InitCard
        Show vbModal
    End If
End Sub

'进入删除工程项目操作，判断编码是否是末级和被使用，删除记录
Public Function DelCard(ByVal lngID As Long, Optional lnghWnd As Long = 0) As Boolean
    Dim strSql As String, strCode As String, strType As String, strPCode As String
    Dim recProject As rdoResultset, dblSum As Double, lngAcnID As Long
    #If conVersionType = 1 Then
        mstrTitle = "在建工程"
    #Else
        mstrTitle = "工程项目"
    #End If

'    If lngID = mlngProjectID And frmCustomerList.IsShowCard(1) Then
'        ShowMsg lnghWnd, "不能删除正在修改的工程项目！", vbExclamation + MB_TASKMODAL, "删除工程项目"
'        Show vbModal
'        Exit Function
'    End If
    DelCard = False
    If gclsBase.AccountSys = "1" And gclsBase.Trade = "邮电通信" Then
        If IsCanDo(391) = False Then
            ShowMsg 0, "操作员" & gclsBase.OperatorName & "没有“在建工程”权限 ,不能删除！", vbExclamation + MB_TASKMODAL, "删除" & mstrTitle
            Exit Function
        End If
    End If
    strSql = "SELECT * FROM Project WHERE lngProjectID=" & lngID
    Set recProject = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recProject.EOF Then
        DelCard = True
        recProject.Close
        Exit Function
    Else
        strCode = Trim(recProject!strProjectCode)
        strType = Trim(recProject!strProjectCode) & " " & Trim(recProject!strProjectName)
        dblSum = recProject("dblBudgetAmount")
        lngAcnID = Format(recProject("lngAccountID"), "@;0;")
        If recProject!blnIsDetail = 0 Then
            ShowMsg lnghWnd, "“" & strType & "”有下级" & mstrTitle & "，不能删除！", _
                    vbExclamation + vbOKOnly + MB_TASKMODAL, "删除" & mstrTitle
            recProject.Close
            Exit Function
        End If
    End If
    recProject.Close
    strPCode = CodePrefix(strCode)
    If CodeUsed(lngID) Then
        ShowMsg lnghWnd, mstrTitle & "“" & strType & "”已有业务发生，不能删除！", _
            vbExclamation + vbOKOnly + MB_TASKMODAL, "删除" & mstrTitle
        Exit Function
    End If
    If ShowMsg(lnghWnd, "您确实要删除" & mstrTitle & "“" & strType & "”吗？" _
        , vbQuestion + vbYesNo + MB_TASKMODAL + vbDefaultButton2, "删除" & mstrTitle) = vbNo Then
        Exit Function
    End If
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "DELETE FROM Project WHERE lngProjectID = " & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    If Not ChangeHigherSum(strCode, 0 - dblSum) Then GoTo ErrHandle
    If Not ChangeHigherCardDetail("Project", "strProjectCode", strCode) Then GoTo ErrHandle
    If Not SetHighAccount(strPCode, lngAcnID) Then GoTo ErrHandle
    DelCard = True
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgProject
    gclsBase.BaseWorkSpace.CommitTrans
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Function SetHighAccount(ByVal strCode As String, ByVal lngAcnID As Long) As Boolean
    Dim recP As rdoResultset, blnDeatil As Boolean, strSql As String
    
    strSql = "SELECT * FROM Project WHERE strProjectCode='" & strCode _
        & "' AND blnIsDetail=1"
    Set recP = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recP.EOF Then
        SetHighAccount = True
        recP.Close
    Else
        recP.Close
        strSql = "UPDATE Project SET lngAccountID=" & lngAcnID _
            & " WHERE strProjectCode='" & strCode & "'"
        SetHighAccount = gclsBase.ExecSQL(strSql)
    End If
    
End Function

'判断编码是否被使用（可能有多张表会使用此编码）
Private Function CodeUsed(lngID As Long) As Boolean
    CodeUsed = True
    If lngID <> 0 Then
        If CheckIDUsed("ProjectFundIn", "lngProjectID", lngID) Then Exit Function
        If CheckIDUsed("ProjectInvoice", "lngProjectID", lngID) Then Exit Function
        If CheckIDUsed("ProjectOrder", "lngProjectID", lngID) Then Exit Function
    End If
    CodeUsed = False
End Function

Private Sub chkClose_Click()
    If chkClose.Value = vbChecked Then
        lblProj(7).Enabled = True
        dteClose.Enabled = True
'        dteClose.BackColor = &H80000005
    Else
        lblProj(7).Enabled = False
        dteClose.Enabled = False
        dteClose.Text = ""
'        dteClose.BackColor = &H80000004
    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub chkPause_Click()
'    Dim strType As String
'
'    strType = txtInput(0).Text & " " & txtInput(1).Text
'    If chkPause.Value = Checked And Not mblnIsNew Then
'        If CodeUsed(mlngProjectID) Then
'            ShowMsg hwnd, "工程项目“" & strType & "”已有业务发生，不能停用！", _
'                vbExclamation, Caption
'            chkPause.Value = Unchecked
'        End If
'    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
    Me.Refresh
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If mblnIsList Then
        mblnIsList = False
        Exit Sub
    End If
    If KeyAscii = vbKeyReturn Then
        If Me.ActiveControl.Name <> "txtNotes" Then BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOkCancel(0).Value = True
    End If
End Sub

Private Sub Form_Load()
    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
    Utility.LoadFormResPicture Me
    mblnNotExit = False
    #If conVersionType = 1 Then
        mstrTitle = "在建工程"
    #Else
        mstrTitle = "工程项目"
    #End If
    lblProj(7).Caption = mstrTitle & "日期(&D)"
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer, strMess As String
    
    If UnloadMode <> vbFormControlMenu Then Exit Sub
    If Trim(txtInput(0).Text & txtInput(1).Text) = "" Then Exit Sub
    If mblnIsChanged Then
        If mblnIsNew Then
            strMess = "您要保存新增的" & mstrTitle
            If txtInput(0).Text <> "" Then
                strMess = strMess & "“" & txtInput(0).Text & "”"
            End If
            If txtInput(1).Text <> "" Then
                strMess = strMess & "“" & txtInput(1).Text & "”"
            End If
            strMess = strMess & "吗？"
        Else
            strMess = "“" & txtInput(0).Text & "”" & " " _
                & "“" & txtInput(1).Text & "”" & mstrTitle & "已被修改，是否保存？"
        End If
        intMsgReturn = ShowMsg(hwnd, strMess, vbQuestion + vbYesNoCancel, Caption)
        If intMsgReturn = vbYes Then
            Cancel = Not SaveCard
        ElseIf intMsgReturn = vbCancel Then
            Cancel = True
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Utility.UnLoadFormResPicture Me
    mblnIsChanged = False
End Sub

Private Sub Form_Paint()
'  FrameBox Me.hwnd, 210, 2760, 210 + 3585, 2760 + 675
End Sub

Private Sub cmdokcancel_Click(Index As Integer)
    Dim strNextCode As String
    
    If mblnNotExit Then Exit Sub
    Select Case Index
        Case 0   '确定
            If mblnNotExit Then Exit Sub
            If SaveCard Then Unload Me
        Case 1   '取消
            Unload Me
        Case 2   '下一个
            If SaveCard Then
                strNextCode = GetNextCode(txtInput(0).Text)
'                mlngProjectID = 0
                InitCard
                txtInput(0).Text = strNextCode
                txtInput(0).SetFocus
                txtInput(0).SelStart = 0
                txtInput(0).SelLength = Len(txtInput(0).Text)
            End If
    End Select
End Sub

Private Function MergeCode() As Boolean
    MergeCode = False
    If Not DisplaceActivity("ProjectFundIn", "lngProjectID", mlngPCodeID, mlngProjectID) Then Exit Function
    If Not DisplaceActivity("ProjectInvoice", "lngProjectID", mlngPCodeID, mlngProjectID) Then Exit Function
    If Not DisplaceActivity("ProjectOrder", "lngProjectID", mlngPCodeID, mlngProjectID) Then Exit Function
    MergeCode = True
End Function

Private Function LstValid() As Boolean
    Dim recA As rdoResultset, strSql As String
    Dim strPCode As String
    
    LstValid = False
    strPCode = CodePrefix(txtInput(0).Text)
    If strPCode <> "" Then
        strSql = "UPDATE Project SET lngAccountID=NULL WHERE strProjectCode='" _
            & strPCode & "'"
        gclsBase.ExecSQL strSql
    End If
'    strSql = "SELECT lngAccountID FROM Account WHERE lngAccountID NOT IN" _
        & "(SELECT lngAccountID FROM Project WHERE lngProjectID<>" _
        & IIf(mblnIsNew, 0, mlngProjectID) & ") AND blnIsDetail=1 " _
        & "AND blnIsInActive=0 AND lngAccountID=" & mlngLstID
    If mlngLstID(0) <> 0 Then
        strSql = "SELECT lngAccountID FROM Account WHERE " _
            & "blnIsInActive=0 AND lngAccountID=" & mlngLstID(0)
        Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If recA.EOF Then
            ShowMsg hwnd, "会计科目没有被停用的科目，" _
                & "你选择的“" & lstText(0).Text & "”无效，请重新选择！", vbExclamation, Caption
            LstValid = False
            lstText(0).SetFocus
            recA.Close
            Exit Function
        End If
        recA.Close
    End If
    
'    strSql = "SELECT lngAccountID FROM Project WHERE lngProjectID<>" _
'        & IIf(mblnIsNew, 0, mlngProjectID) & " AND lngAccountID=" & mlngLstID(0)
'    Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
'    If Not recA.EOF Then
'        ShowMsg hwnd, "会计科目必须是没有被别的工程项目使用，并且没有被停用的科目，" _
'            & "你选择的“" & lstText(0).Text & "”无效，请重新选择！", vbExclamation, Caption
'        LstValid = False
'        lstText(0).SetFocus
'        recA.Close
'        Exit Function
'    Else
'        LstValid = True
'    End If
'    recA.Close
    
    If mlngLstID(1) <> 0 Then
        strSql = "SELECT lngClassID FROM Class1 WHERE " _
            & "blnIsInActive=0 AND lngClassID=" & mlngLstID(1)
        Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If recA.EOF Then
            ShowMsg hwnd, "统计核算必须是没有被停用，" _
                & "你选择的“" & lstText(1).Text & "”无效，请重新选择！", vbExclamation, Caption
            LstValid = False
            recA.Close
            lstText(1).SetFocus
            Exit Function
        End If
    End If
    
    If mlngLstID(2) <> 0 Then
        strSql = "SELECT lngClassID FROM Class2 WHERE " _
            & "blnIsInActive=0 AND lngClassID=" & mlngLstID(2)
        Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)