frmpositionlistcard.frm

金算盘软件代码

    
    If Trim$(txtInput(0).Text) = "" Then
        ShowMsg hwnd, "货位编码不能为空!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    
    If InStr(1, txtInput(0).Text, mstrOldCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "货位不能修改为自己的下级货位!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If InStr(1, mstrOldCode, txtInput(0).Text & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "货位不能修改为自己的上级货位!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If Trim$(txtInput(1).Text) = "" Then
        ShowMsg hwnd, "货位名称不能为空!", vbExclamation, Caption
        txtInput(1).SetFocus
        GoTo ErrHandle
    End If
    If Trim(lstDepartment.Text) = "" Then mlngLstID = 0
    If Not ItemIsValid("Department", "lngDepartmentID", mlngLstID) Then
        ShowMsg hwnd, "部门应该是末级，您选择的“" & lstDepartment.Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstDepartment.SetFocus
        GoTo ErrHandle
    End If
    
    intResult = CodeCheck("Position", "strPositionCode", "lngPositionID", _
        mblnIsNew, txtInput(0).Text, txtInput(1).Text, mstrOldCode, _
        mstrOldFullName, mstrFullName, mlngPCodeID, mblnPIsDetail, mblnPIsInActive, _
        mblnIsDetail)
    If intResult = -1 Then
        If mblnIsNew Then
            ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "“的上级货位" _
                & "不存在,请先增加上级货位”" & CodePrefix(txtInput(0).Text) _
                    & "“", vbExclamation, Caption
        Else
            ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "“的上级货位" _
                & "不存在,请重新修改货位”" _
                & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
        End If
        txtInput(0).SetFocus
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            ShowMsg hwnd, "货位编码“" & Trim$(txtInput(0).Text) _
                & "”已经存在,请重新录入货位编码", vbExclamation, Caption
            txtInput(0).SetFocus
            GoTo ErrHandle
        Else
            If Not mblnPIsDetail Or (mblnIsInActive <> mblnPIsInActive) Or Not mblnIsDetail Then
                ShowMsg hwnd, "货位“" & mstrOldCode & "”与货位“" _
                    & Trim$(txtInput(0).Text) & "”不能合并,请重新修改货位编码“" _
                    & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
                txtInput(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(hwnd, "是否将货位“" & mstrOldCode & "”与“" _
                    & Trim$(txtInput(0).Text) & "”进行合并?", vbQuestion + vbYesNo, _
                     Caption) = vbNo Then
                    txtInput(0).SetFocus
                    GoTo ErrHandle
                Else
                    blnMerge = True
                End If
            End If
        End If
    ElseIf intResult = -3 Then
        ShowMsg hwnd, "货位编码太长,请重新修改编码!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    Else
        If mblnIsNew And mblnPIsDetail Then
            If CodeUsed(mlngPCodeID) Then
                If ShowMsg(hwnd, "货位“" & CodePrefix(txtInput(0).Text) _
                    & "”是一个已经发生业务的末级货位," _
                    & "是否在该货位下新增明细货位“" & Trim$(txtInput(0).Text) & "”," _
                    & "并将发生的所有业务转到新增的明细货位?", vbQuestion + vbYesNo, _
                    Caption) = vbNo Then
                    txtInput(0).SetFocus
                    GoTo ErrHandle
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
    If CheckSameName("Position", "strPositionCode", txtInput(0).Text, _
        "strPositionName", txtInput(1).Text, "lngPositionID", _
        IIf(mblnIsNew, 0, mlngPositionID)) Then
        ShowMsg hwnd, "已有同级货位使用了" & "“" & txtInput(1).Text & "“" & _
            ",请重新录入货位名称!", _
            vbExclamation, Caption
        txtInput(1).SetFocus
        recPosition.Close
        GoTo ErrHandle
    End If
    mstrCode = txtInput(0).Text
    mstrName = txtInput(1).Text
    mblnIsInActive = (chkPause.Value = vbChecked)
    mblnIsDetail = True
    mstrStartDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
    mintLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    If mblnIsNew Then
        If mblnPIsDetail Then
            If blnMerge Then    '上级编码是已使用的末级编码,合并业务
                If Not TransActivity(mlngPCodeID) Then GoTo ErrHandle
            Else
                Strsql = "UPDATE Position SET blnIsDetail=0 WHERE " _
                    & "lngPositionID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            End If
        End If
        If Not mblnIsInActive And mblnPIsInActive And mlngPCodeID <> 0 Then
            If ShowMsg(hwnd, "上级货位已经被停用,是否启用上级货位？", _
                vbQuestion + vbYesNo, Caption) = vbNo Then
                mblnIsInActive = True
                 Strsql = "UPDATE Position SET blnIsInActive=True WHERE " _
                    & "lngPositionID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            Else
                mblnIsInActive = False
            End If
        End If
        intIsDetail = IIf(mblnIsDetail, 1, 0)
        intIsInActive = IIf(mblnIsInActive, 1, 0)
        Strsql = "INSERT INTO Position(lngPositionID,strPositionCode,strPositionName," _
            & "strFullName,blnIsInActive,intLevel,blnIsDetail,lngDepartmentID," _
            & "strNotes,strStartDate) VALUES (" & GetNewID("Position") & ",'" & mstrCode _
            & "','" & mstrName & "','" & mstrFullName & "'," & intIsInActive & "," _
            & mintLevel & "," & intIsDetail & "," & mlngLstID & ",'" & mstrNotes _
            & "','" & mstrStartDate & "')"   '插入数据库
        If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
        Strsql = "SELECT * FROM Position WHERE strPositionCode='" & txtInput(0).Text & "'"
        Set recPosition = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
        mlngPositionID = recPosition!lngPositionID
        recPosition.Close
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode Then GoTo ErrHandle
            Strsql = "DELETE FROM Position WHERE lngPositionID=" & mlngPositionID
            If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
        Else
            intIsInActive = IIf(mblnIsInActive, 1, 0)
            Strsql = "UPDATE Position SET strPositionCode='" & mstrCode _
                & "',strPositionName='" & mstrName & "',strFullName='" & mstrFullName _
                & "',blnIsInActive=" & intIsInActive & ",intLevel =" & mintLevel _
                & ",lngDepartmentID=" & mlngLstID & ",strNotes='" & mstrNotes _
                & "' WHERE lngPositionID=" & mlngPositionID
            If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            If Not ChangeLowerCardCodeAndFullName("Position", "strPositionCode", _
                "strFullName", "lngPositionID", mstrOldCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
'            If Not ChangeLowerCardCodeAndFullName("Position", "strPositionCode", _
                "strFullName", mstrOldCode, mstrOldName, mstrCode, mstrName, "lngPositionID") _
                    Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive("Position", "strPositionCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
            If mblnPIsDetail Then
                Strsql = "UPDATE Position SET blnIsDetail=0 WHERE lngPositionID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail("Position", "strPositionCode", _
            mstrOldCode) Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive("Position", "strPositionCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    gclsSys.SendMessage Me.hwnd, Message.msgPosition
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
End Function

Private Sub lstDepartment_ItemNotExist()
    Dim intMsgReturn As Integer, lngID As Long
    
    intMsgReturn = frmMsgAdd.MsgAddShow("所属部门不存在", "部门列表中没有“" _
        & lstDepartment.Text & "”！")
    If intMsgReturn = vbOK Then
        lngID = frmDepartmentCard.AddCard(lstDepartment.Text, vbModal)
        If lngID <> 0 Then mlngLstID = lngID
        setlistbox lstDepartment, 8, mlngLstID
    Else
        lstDepartment.Text = ""
    End If
    mblnIsChanged = True
End Sub

Private Sub lstDepartment_KeyUp(KeyCode As Integer, Shift As Integer)
'    If KeyCode = vbKeyReturn Then SendKeys "{TAB}"
End Sub

Private Sub lstDepartment_LostFocus()
    If mblnIsNew Then
        cmdOKCancel(2).Default = True
    Else
        cmdOKCancel(0).Default = True
    End If
    BKKEY lstDepartment.hwnd, vbKeyHome
End Sub

Private Sub mclsMainControl_ChildActive()
    gclsSys.CurrFormName = Me.hwnd
End Sub

Private Sub mclsMainControl_EditShowList()
    ShowRelationList
End Sub

Private Sub txtInput_Change(Index As Integer)
    Dim strErr As String
    
    If Index = 0 Then
        strErr = "'""|?/`~\.>, <;;:!@#$%^&*=+"
    Else
        strErr = "'""|?/`~\.>,-<;;:!@#$%^&*=+"
    End If
    If ContainErrorChar(txtInput(Index).Text, strErr) Then
        BKKEY txtInput(Index).hwnd
    End If
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Function TransActivity(ByVal lngPID As Long) As Boolean
    Dim intLevel As Integer, lngDepartmentID As Long
    Dim recPosition As rdoResultset
    Dim Strsql As String, strFullName As String, strNotes As String
    
    Strsql = "SELECT * FROM Position WHERE lngPositionID=" & lngPID
    Set recPosition = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
    With recPosition
    mblnIsDetail = False
'    mblnIsInActive = !blnIsInActive
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strPositionCode
    mstrName = !strPositionName
    strFullName = !strFullName
    strNotes = Format(!strNotes, "@;;")
    lngDepartmentID = !lngDepartmentID
    End With
    recPosition.Close
    
    intLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    Strsql = "UPDATE Position SET strPositionCode='" & txtInput(0).Text _
        & "',strPositionName='" & txtInput(1).Text & "',strFullName='" & mstrFullName _
        & "',blnIsInActive=" & chkPause.Value & ",intLevel =" & intLevel _
        & ",strNotes='" & IIf(mstrNotes = "", " ", mstrNotes) _
        & "',lngDepartmentID=" & mlngLstID & ",strStartDate='" _
        & Format(Date, "YYYY-MM-DD") & "' WHERE lngPositionID=" & lngPID
    TransActivity = gclsBase.ExecSQL(Strsql)
    If TransActivity Then
        mstrFullName = strFullName
        mstrNotes = strNotes
        mlngLstID = lngDepartmentID
    End If
End Function