frmdefinelistcard.frm

金算盘软件代码

    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)
    frmCustomList.IsShowCard = False
    mblnIsChanged = False
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
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, _
            rdOpenForwardOnly)
        With recCustom
            txtInput(0).Text = !strCustomCode
            mstrLastCode = !strCustomCode
            txtInput(1).Text = !strCustomName
            mstrLastName = !strCustomName
            mstrNotes = Format(!strNotes, "@;;")
            mblnIsInActive = !blnIsInActive
            mblnIsDetail = (!blnIsDetail = 1)
            mintOldLevel = !intLevel
            mstrOldFullName = !strFullName
            chkStop.Value = !blnIsInActive
        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 Not DisplaceActivity("ARAPInit", strFName, mlngPCodeID, mlngCustomID) Then Exit Function
    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() As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recCustom As rdoResultset, Strsql As String
    Dim intIsDetail As Integer, intIsInActive As Integer
    
    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
    End If
    
    intResult = CodeCheck(mstrTableName, "strCustomCode", "lngCustomID", _
        mblnIsNew, txtInput(0).Text, txtInput(1).Text, mstrLastCode, _
        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, "自定项目“" & mstrLastCode & "”与自定项目“" _
                    & Trim$(txtInput(0).Text) & "”不能合并,请重新修改自定项目编码“" _
                    & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
                txtInput(0).SetFocus
                GoTo ErrHandle
            Else
                If ShowMsg(hwnd, "是否将自定项目“" & mstrLastCode & "”与“" _
                    & 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 CodeIsUsed(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(mstrTableName, "strCustomCode", txtInput(0).Text, _
        "strCustomName", txtInput(1).Text, "lngCustomID", _
        IIf(mblnIsNew, 0, mlngCustomID)) Then
        ShowMsg hwnd, "已有同级自定项目使用了" & "“" & txtInput(1).Text & "“" & _
            ",请重新录入自定项目名称!", vbExclamation, Caption
        txtInput(1).SetFocus
        recCustom.Close
        GoTo ErrHandle
    End If
    mstrCode = txtInput(0).Text
    mstrName = txtInput(1).Text
    mblnIsInActive = (chkStop.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 " & mstrTableName & " SET blnIsDetail=0 WHERE " _
                    & "lngCustomID=" & 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 " & mstrTableName & " SET blnIsInActive=True WHERE " _
                    & "lngCustomID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            Else
                mblnIsInActive = False
            End If
        End If
        mlngCustomID = GetNewID(mstrTableName)
        intIsDetail = IIf(mblnIsDetail, 1, 0)
        intIsInActive = IIf(mblnIsInActive, 1, 0)
        Strsql = "INSERT INTO " & mstrTableName & "(lngCustomID,strCustomCode," _
            & "strCustomName,strFullName,blnIsInActive,intLevel,blnIsDetail," _
            & "strStartDate) VALUES (" & mlngCustomID & ", '" & mstrCode & "','" _
            & mstrName & "','" & mstrFullName & "'," & intIsInActive & "," _
            & mintLevel & "," & intIsDetail & ",'" & mstrStartDate & "')"   '插入数据库
        If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
'        Strsql = "SELECT * FROM " & mstrTableName & " WHERE strCustomCode='" & txtInput(0).Text & "'"
'        Set recCustom = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
'        mlngCustomID = recCustom!lngCustomID
'        recCustom.Close
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode Then GoTo ErrHandle
            Strsql = "DELETE FROM " & mstrTableName & " WHERE lngCustomID=" & mlngCustomID
            If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
        Else
            intIsInActive = IIf(mblnIsInActive, 1, 0)
            Strsql = "UPDATE " & mstrTableName & " SET strCustomCode='" & mstrCode _
                & "',strCustomName='" & mstrName & "',strFullName='" & mstrFullName _
                & "',blnIsInActive=" & intIsInActive & ",intLevel =" & mintLevel _
                & " WHERE lngCustomID=" & mlngCustomID
            If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            If Not ChangeLowerCardCodeAndFullName(mstrTableName, "strCustomCode", _
                "strFullName", "lngCustomID", mstrLastCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
'            If Not ChangeLowerCardCodeAndFullName("Custom", "strCustomCode", _
                "strFullName", mstrLastCode, mstrLastName, mstrCode, mstrName, "lngCustomID") _
                    Then GoTo ErrHandle
            If mblnIsInActive Then      '本级停用时改变下级的停用属性
                If Not ChangeLowerActive(mstrTableName, "strCustomCode", mstrCode) _
                    Then GoTo ErrHandle
            End If
            If mblnPIsDetail Then
                Strsql = "UPDATE " & mstrTableName & " SET blnIsDetail=0 WHERE lngCustomID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(Strsql) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail(mstrTableName, "strCustomCode", mstrLastCode) Then GoTo ErrHandle
    End If
    If Not mblnIsInActive And mblnPIsInActive Then  '本级是活动时改变上级的停用属性
        If Not ChangeHigherActive(mstrTableName, "strCustomCode", mstrCode) _
            Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    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 Function SelectTable(strTitleName As String) As Boolean
    Dim Strsql As String
    Dim recSelect As rdoResultset
    
    Strsql = "SELECT strKey FROM Setting WHERE lngModuleID=8 AND strSetting='" _
              & strTitleName & "'"
    Set recSelect = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
    If Not recSelect.EOF Then
        mintCustomIndex = Mid(recSelect!strKey, 5, 1)
        mstrTableName = "Custom" & mintCustomIndex
        SelectTable = True
    Else
        SelectTable = False
    End If
    recSelect.Close
End Function

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
    Dim recCustom As rdoResultset
    Dim Strsql As String, strFullName As String, strNotes As String
    
    Strsql = "SELECT * FROM " & mstrTableName & " WHERE lngCustomID=" & lngPID
    Set recCustom = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenForwardOnly)
    With recCustom
    mblnIsDetail = False
'    mblnIsInActive = !blnIsInActive
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strCustomCode
    mstrName = !strCustomName
    strFullName = !strFullName
    strNotes = Format(!strNotes, "@;;")
    End With
    recCustom.Close
    
    intLevel = stringCount(Trim(txtInput(0).Text), "-") + 1
    Strsql = "UPDATE " & mstrTableName & " SET strCustomCode='" & txtInput(0).Text _
        & "',strCustomName='" & txtInput(1).Text & "',strFullName='" & mstrFullName _
        & "',blnIsInActive=" & (chkStop.Value = vbChecked) & ",intLevel =" & intLevel _
        & ",strNotes='" & IIf(mstrNotes = "", " ", mstrNotes) & "',strStartDate='" _
        & Format(Date, "YYYY-MM-DD") & "' WHERE lngCustomID=" & lngPID
    TransActivity = gclsBase.ExecSQL(Strsql)
    If TransActivity Then
        mstrFullName = strFullName
        mstrNotes = strNotes
    End If
End Function

Private Function IsContinue() As Boolean
    Dim lngResult As Long
    
    IsContinue = True
    If mblnIsChanged Then
        Me.ZOrder 0
        lngResult = ShowMsg(Me.hwnd, "上一次编辑的自定项目还未保存，是否继续编辑它？", vbYesNoCancel + vbQuestion, "自定项目卡片提示信息")
        If lngResult = vbYes Then       '继续编辑上一次的自定项目
            SendKeys "%{C}"
            Exit Function
        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