frmareacard.frm

金算盘软件代码

Private Function InitCard(Optional strName As String = "") As Boolean
     Dim recArea As rdoResultset, strSQL As String
    
    mblnIsInit = True
    InitCard = True
    mlngPCodeID = 0
    mblnPIsDetail = False
    If Not mblnIsNew Then
        strSQL = "SELECT * FROM Area WHERE lngAreaID=" _
            & mlngAreaID
        Set recArea = gclsBase.BaseDB.OpenResultset(strSQL, _
            rdOpenStatic)
        With recArea
            txtInput(0).Text = !strAreaCode
            mstrLastCode = !strAreaCode
            txtInput(1).Text = !strAreaName
            mstrLastName = !strAreaName
            mintOldLevel = !intLevel
            mblnIsDetail = (!blnIsDetail = 1)
            mstrOldFullName = !strFullName
            mstrNotes = Format(!strNotes, "@;;")
        End With
        recArea.Close
    Else
        txtInput(1).Text = ""
        txtInput(0).Text = Trim(strName)
        mstrNotes = ""
    End If
    mblnIsInit = False
End Function

Private Function CodeCheck() As Integer
    Dim recArea As rdoResultset
    Dim strCode As String, strSQL As String
    Dim strPre As String
    
    strCode = Trim$(txtInput(0).Text)
    If Not mblnIsNew Then
        If mstrLastCode = strCode Then
            strPre = CodePrefix(mstrOldFullName)
            If strPre = "" Then
                mstrFullName = Trim$(txtInput(1).Text)
            Else
                mstrFullName = strPre & "-" & Trim$(txtInput(1).Text)
            End If
            CodeCheck = 1
            Exit Function
        Else
            strSQL = "SELECT * FROM Area WHERE strAreaCode LIKE '" _
                & mstrLastCode & "*'"
            Set recArea = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
            If Not recArea.EOF Then
                recArea.MoveLast
                If Len(Trim$(recArea!strAreaCode)) + Len(strCode) - _
                    Len(mstrLastCode) > 16 Then
                    CodeCheck = -3   '编码超长
                    Exit Function
                End If
            End If
            recArea.Close
        End If
    End If

    strSQL = "SELECT * FROM Area WHERE strAreaCode='" & strCode & "'"
    Set recArea = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recArea.EOF Then
        CodeCheck = -2             '当前编码已存在
        mlngPCodeID = recArea!lngAreaID
        mblnPIsDetail = recArea!blnIsDetail
        mstrFullName = CodePrefix(Trim$(recArea!strFullName)) & "-" _
            & Trim$(txtInput(1).Text)
        Exit Function
    End If
    recArea.Close

    strPre = CodePrefix(strCode)
    If strPre <> "" Then
        strSQL = "SELECT * FROM Area WHERE strAreaCode='" & strPre & "'"
        Set recArea = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
        If recArea.EOF Then
            CodeCheck = -1           '上级编码不存在
            Exit Function
        Else
'            mintLevel = strCount(strCode, "-") + 1
            mblnIsDetail = True
            mstrFullName = Trim$(recArea!strFullName) & "-" _
                & Trim$(txtInput(1).Text)
            mlngPCodeID = recArea!lngAreaID
            mblnPIsDetail = recArea!blnIsDetail
        End If
        recArea.Close
    Else
'        mintLevel = 1
        mblnIsDetail = True
        mstrFullName = Trim$(txtInput(1).Text)
        mlngPCodeID = 0
        mblnPIsDetail = False
    End If
    CodeCheck = 1
End Function

Private Function MergeCode() As Boolean
    MergeCode = False
    If Not DisplaceActivity("Customer", "lngAreaID", mlngPCodeID, mlngAreaID) Then Exit Function
    If Not DisplaceActivity("Item", "lngAreaID", mlngPCodeID, mlngAreaID) Then Exit Function
    MergeCode = True
End Function

Private Function SaveCard(Optional blnByAdd As Boolean = False) As Boolean
    Dim blnMerge As Boolean     'NEW--转移业务  EDIT--合并代码
    Dim intResult As Integer    '编码检查结果:1--合法 -1--上级编码不存在 -2--编码已存在 -3--编码超长
    Dim recArea As rdoResultset, strSQL As String
    Dim intIsDetail As Integer
    
    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, mstrLastCode & "-") <> 0 And Not mblnIsNew Then
        If Not blnByAdd Then
            ShowMsg hwnd, "地区不能修改为自己的下级地区!", vbExclamation, Caption
            txtInput(0).SetFocus
        End If
        GoTo ErrHandle
    End If
    If InStr(1, mstrLastCode, txtInput(0).Text & "-") <> 0 And Not mblnIsNew Then
        If Not blnByAdd Then
            ShowMsg hwnd, "地区不能修改为自己的上级地区!", vbExclamation, Caption
            txtInput(0).SetFocus
        End If
        GoTo ErrHandle
    End If
    If Trim$(txtInput(1).Text) = "" Then
        If Not blnByAdd Then
            ShowMsg hwnd, "地区名称不能为空!", vbExclamation, Caption
            txtInput(1).SetFocus
        End If
        GoTo ErrHandle
    End If
    
'    If CheckSameName("Area", "strAreaCode", txtInput(0).Text, "strAreaName", _
'        txtInput(1).Text, "lngAreaID", IIf(mblnIsNew, 0, mlngAreaID)) Then
'        ShowMsg hWnd, "已有同级地区使用了" & "“" & txtInput(1).Text & "“" & _
'            ",请重新录入地区名称!", _
'            vbExclamation, Caption
'        txtInput(1).SetFocus
'        recArea.Close
'        GoTo ErrHandle
'    End If
    intResult = CodeCheck
    If intResult = -1 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "“的上级地区" _
                    & "不存在,请先增加上级地区”" & CodePrefix(txtInput(0).Text) _
                        & "“", vbExclamation, Caption
            End If
        Else
            If Not blnByAdd Then
                ShowMsg hwnd, "“" & Trim$(txtInput(0).Text) & "“的上级地区" _
                    & "不存在,请重新修改地区”" _
                    & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
            End If
        End If
        txtInput(0).SetFocus
        GoTo ErrHandle
    ElseIf intResult = -2 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "地区编码“" & Trim$(txtInput(0).Text) _
                    & "”已经存在,请重新录入地区编码", vbExclamation, Caption
                txtInput(0).SetFocus
            End If
            GoTo ErrHandle
        Else
            If Not mblnPIsDetail Or Not mblnIsDetail Then
                If Not blnByAdd Then
                    ShowMsg hwnd, "地区“" & mstrLastCode & "”与地区“" _
                        & Trim$(txtInput(0).Text) & "”不能合并,请重新修改地区编码“" _
                        & Trim$(txtInput(0).Text) & "“", vbExclamation, Caption
                    mlngPCodeID = 0
                    txtInput(0).SetFocus
                End If
                GoTo ErrHandle
            Else
                If Not blnByAdd Then
                    If ShowMsg(hwnd, "是否将地区“" & mstrLastCode & "”与“" _
                        & Trim$(txtInput(0).Text) & "”进行合并?", vbQuestion + vbYesNo, _
                         Caption) = vbNo Then
                        txtInput(0).SetFocus
                        GoTo ErrHandle
                    Else
                        blnMerge = True
                    End If
                Else
                    blnMerge = True
                End If
            End If
        End If
    ElseIf intResult = -3 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "地区编码太长,请重新修改编码!", vbExclamation, Caption
            txtInput(0).SetFocus
        End If
        GoTo ErrHandle
    Else
        If mblnIsNew And mblnPIsDetail Then
            If CodeIsUsed(mlngPCodeID) Then
                If Not blnByAdd 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
                Else
                    blnMerge = True
                End If
            End If
        End If
    End If
    
    mstrCode = Trim(txtInput(0).Text)
    mstrName = Trim(txtInput(1).Text)
    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 Area SET blnIsDetail=0 WHERE " _
                    & "lngAreaID=" & mlngPCodeID
                If Not gclsBase.ExecSQL(strSQL) Then GoTo ErrHandle
            End If
        End If
        mlngAreaID = GetNewID("Area")
        intIsDetail = IIf(mblnIsDetail, 1, 0)
        strSQL = "INSERT INTO Area(lngAreaID,strAreaCode,strAreaName," _
            & "strFullName,intLevel,blnIsDetail," _
            & "strStartDate) VALUES (" & mlngAreaID & ", '" & mstrCode & "','" _
            & mstrName & "','" & mstrFullName & "'," & mintLevel & "," _
            & intIsDetail & ",'" & mstrStartDate & "')"   '插入数据库
        gclsBase.BaseDB.Execute strSQL
        If blnMerge Then mlngAreaID = mlngPCodeID
'        Strsql = "SELECT * FROM Area WHERE strAreaCode='" & Trim(txtInput(0).Text) & "'"
'        Set recArea = gclsBase.BaseDB.OpenResultset(Strsql, rdOpenStatic)
'        mlngAreaID = recArea!lngAreaID
'        recArea.Close
    Else
        '进行编码合并
        If blnMerge Then
            If Not MergeCode Then GoTo ErrHandle
            strSQL = "DELETE FROM Area WHERE lngAreaID=" & mlngAreaID
            If Not gclsBase.ExecSQL(strSQL) Then GoTo ErrHandle
        Else
            strSQL = "UPDATE Area SET strAreaCode='" & mstrCode _
                & "',strAreaName='" & mstrName & "',strFullName='" & mstrFullName _
                & "',intLevel =" & mintLevel & " WHERE lngAreaID=" & mlngAreaID
            gclsBase.BaseDB.Execute strSQL
            If Not ChangeLowerCardCodeAndFullName("Area", "strAreaCode", _
                "strFullName", "lngAreaID", mstrLastCode, mstrOldFullName, mstrCode, _
                mstrFullName, mintOldLevel, mintLevel) Then GoTo ErrHandle
'            If Not ChangeLowerCardCodeAndFullName("Area", "strAreaCode", _
                "strFullName", mstrLastCode, mstrLastName, mstrCode, mstrName, "lngAreaID") _
                    Then GoTo ErrHandle
            If mblnPIsDetail Then
                strSQL = "UPDATE Area SET blnIsDetail=0 WHERE lngAreaID=" _
                    & mlngPCodeID
                If Not gclsBase.ExecSQL(strSQL) Then GoTo ErrHandle
            End If
        End If
        If Not ChangeHigherCardDetail("Area", "strAreaCode", mstrLastCode) Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
'    gclsSys.SendMessage Me.hWnd, Message.msgArea
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    If InStr(Err.Description, "违反唯一约束条件") > 0 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "已有同级地区使用了" & "“" & txtInput(1).Text & "“" & _
                ",请重新录入地区名称!", vbExclamation, Caption
            txtInput(1).SetFocus
        End If
    End If
End Function

Private Sub txtInput_Change(Index As Integer)
    Dim strErr As String
    
    If Index = 0 Then
        strErr = "'""|? `~!^*"
    Else
        strErr = "'""|?`~-!^*"
    End If
    If mblnIsInit Then
        If ContainErrorChar(txtInput(Index).Text, strErr) Then
            BKKEY txtInput(Index).hwnd, vbKeyEnd
            BKKEY txtInput(Index).hwnd
        End If
    Else
        If ContainErrorChar(txtInput(Index).Text, strErr) Then
            BKKEY txtInput(Index).hwnd
        End If
        mblnIsChanged = True
    End If
End Sub

Private Function TransActivity(ByVal lngPID As Long) As Boolean
    Dim intLevel As Integer
    Dim recArea As rdoResultset
    Dim strSQL As String, strFullName As String, strNotes As String
    
    strSQL = "SELECT * FROM Area WHERE lngAreaID=" & lngPID
    Set recArea = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    With recArea
    mblnIsDetail = False
    mintLevel = !intLevel
    mstrStartDate = !strStartDate
    mstrCode = !strAreaCode
    mstrName = !strAreaName
    strFullName = !strFullName
    strNotes = !strNotes
    End With
    recArea.Close
    
    intLevel = strCount(Trim(txtInput(0).Text), "-") + 1
    strSQL = "UPDATE Area SET strAreaCode='" & Trim(txtInput(0).Text) _
        & "',strAreaName='" & Trim(txtInput(1).Text) & "',strFullName='" & mstrFullName _
        & "',intLevel =" & intLevel & ",strNotes='" & IIf(mstrNotes = "", " ", mstrNotes) & "',strStartDate='" _
        & Format(Date, "YYYY-MM-DD") & "' WHERE lngAreaID=" & lngPID
    TransActivity = gclsBase.ExecSQL(strSQL)
    If TransActivity Then
        mstrFullName = strFullName
        mstrNotes = strNotes
    End If
End Function

Private Sub txtInput_KeyPress(Index As Integer, KeyAscii As Integer)
    If Index = 0 Then
        If InStr("'""|?`~! ^*", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    Else
        If InStr("'""|?`~-!^*", Chr(KeyAscii)) > 0 Then KeyAscii = 0
    End If
End Sub