frmsetusermode.frm

用vb6.0实现的一个可以通用的企业档案管理系统。

    End If
End Sub

Private Sub tvItem_KeyPress(KeyAscii As Integer)
    If KeyAscii <> vbKeyReturn Then
        Exit Sub
    End If
    If IsQYBM Then
        Call TranceList(tvItem, lstSeleItem, QYBMLength)
    Else
        Call TranceList(tvItem, lstSeleItem, CaseCodeLength)
    End If
End Sub

Private Sub txtItem_Change()
    If IsQYBM Then
        Call FindExactNode(txtItem.Text, QYBMLength, tvItem)
    Else
        Call FindExactNode(txtItem.Text, CaseCodeLength, tvItem)
    End If
End Sub

Private Function SaveUserMode(IsQYBM As Boolean, ModeName As TextBox, lstSeleItem As ListBox) As Boolean
'***********************************************
'功能：将用户制作的自定义方法存入数据库CaseMain
'      的表Operation_UserDefined_Rules
'用于：本窗体的cmdSave_Click
'***********************************************

Dim i As Integer

Dim FoundSQL As String
Dim Msg As String

Dim rstUserMode As ADODB.Recordset


'如果自定义类型名称为空,则退出
If Trim(ModeName.Text) = vbNullString Then
    MsgBox "自定义集合名称不能为空!", vbExclamation
    ModeName.SetFocus
    SaveUserMode = False
    Exit Function
End If

'如果未选择项目,则退出
If lstSeleItem.ListCount = 0 Then
    MsgBox "自定义类型不能为空", vbExclamation
    SaveUserMode = False
Exit Function
End If

'打开的相应的表:Operation_UserDefined_Rules
Set rstUserMode = New ADODB.Recordset
FoundSQL = "SELECT distinct Ope_Name FROM Operation_UserDefined_Rules WHERE Ope_Name='" & ModeName & "'"
rstUserMode.Open FoundSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdTableDirect

With rstUserMode

    '处理重复的名称
    If Not .BOF Then .MoveFirst
    Do Until .EOF
        If !Ope_Name = ModeName.Text Then
            Msg = MsgBox("该名称已存在，是否覆盖?", vbYesNo + vbInformation)
            Select Case Msg
                Case vbYes
                    .Close
                    conCaseMain.Execute "Delete FROM Operation_UserDefined_Rules WHERE Ope_Name='" & ModeName & "'"
                    Exit Do
                Case vbNo
                    txtName.SetFocus
                    SendKeys "{Home}+{End}"
                    
                    .Close
                    SaveUserMode = False
                    
                    Exit Function
            End Select
        End If
    .MoveNext
    Loop
    
End With

'重新打开表:Operation_UserDefined_Rules
Set rstUserMode = New ADODB.Recordset
rstUserMode.Open "SELECT * FROM Operation_UserDefined_Rules", conCaseMain, adOpenStatic, adLockOptimistic, adCmdTableDirect

With rstUserMode

    '添加新用户模式
    For i = 0 To lstSeleItem.ListCount - 1
    
        If Not .EOF Then .MoveLast
        .AddNew
    
        '存入自定义模式名称
        !Ope_Name = ModeName.Text
    
        '存入该模式涉及的编码(企业编码或文书编码)
            If IsQYBM Then
                !Ope_QYBM = Left(lstSeleItem.List(i), QYBMLength)
                !Ope_Nsrmc = Right(lstSeleItem.List(i), Len(lstSeleItem.List(i)) - QYBMLength - 1)
            Else
                !Ope_Case_Code = Left(lstSeleItem.List(i), CaseCodeLength)
                !Ope_Case_Name = Right(lstSeleItem.List(i), Len(lstSeleItem.List(i)) - CaseCodeLength - 1)
            End If
    
        '存入该模式类型(企业编码类还是文书编码类)
        !IsQYBM = IsQYBM
        .Update
        
    Next i
End With

If Right(Me.Tag, QYBMLength) = "Modify" Then
    MsgBox "修改成功!", vbInformation
Else
    MsgBox "入库成功!", vbInformation
End If

rstUserMode.Close
SaveUserMode = True

Exit Function

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
        SaveUserMode = False
    End If
End Function

Private Sub ReadExistedMode(ModeName As String)
'*******************************************************
'功能: 从库CaseMain中读出已存在的模式，并添加到lvwItem中
'用于:
'*******************************************************
On Error GoTo ErrorHandler

Dim i As Integer
Dim cTemp As String

Dim ThisMode As String
Dim rstUserMode As ADODB.Recordset

Set rstUserMode = New ADODB.Recordset

ThisMode = csUserModeSQL & " WHERE Ope_Name='" & ModeName & "'"
rstUserMode.Open ThisMode, conCaseMain, adOpenStatic, adLockOptimistic, adCmdTableDirect

With rstUserMode
    If Not .EOF Then .MoveLast
    If Not .BOF Then .MoveFirst
    
    If .RecordCount = 0 Then
        MsgBox "无法找到该模式!", vbExclamation
        
        Set rstUserMode = Nothing
        
        Exit Sub
    End If
    
    lstSeleItem.Clear
    
    Do Until .EOF
        If IsQYBM Then
            lstSeleItem.AddItem !Ope_QYBM & csSeperator & !Ope_Nsrmc
        Else
            lstSeleItem.AddItem !Ope_Case_Code & csSeperator & !Ope_Case_Name
        End If
        .MoveNext
    Loop
End With

Set rstUserMode = Nothing

Exit Sub
ErrorHandler:
    If Err Then
        MsgBox "ReadExistedModeError!", vbExclamation
        Err.Clear
    End If
End Sub

Private Sub ReadSelection(lstItem As ListBox)
'****************************************************************
'功能：将lstItem中的项目加入另一个lstItem中
'用于：本窗体的FormLoad
'****************************************************************
On Error GoTo ErrorHandler

Dim i As Integer

'清除原有项目
lstSeleItem.Clear

For i = 0 To lstItem.ListCount - 1
    lstSeleItem.AddItem lstItem.List(i)
Next i

Exit Sub
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
    End If
End Sub

Private Sub AddListItem(StringOfBM As String, LengthOfBM As Integer, Seperator As String, lstItem As ListBox)
'****************************************************************
'功能：处理StringOfBM,提取其中的编码,将编码和对应名称添加到lvwItem中
'用于: ReadExistedMode
'****************************************************************

Dim i As Integer
Dim j As Integer
Dim iPos As Integer
Dim ExactBM As String

Dim ThisBM As String
Dim BMArray() As String
Dim TypeText(1 To 5) As String

Dim rstUserBM_Name As ADODB.Recordset

Set rstUserBM_Name = New ADODB.Recordset

Do Until Len(StringOfBM) < LengthOfBM
    
    '取得分隔符所在位置
    iPos = InStr(StringOfBM, Seperator)
    
    'iPos>0表示字符串中有分隔符,在分隔符左边为所需编码
    If iPos > 0 Then
        ExactBM = Left(StringOfBM, iPos - 1)
        StringOfBM = Right(StringOfBM, Len(StringOfBM) - iPos)
    Else
        '字符串中没有分隔符,表示只剩下最后一个编码
        ExactBM = Left(StringOfBM, LengthOfBM)
        StringOfBM = Right(StringOfBM, Len(StringOfBM) - LengthOfBM)
    End If
    
    '长度合适
    If Len(ExactBM) = LengthOfBM Then
        
        '编码数量累加
        i = i + 1
        
        '重定义编码数组维数
        ReDim Preserve BMArray(1 To i) As String
        
        '给新增加的数组元素赋值
        BMArray(i) = ExactBM
        
    End If
Loop

'取得编码对应的名称(分企业编码和文书编码)
'企业编码
If IsQYBM Then

    TypeText(1) = csDJ_QYSQL
    TypeText(2) = csDJ_GTSQL
    TypeText(3) = csDJ_WZSQL
    TypeText(4) = csDJ_WGSQL
    TypeText(5) = csDJ_ZCSQL

    For i = 1 To 5
    
        '生成查询SQL语句
        ThisBM = TypeText(i) & " WHERE QYBM='"
        For j = 1 To UBound(BMArray)
            If j = 1 Then
                ThisBM = ThisBM & BMArray(j) & "'"
            Else
                ThisBM = ThisBM & " OR QYBM='" & BMArray(j) & "'"
            End If
        Next j
        Debug.Print ThisBM
        '打开相关表
        rstUserBM_Name.Open ThisBM, conZT97, adOpenStatic, adLockOptimistic, adCmdTableDirect
        With rstUserBM_Name
            If Not .EOF Then .MoveLast
            If Not .BOF Then .MoveFirst
            Do Until .EOF
                If .RecordCount > 0 Then
                    '在lstItem中加入编码+名称
                    lstItem.AddItem !QYBM & csSeperator & !Nsrmc
                Else
                    Exit Do
                End If
                .MoveNext
            Loop
        End With
        rstUserBM_Name.Close
    Next i
    
'文书编码
Else
    '生成查询SQL语句
    ThisBM = csCaseSQL & " WHERE Case_Code='"
    For j = 1 To UBound(BMArray)
        If j = 1 Then
            ThisBM = ThisBM & BMArray(j) & "'"
        Else
            ThisBM = ThisBM & " Or Case_Code='" & BMArray(j) & "'"
        End If
    Next j
    '打开相关表
    rstUserBM_Name.Open ThisBM, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
    With rstUserBM_Name
        If Not .EOF Then .MoveLast
        If Not .BOF Then .MoveFirst
        Do Until .EOF
            If .RecordCount = 0 Then
                Set rstUserBM_Name = Nothing
                Exit Sub
            Else
                '在lstItem中加入编码+名称
                lstItem.AddItem !Case_Code & csSeperator & !Case_Name
            End If
            .MoveNext
        Loop
    End With
End If

Set rstUserBM_Name = Nothing

Exit Sub
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbExclamation
        Err.Clear
    End If
End Sub

Private Function ModifyUserMode(IsQYBM As Boolean, ModeNameOld As String, ModeNameNew As String, lstSeleItem As ListBox) As Boolean
'***********************************************
'功能：修改选定的自定义方法存入数据库CaseMain
'      的表Operation_UserDefined_Rules
'用于：本窗体的cmdSure_Click
'***********************************************
On Error GoTo ErrorHandler

Dim i As Integer
Dim FoundStr As String
Dim Msg As String

Dim rstUserMode As ADODB.Recordset

'打开的相应的表:Operation_UserDefined_Rules
Set rstUserMode = New ADODB.Recordset
FoundStr = "SELECT * FROM Operation_UserDefined_Rules WHERE Ope_Name='" & ModeNameOld & "'"
rstUserMode.Open FoundStr, conCaseMain, adOpenStatic, adLockOptimistic, adCmdTableDirect

'如果自定义类型名称为空,则退出
If Trim(ModeNameNew) = vbNullString Then
    MsgBox "自定义类型名称不能为空!", vbExclamation
        
    txtItem.SetFocus
        
    ModifyUserMode = False
    rstUserMode.Close
        
    Exit Function
End If

With rstUserMode

    '添加新用户模式
    If Not .EOF Then .MoveLast
    
    '存入自定义模式名称
    !Ope_Name = ModeNameNew
    
    '存入该模式涉及的编码(企业编码或文书编码)
    For i = 0 To lstSeleItem.ListCount - 1
        If IsQYBM Then
            !Ope_QYBM = Left(lstSeleItem.List(i), QYBMLength)
            !Ope_Nsrmc = Right(lstSeleItem.List(i), Len(lstSeleItem.List(i)) - QYBMLength - 1)
        Else
            !Ope_Case_Code = Left(lstSeleItem.List(i), CaseCodeLength)
            !Ope_Case_Name = Right(lstSeleItem.List(i), Len(lstSeleItem.List(i)) - CaseCodeLength - 1)
        End If
    Next i
    
    '存入该模式类型(企业编码类还是文书编码类)
    !IsQYBM = IsQYBM
    .Update
    .MoveNext
End With

ModifyUserMode = True

MsgBox "修改成功!", vbInformation

rstUserMode.Close

Exit Function

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
        ModifyUserMode = False
    End If
End Function

Private Sub txtItem_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn And FindExactCase = True Then
        If TranceList(tvItem, lstSeleItem, CaseCodeLength) = False Then
            Exit Sub
        End If
        SendKeys "{Home}+{End}"
    End If
End Sub