frmcenter.frm

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

Private Sub frmSplitterQY_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim sglPos As Single
    
    If mbMoving Then
        sglPos = X + frmSplitterQY.Left
        If sglPos < sglSplitLimit Then
            frmSplitterQY.Left = sglSplitLimit
        ElseIf sglPos > SSTab1.Width - sglSplitLimit Then
            frmSplitterQY.Left = SSTab1.Width - sglSplitLimit
        Else
            frmSplitterQY.Left = sglPos
        End If
    End If
    
End Sub


Private Sub frmSplitterQY_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    SizeControlsQY frmSplitterQY.Left
    mbMoving = False
End Sub

Sub SizeControlsCase(X As Single)
    On Error Resume Next
    
    '设置 X
    If X < lblCaption2.Width + 100 Then X = lblCaption2.Width + 100
    If X > SSTab1.Width - sglSplitLimit Then X = SSTab1.Width - sglSplitLimit
    
    '设置 sstab.tab(2)中的 Width属性
    tvCase.Width = X - 175
    lstSeleCase.Width = SSTab1.Width - X - 440
    
    '设置 sstab1.tab(2)中控件的 Left属性
    frmSplitterCase.Left = X
    tvCase.Left = txtCase.Left
    lstSeleCase.Left = X + frmSplitterCase.Width
    cmdOneRight2.Left = frmSplitterCase.Left - cmdOneRight1.Width - 15
    cmdOneDelete2.Left = frmSplitterCase.Left + 90
    cmdSaveSeleCase.Left = SSTab1.Width - cmdSaveSeleCase.Width - 300
    
End Sub

Sub SizeControlsQY(X As Single)
    On Error Resume Next
    
    '设置 X
    If X < lblCaption11.Width + 100 Then X = lblCaption11.Width + 100
    If X > SSTab1.Width - sglSplitLimit Then X = SSTab1.Width - sglSplitLimit
    
    '设置 sstab1.tab(1)中控件的 Width属性
    tvCompany.Width = X - 175
    lstSeleCompany.Width = SSTab1.Width - X - 440
    
    '设置 sstab1.tab(1)中控件的 Left属性
    frmSplitterQY.Left = X
    tvCompany.Left = txtQYBM.Left
    lstSeleCompany.Left = X + frmSplitterQY.Width
    lblCaption12.Left = frmSplitterQY.Left + 140
    cmdOneRight1.Left = frmSplitterQY.Left - cmdOneRight1.Width - 15
    cmdOneDelete1.Left = frmSplitterQY.Left + 90
    cmdSaveSeleComp.Left = SSTab1.Width - cmdSaveSeleComp.Width - 300
    

End Sub

Private Sub frmSplitterCase_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With frmSplitterCase
        frmSplitterCase.Move .Left, .Top, .Width, .Height
    End With
    mbMoving = True
End Sub

Private Sub lstSeleCase_DblClick()
    Call DeleteList(lstSeleCase, lstSeleCase.ListIndex)
End Sub

Private Sub lstSeleCompany_DblClick()
    Call DeleteList(lstSeleCompany, lstSeleCompany.ListIndex)
End Sub

Private Sub lvwCase_Click()
    If lvwCase.ListItems.Count = 0 Then Exit Sub
    imbCase.Text = lvwCase.SelectedItem.Text
End Sub

Private Sub lvwCase_DblClick()

    ThisMode = "Case Modify"
    If fSetCase Is Nothing Then
        Set fSetCase = New frmSetUserMode
    End If
    fSetCase.txtName.Text = lvwCase.SelectedItem.Text
    fSetCase.Show vbModal
End Sub

Private Sub lvwQY_Click()
    If lvwQY.ListItems.Count = 0 Then Exit Sub
    
    imbQY.Text = lvwQY.SelectedItem.Text
End Sub

Private Sub lvwQY_DblClick()
'******************************************************
'功能: 调出frmSetUserMode,用于对lvwQY中选定的项目进行修改
'******************************************************

ThisMode = "QY Modify"
If lvwQY.ListItems.Count = 0 Then
    Exit Sub
End If

If fSetCompany Is Nothing Then
    Set fSetCompany = New frmSetUserMode
End If
fSetCompany.txtName.Text = lvwQY.SelectedItem.Text
fSetCompany.Show vbModal
End Sub

Private Sub tvCase_DblClick()
    Call TranceList(tvCase, lstSeleCase, CaseCodeLength)
End Sub

Private Sub tvCase_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Call TranceList(tvCase, lstSeleCase, CaseCodeLength)
    End If
End Sub

Private Sub tvCompany_DblClick()
    '在tvCompany中双击某企业,则将该企业加入右边的lstSeleCompany中
    Call TranceList(tvCompany, lstSeleCompany, QYBMLength)
End Sub

Private Sub tvCompany_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Call TranceList(tvCompany, lstSeleCompany, QYBMLength)
    End If
End Sub

Private Sub txtCase_Change()
    '在txtCase中回车时
    '如果在tvCase中存在txtCase中的文书
    '则在lstSeleCase中加入该文书编码及名称
    Call FindExactNode(UCase(txtCase.Text), CaseCodeLength, tvCase)
End Sub

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

Private Sub txtQYBM_Change()
    Call FindExactNode(txtQYBM.Text, QYBMLength, tvCompany)
End Sub

Private Sub txtQYBM_KeyPress(KeyAscii As Integer)
    '在txtQYBM中回车时
    '如果在tvCompany中存在txtQYBM.TEXT的企业
    '则在lstSeleCompany中加入该企业
    Call FindExactNode(txtQYBM, QYBMLength, tvCompany)
    If KeyAscii = vbKeyReturn And FindExactCompany = True Then
        If TranceList(tvCompany, lstSeleCompany, QYBMLength) = False Then
            Exit Sub
        End If
        SendKeys "{Home}+{End}"
    End If
End Sub

Private Sub RefreshfrmCenter(IsQYBM As Boolean, lstView As ListView, imagecmb As ImageCombo)
'******************************************************
'功能：刷新frmCenter中sstab.tab(3)的ListView和imagecmb
'用于：本窗体的cmdAddCrop_click和cmdAddCase_click
'******************************************************
On Error GoTo ErrorHandler

Dim i As Integer
Dim idx As Integer
Dim itmX As ListItem

Dim FoundSQL As String

Dim rstUserMode As ADODB.Recordset

Set rstUserMode = New ADODB.Recordset
'FoundSQL = "Select Distinct User_Ope_Name," & _
           "Distinct User_Ope_RulesBelongTo," & _
           "Distinct User_Ope_Case_Included," & _
           "Distinct User_Ope_Others_Included," & _
           "Distinct IsQYBM From Operation_UserDefined_Rules"
FoundSQL = "Select Distinct Ope_Name,IsQYBM From Operation_UserDefined_Rules"
rstUserMode.Open FoundSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdTableDirect

'清除imagecmb中的旧项目
imagecmb.Text = vbNullString
imagecmb.ComboItems.Clear
'For i = 0 To imagecmb.ComboItems.Count - 1
'    imagecmb.ComboItems.Remove (0)
'Next i
    
'清除ListView中的旧项目
lstView.ListItems.Clear

With rstUserMode
    If Not .EOF Then .MoveLast
    If Not .BOF Then .MoveFirst
    
    Do Until .EOF
    
    '用户自定义类型名称不能为空
    If !Ope_Name <> vbNullString Then
        
        '库中自定义企业集合类型与当前将要刷新的类型相同
        If !IsQYBM = IsQYBM Then
        
            
            '在imagecmb中添加新项目
            idx = idx + 1
            If IsQYBM Then
                imagecmb.ComboItems.Add idx, !Ope_Name, !Ope_Name, "Company", "Company", 0
            Else
                imagecmb.ComboItems.Add idx, !Ope_Name, !Ope_Name, "Case", "Case", 0
            End If
            'imagecmb.AddItem !Ope_Name
            
            '在ListView中添加新项目
            Set itmX = lstView.ListItems.Add()
            itmX.Text = !Ope_Name
            If IsQYBM Then
                itmX.Icon = "Company"
            Else
                itmX.Icon = "Case"
            End If
        End If
    End If
    .MoveNext
    Loop
End With

rstUserMode.Close

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

Public Sub PutIntoArrayCompany_Case()
'************************************************************
'功能：将选择的企业和文书的编码+名称存入数组CompanyCodeName中
'      将文书的编码+名称+页数存入数组CaseCodeNamePage中
'调用：本窗体的cmdImport_click
'************************************************************
On Error GoTo ErrorHandler

Dim i As Integer
Dim Dimension As Integer

Dim CompanyCodeName1() As String
Dim CompanyCodeName2() As String

Dim CaseCodeName1() As String
Dim CaseCodeName2() As String

Dim FoundSQL As String
Dim rstUserMode As ADODB.Recordset
Dim rstTemp As ADODB.Recordset


'创建纪录集
Set rstUserMode = New ADODB.Recordset
Set rstTemp = New ADODB.Recordset

'1.将lstSeleCompany中的项目存入数组CompanyCodeName1
If lstSeleCompany.ListCount > 0 Then
    ReDim CompanyCodeName1(lstSeleCompany.ListCount - 1)
    For i = 0 To lstSeleCompany.ListCount - 1
        CompanyCodeName1(i) = lstSeleCompany.List(i)
    Next i
End If

'2.将Ope_QYBM表中储存的自定义类型包含的企业存入数组CompanyCodeName2
If Trim(imbQY.Text) <> vbNullString Then
    FoundSQL = "SELECT DISTINCT Ope_QYBM,Ope_Nsrmc " & _
            "FROM Operation_UserDefined_Rules " & _
            "WHERE Ope_Name='" & imbQY.Text & "'"
Else
    FoundSQL = "SELECT Ope_QYBM,Ope_Nsrmc FROM Operation_UserDefined_Rules WHERE 1=2"
End If
rstUserMode.Open FoundSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
With rstUserMode
    If Not .BOF Then .MoveLast
    If Not .BOF Then .MoveFirst
    If .RecordCount <> 0 Then
    ReDim CompanyCodeName2(.RecordCount - 1)
        For i = 0 To .RecordCount - 1
            CompanyCodeName2(i) = !Ope_QYBM & csSeperator & !Ope_Nsrmc
            .MoveNext
        Next i
    End If
End With


'取得没有重复项目的企业集合!!!!!!!!!!!!!!!!
Call CheckSame(CompanyCodeName1(), lstSeleCompany.ListCount, CompanyCodeName2(), rstUserMode.RecordCount, CompanyCodeName())
rstUserMode.Close


FoundSQL = "SELECT * FROM sys_Case"
rstTemp.Open FoundSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText

'1.将lstSeleCase中的文书存入数组CaseCodeName1
If lstSeleCase.ListCount > 0 Then
    ReDim CaseCodeName1(lstSeleCase.ListCount - 1)
    For i = 0 To lstSeleCase.ListCount - 1
        rstTemp.MoveFirst
        rstTemp.Find "Case_Code='" & Left(lstSeleCase.List(i), CaseCodeLength) & "'"
        If Not rstTemp.EOF Then
            CaseCodeName1(i) = lstSeleCase.List(i) & csSeperator & rstTemp!Case_Pages
        End If
    Next i
End If

'2.将Operation_UserDefined_Rules中的文书存入数组CaseCodeName2
If Trim(imbCase.Text) <> vbNullString Then
    FoundSQL = "SELECT DISTINCT Ope_Case_Code,Ope_Case_Name " & _
            "FROM Operation_UserDefined_Rules " & _
            "WHERE Ope_Name='" & imbCase.Text & "'"
Else
    FoundSQL = "SELECT Ope_Case_Code,Ope_Case_Name FROM Operation_UserDefined_Rules WHERE 1=2"
End If
rstUserMode.Open FoundSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
With rstUserMode
    If Not .EOF Then .MoveLast
    If Not .BOF Then .MoveFirst

    If .RecordCount > 0 Then
        i = 0
        Do Until .EOF
            rstTemp.MoveFirst
            rstTemp.Find "Case_Code='" & !Ope_Case_Code & "'"
            If Not rstTemp.EOF Then
                Dimension = Dimension + 1
                ReDim Preserve CaseCodeName2(i)
                CaseCodeName2(i) = !Ope_Case_Code & csSeperator & !Ope_Case_Name & csSeperator & rstTemp!Case_Pages
            End If
            .MoveNext
            i = i + 1
        Loop
    End If
End With


'取得没有重复项目的文书集合!!!!!!!!!!!!!!!!
Call CheckSame(CaseCodeName1(), lstSeleCase.ListCount, CaseCodeName2(), Dimension, CaseCodeName())

rstUserMode.Close
rstTemp.Close

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