frmdefinecard.frm

金算盘软件代码

    CodeIsUsed = False
End Function

Private Sub chkStop_Click()
'    Dim strDefine As String
'
'    strDefine = txtInput(0).Text & " " & txtInput(1).Text
'    If chkStop.Value = Checked And Not mblnIsNew Then
'        If CodeIsUsed(mlngCustomID) Then
'            ShowMsg hwnd, "自定项目“" & strDefine & "“已有业务发生,不能停用！", 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(txtInput(0).Text)
'            mlngCustomID = 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

Public Function DelCard(ByVal strTitleName As String, 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 = mlngCustomID And frmCustomList.IsShowCard Then
'        ShowMsg lnghWnd, "不能删除正在修改的自定项目！", vbExclamation + MB_TASKMODAL, "删除自定项目"
'        Show vbModal
'        Exit Function
'    End If
    DelCard = False
    If Not SelectTable(strTitleName) Then
        ShowMsg lnghWnd, "自定项目名标题有错。", vbExclamation + MB_TASKMODAL, "删除自定项目"
        Exit Function
    End If
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    strSql = "SELECT * FROM " & mstrTableName & " WHERE lngCustomID=" & lngID
    Set recDep = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recDep.EOF Then
        strCode = recDep!strCustomCode
        strDep = "“" & Trim(recDep!strCustomCode) & " " _
            & Trim(recDep!strCustomName) & "”"
        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) 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 " & mstrTableName & " WHERE lngCustomID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    If Not ChangeHigherCardDetail(mstrTableName, "strCustomCode", strCode) Then GoTo ErrHandle
    gclsBase.BaseWorkSpace.CommitTrans
    DelCard = True
    Select Case CInt(mintCustomIndex)
        Case 0
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgCustom1
        Case 1
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgCustom2
        Case 2
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgCustom3
        Case 3
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgCustom4
        Case 4
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgCustom5
        Case 5
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgCustom6
    End Select
    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, 30030
    Utility.LoadFormResPicture Me
'    frmCustomList.IsShowCard = 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, 150, 150, 4300, 1900
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
'    frmCustomList.IsShowCard = False
    Utility.UnLoadFormResPicture Me
    mblnIsChanged = False
End Sub

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

Private Function MergeCode() As Boolean
    Dim strFname As String

    MergeCode = False
    strFname = "lngCustomID" & mintCustomIndex
    If gclsBase.ControlAccount Then
        If Not DisplaceActivity("ARAPInit", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    Else
        If Not DisplaceActivity("ARAPInit1", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    End If
    If Not DisplaceActivity("CostPriceDetail", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    If Not DisplaceActivity("Item", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    If Not DisplaceActivity("ItemActivityDetail", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    If Not DisplaceActivity("PurchaseOrderDetail", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    If Not DisplaceActivity("SaleOrderDetail", strFname, mlngPCodeID, mlngCustomID) Then Exit Function
    If Not DisplaceActivity("StockTakingDetail", strFname, mlngPCodeID, mlngCustomID) 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 recCustom As rdoResultset, strSql As String
    
    On Error GoTo ErrHandle
    
    SaveCard = False
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    If Trim$(txtInput(0).Text) = "" Then
        ShowMsg hwnd, "自定项目编码不能为空!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    
    If InStr(1, txtInput(0).Text, mstrLastCode & "-") <> 0 And Not mblnIsNew Then
        ShowMsg hwnd, "自定项目不能修改为自己的下级自定项目!", vbExclamation, Caption
        txtInput(0).SetFocus
        GoTo ErrHandle
    End If
    If InStr(1, mstrLastCode, 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