frmdepcardnew.frm

金算盘软件代码

    CodeIsUsed = False
End Function

Private Sub chkStop_Click()
'    Dim strDep As String
'
'    strDep = txtDepartment(0).Text & " " & txtDepartment(1).Text
'    If chkStop.Value = Checked And Not mblnIsNew Then
'        If CodeIsUsed(mlngDepartmentID) Then
'            ShowMsg hwnd, strDep & "部门已有业务发生,不能停用！", vbExclamation, Caption
'            chkStop.Value = Unchecked
'        End If
'    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Sub cmdOK_Click(Index As Integer)
    Dim strNextCode As String
    
    If Index = 0 Then
        If Not SaveCard Then Exit Sub
    ElseIf Index = 2 Then
        If SaveCard Then
            strNextCode = GetNextCode(txtDepartment(0).Text)
'            mlngDepartmentID = 0
            InitCard
            txtDepartment(0).Text = strNextCode
            txtDepartment(0).SetFocus
            txtDepartment(0).SelStart = 0
            txtDepartment(0).SelLength = Len(txtDepartment(0).Text)
        End If
        Exit Sub
    ElseIf Index = 3 Then
        mstrNotes = frmNotePad.EditCard(Me.Caption, txtDepartment(0).Text, _
            txtDepartment(1).Text, mstrNotes)    '调记事
        mblnIsChanged = True
        Exit Sub
    End If
    Unload Me
    
End Sub

Public Function DelCard(ByVal lngID As Long, Optional lnghWnd As Long = 0) As Boolean
    Dim recDep As rdoResultset, strSql As String
    Dim strDep As String, strCode As String
    
'    If lngID = mlngDepartmentID And frmEmployeeList.IsShowCard(0) Then
'        ShowMsg lnghWnd, "不能删除正在修改的部门！", vbExclamation + MB_TASKMODAL, "删除部门"
'        Show vbModal
'        Exit Function
'    End If
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    DelCard = False
    strSql = "SELECT * FROM Department WHERE lngDepartmentID=" & lngID
    Set recDep = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recDep.EOF = True Then
        strCode = recDep!strDepartmentCode
        strDep = "“" & Trim(recDep!strDepartmentCode) & " " _
            & Trim(recDep!strDepartmentName) & "”"
        If recDep!blnIsDetail = 0 Then
            ShowMsg lnghWnd, strDep & "有下级部门,不能删除！", vbExclamation + MB_TASKMODAL, "删除部门"
            GoTo ErrHandle
        End If
    Else
        DelCard = True
        GoTo ErrHandle
    End If
    If CodeIsUsed(lngID, strCode & " " & recDep!strDepartmentName) Then
        ShowMsg lnghWnd, strDep & "部门已有业务发生,不能删除！", vbExclamation + MB_TASKMODAL, "删除部门"
        GoTo ErrHandle
    End If
    If ShowMsg(lnghWnd, "你确实要删除" & strDep & "部门吗？", vbQuestion + vbYesNo + MB_TASKMODAL + vbDefaultButton2, _
        "删除部门") = vbNo Then GoTo ErrHandle
    strSql = "DELETE FROM Department WHERE lngDepartmentID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    If Not ChangeHigherCardDetail("Department", "strDepartmentCode", strCode) Then GoTo ErrHandle
    gclsBase.BaseWorkSpace.CommitTrans
    DelCard = True
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgDepartment
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If mblnIsList Then
        mblnIsList = False
        Exit Sub
    End If
    If KeyAscii = vbKeyReturn 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
        cmdOK(0).Value = True
    End If
End Sub

Private Sub Form_Load()
    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
'    SetHelpID hwnd, 30009
    Utility.LoadFormResPicture Me
'    frmEmployeeList.IsShowCard(0) = True
    mblnIsChanged = False
'    SendKeys "%{C}"
    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_Paint()
  FrameBox Me.hwnd, 180, 170, 4335, 2100
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(txtDepartment(0).Text & txtDepartment(1).Text) = "" Then Exit Sub
    If mblnIsChanged Then
        If mblnIsNew Then
            strMess = "您要保存新增的部门"
            If txtDepartment(0).Text <> "" Then
                strMess = strMess & "“" & txtDepartment(0).Text & "”"
            End If
            If txtDepartment(1).Text <> "" Then
                strMess = strMess & "“" & txtDepartment(1).Text & "”"
            End If
            strMess = strMess & "吗？"
        Else
            strMess = "“" & txtDepartment(0).Text & "”" & " " _
                & "“" & txtDepartment(1).Text & "”部门已被修改，是否保存？"
        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
'    frmEmployeeList.IsShowCard(0) = False
    Utility.UnLoadFormResPicture Me
    mblnIsChanged = False
End Sub

Private Function InitCard(Optional strName As String = "") As Boolean
     Dim recDepartment As rdoResultset, strSql As String
    
    InitCard = True
    mblnIsInit = True
    mlngPCodeID = 0
    mblnPIsDetail = False
    mblnPIsInActive = False
    If Not mblnIsNew Then
        strSql = "SELECT * FROM Department WHERE lngDepartmentID=" _
            & mlngDepartmentID
        Set recDepartment = gclsBase.BaseDB.OpenResultset(strSql, _
            rdOpenStatic)
        With recDepartment
            txtDepartment(0).Text = !strDepartmentCode
            mstrLastCode = !strDepartmentCode
            txtDepartment(1).Text = !strDepartmentName
            mstrLastName = !strDepartmentName
            mintOldLevel = !intLevel
            mstrNotes = Format(!strNotes, "@;;")
            mblnIsInActive = !blnIsInActive
            mblnIsDetail = !blnIsDetail
            mstrOldFullName = !strFullName
            chkStop.Value = IIf(!blnIsInActive, 1, 0)
        End With
        recDepartment.Close
    Else
        txtDepartment(1).Text = ""
        txtDepartment(0).Text = Trim(strName)
        mstrNotes = ""
        chkStop.Value = 0
    End If
    mblnIsInit = False
End Function

Public Function MergeCode(ByVal lngPID As Long, ByVal lngID As Long) As Boolean
    MergeCode = False
    If Not MergeAccountDaily(lngPID, lngID, "lngDepartmentID") Then Exit Function
    If Not DisplaceActivity("ActivityDetail", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If gclsBase.ControlAccount Then
        If Not DisplaceActivity("ARAPInit", "lngDepartmentID", lngPID, lngID) Then Exit Function
    Else
        If Not DisplaceActivity("ARAPInit1", "lngDepartmentID", lngPID, lngID) Then Exit Function
    End If
    If Not MergeBudgetBalance(lngPID, lngID, "lngDepartmentID") Then Exit Function
    If Not DisplaceActivity("CostPrice", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("Employee", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("FixedDepartment", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("ItemActivity", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("Position", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("PurchaseOrder", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("Salary", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("SaleOrder", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("StockTaking", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("TransVoucherDetail", "lngDepartmentID", lngPID, lngID) Then Exit Function
    If Not DisplaceActivity("VoucherDetail", "lngDepartmentID", lngPID, lngID) Then Exit Function
    MergeCode = True
End Function

Private Function SaveCard(Optional blnByAdd As Boolean = False) As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recDepartment As rdoResultset, strSql As String
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtDepartment(0).Text) = "" Then
        If Not blnByAdd Then
            ShowMsg hwnd, "部门编码不能为空!", vbExclamation, Caption
            txtDepartment(0).SetFocus
        End If
        GoTo ErrHandle
    End If
    
    If InStr(1, txtDepartment(0).Text, mstrLastCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "部门不能修改为自己的下级部门!", vbExclamation, Caption
        txtDepartment(0).SetFocus
        GoTo ErrHandle
    End If
    If InStr(1, mstrLastCode, txtDepartment(0).Text & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "部门不能修改为自己的上级部门!", vbExclamation, Caption
        txtDepartment(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim$(txtDepartment(1).Text) = "" Then
        If Not blnByAdd Then
            ShowMsg hwnd, "部门名称不能为空!", vbExclamation, Caption
            txtDepartment(1).SetFocus
        End If
        GoTo ErrHandle
    End If
    
    intResult = CodeCheck("Department", "strDepartmentCode", "lngDepartmentID", _
        mblnIsNew, txtDepartment(0).Text, txtDepartment(1).Text, mstrLastCode, _
        mstrOldFullName, mstrFullName, mlngPCodeID, mblnPIsDetail, mblnPIsInActive, _
        mblnIsDetail)