frmpositioncard.frm

金算盘软件代码

        chkPause.Value = Unchecked
    Else
        strSql = "SELECT Position.*,strDepartmentCode,strDepartmentName FROM " _
            & "Position,Department WHERE Position.lngDepartmentID=" _
            & "Department.lngDepartmentID(+)" & " AND lngPositionID=" & mlngPositionID
        Set recPosition = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        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, Optional lnghWnd As Long = 0) As Boolean
    Dim recSelect As rdoResultset
    Dim strCode As String, strPosition As String, strSql As String
    
    DelCard = False
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "SELECT * FROM Position WHERE lngPositionID=" & lngID
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    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 lnghWnd, "货位“" & strPosition & "”有下级货位，不能删除！", _
                vbExclamation + MB_TASKMODAL, "删除货位"
            recSelect.Close
            GoTo ErrHandle
        End If
    End If
    recSelect.Close
    If CodeUsed(lngID) Then
        ShowMsg lnghWnd, "货位“" & strPosition & "”已经有业务发生，不能删除！", _
            vbExclamation + MB_TASKMODAL, "删除货位"
        GoTo ErrHandle
    End If
    If ShowMsg(lnghWnd, "您确实要删除“" & strPosition & "”货位吗？", _
        vbQuestion + vbYesNo + MB_TASKMODAL + vbDefaultButton2, "删除货位") = vbNo Then
        GoTo ErrHandle
    End If
    strSql = "UPDATE Item SET lngPositionID=0 WHERE lngPositionID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    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, Optional blnForDel As Boolean = True) As Boolean
    CodeUsed = True
    If CheckIDUsed("ItemActivityDetail", "lngPositionID", lngID) Then Exit Function
    If CheckIDUsed("StockTakingDetail", "lngPositionID", lngID) Then Exit Function
    If Not blnForDel Then
        If CheckIDUsed("Item", "lngPositionID", lngID) Then Exit Function
    End If
    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()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    mblnIsRefer = lstDepartment.ReferVisible
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If mblnIsList Then
        mblnIsList = False
        Exit Sub
    End If
    If KeyAscii = vbKeyReturn Then
        If Not mblnIsRefer Then
            BKKEY Me.ActiveControl.hwnd, vbKeyTab
        End If
    ElseIf KeyAscii = vbKeyEscape Then
        cmdOKCancel(1).Value = Not mblnIsRefer
    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
    mblnNotExit = False
'    SetHelpID hwnd, 30032
    Utility.LoadFormResPicture Me
'    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, 150, 150, 4700, 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)
    On Error Resume Next
    Unload frmDepartmentCard
    mblnIsChanged = False
    Utility.UnLoadFormResPicture Me
End Sub

Private Sub lstDepartment_AddNew()
    Dim lngID As Long
    
    lngID = frmDepartmentCard.AddCard(, vbModal, True)
    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()
    If mlngLstID = 0 Then
        ShowMsg hwnd, "请先选择所属部门再进行修改！", vbExclamation, Caption
    Else
        frmDepartmentCard.EditCard mlngLstID, vbModal, lstDepartment.Text
        setlistbox lstDepartment, 8, mlngLstID
        If lstDepartment.Text = "" Then mlngLstID = 0
        mblnIsChanged = True
    '    SettingListBox lstDepartment, 11, mlngLstID
    End If
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.ID
    mblnIsChanged = True
End Sub

Private Sub cmdokcancel_Click(Index As Integer)
    Dim strNextCode As String
    
    If mblnNotExit Then Exit Sub
    If Index = 0 Then
        If mblnNotExit Then Exit Sub
        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 MergePositionBalance(mlngPCodeID, mlngPositionID, "lngPositionID") Then Exit Function
    If Not MergePositionDaily(mlngPCodeID, mlngPositionID, "lngPositionID") 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(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recPosition As rdoResultset, strSql As String
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtInput(0).Text) = "" Then
        If Not blnByAdd Then
            ShowMsg hwnd, "货位编码不能为空!", vbExclamation, Caption
            txtInput(0).SetFocus
        End If
        GoTo ErrHandle
    End If
    
    If InStr(1, txtInput(0).Text, mstrOldCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "货位不能修改为自己的下级货位!", vbExclamation, Caption