frmpositionlistcard.frm

金算盘软件代码

        Else
            lngResult = ShowMsg(Me.hwnd, "是否保存上一次编辑的货位？", vbYesNoCancel + vbQuestion, "货位卡片提示信息")
            If lngResult = vbYes Then       '保存上一次编辑的货位
                If Not SaveCard Then      '保存失败
                    lngResult = ShowMsg(Me.hwnd, "上一次编辑的货位保存失败，是否继续编辑它？", vbYesNoCancel + vbQuestion, "货位卡片提示信息")
                    If lngResult = vbYes Then
                        SendKeys "%{C}"
                        Exit Function
                    End If
                End If
            End If
        End If
    End If
    IsContinue = False
End Function

Private Sub InitCard(Optional strName As String)
    Dim recPosition As rdoResultset, Strsql As String
    
    mblnIsInit = True
    mlngPCodeID = 0
    mblnPIsDetail = False
    mblnPIsInActive = False
    If mblnIsNew Then
        txtInput(1).Text = ""
        txtInput(0).Text = Trim(strName)
        mlngLstID = 0
        lstDepartment.Text = ""
        chkPause.Value = Unchecked
    Else
        Strsql = "SELECT * FROM POSITIONVIEW WHERE lngPositionID=" & mlngPositionID
        Set recPosition = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
        txtInput(0).Text = recPosition!strPositionCode
        txtInput(1).Text = recPosition!strPositionName
        chkPause.Value = recPosition!blnIsInActive
        mblnIsInActive = (recPosition!blnIsInActive = 1)
        mblnIsDetail = (recPosition!blnIsDetail = 1)
        mintOldLevel = recPosition!intLevel
        lstDepartment.Text = Format(recPosition!strDepartmentCode, "@;;") & " " _
            & Format(recPosition!strDepartmentName, "@;;")
        mlngLstID = Format(recPosition!lngDepartmentID, "@;0;")
        mstrOldFullName = recPosition!strFullName
        mstrOldCode = txtInput(0).Text
        mstrOldName = txtInput(1).Text
    End If
    mblnIsInit = False
End Sub

'进入删除货位，判断记录是否是末级和被使用，删除记录
Public Function DelCard(ByVal lngID As Long) As Boolean
    Dim recSelect As rdoResultset
    Dim strCode As String, strPosition As String, Strsql As String
    
    If lngID = mlngPositionID And frmPositionList.IsShowCard Then
        ShowMsg 0, "不能删除正在修改的货位！", vbExclamation + MB_TASKMODAL, "删除货位"
        Show
        Exit Function
    End If
    DelCard = False
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    Strsql = "SELECT * FROM Position WHERE lngPositionID=" & lngID
    Set recSelect = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
    If recSelect.EOF Then
        DelCard = True
        recSelect.Close
        GoTo ErrHandle
    Else
        strCode = recSelect!strPositionCode
        strPosition = Trim(recSelect!strPositionCode) & " " _
            & Trim(recSelect!strPositionName)
        If recSelect!blnIsDetail = 0 Then
            ShowMsg 0, "货位“" & strPosition & "”有下级货位，不能删除！", _
                vbExclamation + MB_TASKMODAL, "删除货位"
            recSelect.Close
            GoTo ErrHandle
        End If
    End If
    recSelect.Close
    If CodeUsed(lngID) Then
        ShowMsg 0, "货位“" & strPosition & "”已经有业务发生，不能删除！", _
            vbExclamation + MB_TASKMODAL, "删除货位"
        GoTo ErrHandle
    End If
    If ShowMsg(0, "您确实要删除“" & strPosition & "”货位吗？", _
        vbQuestion + vbYesNo + MB_TASKMODAL, "删除货位") = vbNo Then
        GoTo ErrHandle
    End If
    Strsql = "DELETE FROM Position WHERE lngPositionID = " & lngID
    If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
    If Not ChangeHigherCardDetail("Position", "strPositionCode", strCode) Then
        GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
'    gclsSys.SendMessage CStr(Me.hwnd), Message.msgPosition
    DelCard = True
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollbackTrans
End Function

'判断记录是否被使用（可能有多张表会使用此编码）
Private Function CodeUsed(lngID As Long) As Boolean
    CodeUsed = True
    If CheckIDUsed("Item", "lngPositionID", lngID) Then Exit Function
    If CheckIDUsed("ItemActivityDetail", "lngPositionID", lngID) Then Exit Function
    If CheckIDUsed("PositionItemDetail", "lngPositionID", lngID) Then Exit Function
    If CheckIDUsed("StockTakingDetail", "lngPositionID", lngID) Then Exit Function
    CodeUsed = False
End Function

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

Private Sub Form_Activate()
    mclsMainControl_ChildActive
    frmMain.mnuEditShowList = True
    gclsSys.CurrFormName = Me.hwnd
End Sub

Private Sub Form_Load()
    Me.Hide
    Me.Left = -30000
    MsgForm.PleaseWait
    SetHelpID hwnd, 30032
    frmPositionList.IsShowCard = True
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 120, 60, 4755, 2025 '画边框
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 = "您要保存新增的货位"
            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 & "”货位已被修改，是否保存？"
        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)
    frmPositionList.IsShowCard = False
    mblnIsChanged = False
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub lstDepartment_AddNew()
    Dim lngID As Long
    
    lngID = frmDepartmentCard.AddCard(, vbModal)
    If lngID <> 0 Then mlngLstID = lngID
    setlistbox lstDepartment, 8, mlngLstID
    mblnIsChanged = True
'    SettingListBox lstDepartment, 11, mlngLstID
End Sub

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

Private Sub lstDepartment_Delete()
    If frmDepartmentCard.DelCard(mlngLstID, Me.hwnd) Then mlngLstID = 0
    setlistbox lstDepartment, 8, mlngLstID
    mblnIsChanged = True
'    SettingListBox lstDepartment, 11, mlngLstID
End Sub

Private Sub lstDepartment_Edit()
    frmDepartmentCard.EditCard mlngLstID, vbModal, lstDepartment.Text
    setlistbox lstDepartment, 8, mlngLstID
    mblnIsChanged = True
'    SettingListBox lstDepartment, 11, mlngLstID
End Sub

'当第一次进入列表框时，设置它的选项
Private Sub lstDepartment_GotFocus()
    
    If mblnIsNew Then
        cmdOKCancel(2).Default = False
    Else
        cmdOKCancel(0).Default = False
    End If
    If lstDepartment.Referrows <= 1 Then
'       SettingListBox lstDepartment, 11, mlngLstID
        setlistbox lstDepartment, 8, mlngLstID
    End If
End Sub

'根据列表框选择结果来调用卡片或存储调用卡片的参数
Private Sub lstDepartment_Choose()
    mlngLstID = lstDepartment.TextMatrix(lstDepartment.ReferRow, 1)
    mblnIsChanged = True
End Sub

Private Sub cmdokcancel_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(txtInput(0).Text)
'            mlngPositionID = 0
            InitCard
            txtInput(0).Text = strNextCode
            txtInput(0).SetFocus
            txtInput(0).SelStart = 0
            txtInput(0).SelLength = Len(txtInput(0).Text)
        End If
        Exit Sub
    ElseIf Index = 3 Then
        mstrNotes = frmNotePad.EditCard(Me.Caption, txtInput(0).Text, _
            txtInput(1).Text, mstrNotes)    '调记事
        Exit Sub
    End If
    Unload Me
    
End Sub

Private Function MergeCode() As Boolean
    MergeCode = False
    If Not DisplaceActivity("Item", "lngPositionID", mlngPCodeID, mlngPositionID) Then Exit Function
    If Not DisplaceActivity("ItemActivityDetail", "lngPositionID", mlngPCodeID, mlngPositionID) Then Exit Function
    If Not DisplaceActivity("PositionBalance", "lngPositionID", mlngPCodeID, mlngPositionID) Then Exit Function
    If Not DisplaceActivity("PositionDaily", "lngPositionID", mlngPCodeID, mlngPositionID) Then Exit Function
    If Not DisplaceActivity("PositionItemDetail", "lngPositionID", mlngPCodeID, mlngPositionID) Then Exit Function
    If Not DisplaceActivity("StockTakingDetail", "lngPositionID", mlngPCodeID, mlngPositionID) Then Exit Function
    MergeCode = True
End Function

Private Function SaveCard() As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recPosition As rdoResultset, Strsql As String
    Dim intIsDetail As Integer, intIsInActive As Integer
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans