frmquery.frm

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

    For i = 0 To UBound(CompanyCaseType, 2)
        Set nodCase = tvwResult.Nodes.Add(idxRoot, tvwChild)
            nodCase.Text = CompanyCaseType(0, i).Case_Code & csSeperator & CompanyCaseType(0, i).Case_Name
            nodCase.Tag = "Case"
            idxCase = nodCase.Index
            
        
        '查询文书,增加文书节点
        strTemp = "SELECT DISTINCT QYBM,NSRMC,Img_SSSQ,Img_IsRegister FROM sys_Image WHERE Img_Case_Code='" & CompanyCaseType(0, i).Case_Code & "'"
        '导入时间和所属时期
        If dImportDate1 <> #12:00:00 AM# And dImportDate2 <> #12:00:00 AM# Then
            strTemp = strTemp & " AND Img_Import_Date BETWEEN #" & dImportDate1 & "# AND #" & dImportDate2 & "#"
        End If
        If CompanyCaseType(0, i).Img_IsRegister = False Then
            If strSSSQ1 <> vbNullString And strSSSQ2 <> vbNullString Then
                strTemp = strTemp & " AND Img_SSSQ BETWEEN '" & strSSSQ1 & "' AND '" & strSSSQ2 & "'"
            End If
        End If
        
        rstTemp.Open strTemp, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
        With rstTemp
            If Not .BOF Then .MoveFirst
            Do Until .EOF
                If !QYBM <> vbNullString Then
                    Set NodCompany = tvwResult.Nodes.Add(idxCase, tvwChild)
                        NodCompany.Text = !QYBM & csSeperator & !Nsrmc
                        NodCompany.Tag = !Img_SSSQ
                        IdxCompany = NodCompany.Index
                End If
'                .MoveNext
'            Loop
'        End With
'        rstTemp.Close
        
        '***************************************************************
        '如果包含申报表,则额外增加数据报表
        If CompanyCaseType(0, i).Case_Code = "ZS10" Then
            Set nodCase = tvwResult.Nodes.Add(idxCase, tvwChild)
            nodCase.Text = !QYBM & csSeperator & !Nsrmc & "--数据报表"
            nodCase.Tag = "DataReport"
            idxCase = nodCase.Index
        End If
        
        If CompanyCaseType(0, i).Case_Code = "ZS11" Then
            Set nodCase = tvwResult.Nodes.Add(idxCase, tvwChild)
            nodCase.Text = !QYBM & csSeperator & !Nsrmc & "--数据报表"
            nodCase.Tag = "DataReport"
            idxCase = nodCase.Index
        End If
        
        If CompanyCaseType(0, i).Case_Code = "ZS12" Then
            Set nodCase = tvwResult.Nodes.Add(idxCase, tvwChild)
            nodCase.Text = !QYBM & csSeperator & !Nsrmc & "--数据报表"
            nodCase.Tag = "DataReport"
            idxCase = nodCase.Index
        End If
        
        If CompanyCaseType(0, i).Case_Code = "ZS13" Then
            Set nodCase = tvwResult.Nodes.Add(idxCase, tvwChild)
            nodCase.Text = !QYBM & csSeperator & !Nsrmc & "--数据报表"
            nodCase.Tag = "DataReport"
            idxCase = nodCase.Index
        End If
        
        If CompanyCaseType(0, i).Case_Code = "ZS14" Then
            Set nodCase = tvwResult.Nodes.Add(idxCase, tvwChild)
            nodCase.Text = !QYBM & csSeperator & !Nsrmc & "--数据报表"
            nodCase.Tag = "DataReport"
            idxCase = nodCase.Index
        End If
        '***************************************************************

        '********************************************************
        '查询报表,增加报表节点
        strTemp = "SELECT sb_zzs_xx.qybm,jk_dj_nsr.nsrmc FROM sb_zzs_xx,jk_dj_nsr WHERE sb_zzs_xx.qybm=jk_dj_nsr.qybm"
        '********************************************************
            .MoveNext
            Loop
        End With
        rstTemp.Close
    Next i
End If

'文书数组为空,查询选定企业的所有类型的文书
If CaseArrayIsEmpty And CompanyArrayIsEmpty = False Then

    Set nodRoot = tvwResult.Nodes.Add()
        nodRoot.Text = "选择的企业"
        nodRoot.Tag = "Root"
        idxRoot = nodRoot.Index
        
    For i = 0 To UBound(CompanyCaseType)
        Set NodCompany = tvwResult.Nodes.Add(idxRoot, tvwChild)
            NodCompany.Text = CompanyCaseType(i, 0).QYBM & csSeperator & CompanyCaseType(i, 0).Nsrmc
            NodCompany.Tag = "Company"
            IdxCompany = NodCompany.Index
        
        strTemp = "SELECT DISTINCT Img_Case_Code,Img_Case_Name,Img_SSSQ,Img_IsRegister FROM Sys_Image WHERE QYBM='" & CompanyCaseType(i, 0).QYBM & "'"
        
        '导入时间和所属时期
        If dImportDate1 <> #12:00:00 AM# And dImportDate2 <> #12:00:00 AM# Then
            strTemp = strTemp & " AND Img_Import_Date BETWEEN #" & dImportDate1 & "# AND #" & dImportDate2 & "#"
        End If
        If CompanyCaseType(0, i).Img_IsRegister = False Then
            If strSSSQ1 <> vbNullString And strSSSQ2 <> vbNullString Then
                strTemp = strTemp & " AND Img_SSSQ BETWEEN '" & strSSSQ1 & "' AND '" & strSSSQ2 & "'"
            End If
        End If
        
        rstTemp.Open strTemp, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
        With rstTemp
            If Not .BOF Then .MoveFirst
            Do Until .EOF
                If !Img_Case_Code <> vbNullString Then
                    Set nodCase = tvwResult.Nodes.Add(IdxCompany, tvwChild)
                        nodCase.Text = !Img_Case_Code & csSeperator & !Img_Case_Name
                        nodCase.Tag = !Img_SSSQ
                        idxCase = nodCase.Index
                End If
                .MoveNext
            Loop
        End With
        rstTemp.Close
    Next i
End If

'企业数组和文书数组都为空,查询所有企业和文书,要区分所属时期
If CompanyArrayIsEmpty And CaseArrayIsEmpty Then
    
    Set nodRoot = tvwResult.Nodes.Add()
        nodRoot.Text = "选择的企业"
        nodRoot.Tag = "Root"
        idxRoot = nodRoot.Index
        
        
    strTemp = "SELECT DISTINCT QYBM,NSRMC FROM sys_Image "
    
    '打开纪录集
    Set rstQY = New ADODB.Recordset
    Set rstTemp = New ADODB.Recordset
    rstQY.Open strTemp, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
    With rstQY
        If Not .EOF Then .MoveFirst
        Do Until .EOF
            Set NodCompany = tvwResult.Nodes.Add(idxRoot, tvwChild)
                NodCompany.Text = !QYBM & csSeperator & !Nsrmc
                NodCompany.Tag = "Company"
                IdxCompany = NodCompany.Index
                
                strTemp = "SELECT DISTINCT Img_Case_Code,Img_Case_Name,Img_SSSQ,Img_IsRegister FROM sys_Image "
                strTemp = strTemp & "WHERE QYBM='" & !QYBM & "'"
                
                '导入时间和所属时期
                If dImportDate1 <> #12:00:00 AM# And dImportDate2 <> #12:00:00 AM# Then
                    strTemp = strTemp & " AND Img_Import_Date BETWEEN #" & dImportDate1 & "# AND #" & dImportDate2 & "#"
                End If
                If CompanyCaseType(0, i).Img_IsRegister = False Then
                    If strSSSQ1 <> vbNullString And strSSSQ2 <> vbNullString Then
                        strTemp = strTemp & " AND Img_SSSQ BETWEEN '" & strSSSQ1 & "' AND '" & strSSSQ2 & "'"
                    End If
                End If
                
                rstTemp.Open strTemp, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
                If Not rstTemp.EOF Then rstTemp.MoveFirst
                Do Until rstTemp.EOF
                    If rstTemp!Img_Case_Code <> vbNullString Then
                        Set nodCase = tvwResult.Nodes.Add(IdxCompany, tvwChild)
                            nodCase.Text = rstTemp!Img_Case_Code & csSeperator & rstTemp!Img_Case_Name
                            nodCase.Tag = rstTemp!Img_SSSQ
                            
                    End If
                    rstTemp.MoveNext
                Loop
                rstTemp.Close
                    
            .MoveNext
        Loop
    End With
    rstQY.Close
End If

'企业数组和文书数组都不为空
If CompanyArrayIsEmpty = False And CaseArrayIsEmpty = False Then
    Set nodRoot = tvwResult.Nodes.Add()
        nodRoot.Text = "选择的企业"
        nodRoot.Tag = "Root"
        idxRoot = nodRoot.Index
        
    For i = 0 To UBound(CompanyCaseType)
        Set NodCompany = tvwResult.Nodes.Add(idxRoot, tvwChild)
            NodCompany.Text = CompanyCaseType(i, 0).QYBM & csSeperator & CompanyCaseType(i, 0).Nsrmc
            NodCompany.Tag = "Company"
            IdxCompany = NodCompany.Index
        
        strTemp = "SELECT DISTINCT Img_Case_Code,Img_Case_Name,Img_SSSQ,Img_IsRegister FROM sys_Image "
        strTemp = strTemp & MakeQueryString(i)
        
        '导入时间和所属时期
        If dImportDate1 <> #12:00:00 AM# And dImportDate2 <> #12:00:00 AM# Then
            strTemp = strTemp & " AND Img_Import_Date BETWEEN #" & dImportDate1 & "# AND #" & dImportDate2 & "#"
        End If
        If CompanyCaseType(0, i).Img_IsRegister = False Then
            If strSSSQ1 <> vbNullString And strSSSQ2 <> vbNullString Then
                strTemp = strTemp & " AND Img_SSSQ BETWEEN '" & strSSSQ1 & "' AND '" & strSSSQ2 & "'"
            End If
        End If
        
        rstTemp.Open strTemp, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
        With rstTemp
            If Not .BOF Then .MoveFirst
            Do Until .EOF
                If !Img_Case_Code <> vbNullString Then
                    Set nodCase = tvwResult.Nodes.Add(IdxCompany, tvwChild)
                        nodCase.Text = !Img_Case_Code & csSeperator & !Img_Case_Name
                        nodCase.Tag = !Img_SSSQ
                        idxCase = nodCase.Index
                End If
                .MoveNext
            Loop
        End With
        rstTemp.Close
    Next i
End If

Screen.MousePointer = vbDefault
tvwResult.Nodes(1).Expanded = True

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

Private Function MakeQueryString(CurrentComp As Integer) As String
'***********************************************************
'功能：生成查询SQL语句
'调用：MakeQueryTree
'***********************************************************

Dim i As Integer

MakeQueryString = " WHERE QYBM='" & CompanyCaseType(CurrentComp, 0).QYBM & "' AND "
For i = 0 To UBound(CompanyCaseType, 2)
    If i = 0 Then
        MakeQueryString = MakeQueryString & " (( Img_Case_Code='" & CompanyCaseType(CurrentComp, i).Case_Code & "'"
    Else
        MakeQueryString = MakeQueryString & " OR ( Img_Case_Code='" & CompanyCaseType(CurrentComp, i).Case_Code & "'"
    End If
    If Not CompanyCaseType(CurrentComp, i).Img_IsRegister Then
        If strSSSQ1 <> vbNullString And strSSSQ2 <> vbNullString Then
            MakeQueryString = MakeQueryString & " AND Img_SSSQ BETWEEN '" & strSSSQ1 & "' AND '" & strSSSQ2 & "'"
        End If
    End If
    MakeQueryString = MakeQueryString & ")"
Next i
MakeQueryString = MakeQueryString & ") "

End Function

Private Sub tvwResult_DblClick()

'是子节点，则显示该节点表示的文书
If tvwResult.SelectedItem.Tag = "Root" Then Exit Sub
With tvwResult.SelectedItem
    If .Child Is Nothing And .Parent.Tag <> "Root" Then
        Set fShowImg = New frmShowImg
        Set fShowImg.rstImage = New ADODB.Recordset
        Call OpenSubItemImage(tvwResult.SelectedItem)
        Set fShowImg.rstImage = rstImage.Clone
        fShowImg.Show 0
    End If
End With
End Sub

Private Sub tvwResult_NodeClick(ByVal Node As MSComctlLib.Node)

Dim XItem As ListItem
Dim i As Integer


'只有第二级节点(企业或文书)才添加 lvwResult
If Not Node.Child Is Nothing And Not Node.Parent Is Nothing Then

    '在lvwResult中添加ColumnHeads
    If Node.Tag = "Company" Then
        If EventFlag <> "Company" Then
        MakeColumns (True)
        End If
    End If
    If Node.Tag = "Case" Then
        If EventFlag <> "Case" Then
            MakeColumns (False)
        End If
    End If

    '清除lvwResult中原有的ListItem
    If lvwResult.ListItems.Count > 0 Then
        lvwResult.ListItems.Clear
    End If
    
    With tvwResult
        '循环从当前的二级节点开始,到下一个二级节点结束
        For i = Node.Index + 1 To tvwResult.Nodes.Count
            If Not .Nodes(i).Child Is Nothing Then
                Exit For
            End If
            '是二级节点的子节点,添加 lvwResult
            If .Nodes(i).Child Is Nothing And .Nodes(i).Parent.Text = Node.Text Then
                Set XItem = lvwResult.ListItems.Add(Text:=.Nodes(i).Text)
                    XItem.Tag = .Nodes(i).Parent.Tag & csSeperator & .Nodes(i).Tag
                Call OpenSubItemImage(.Nodes(i))
                Call AddlvwResultSubItems(.Nodes(i), XItem)
            End If
        Next i
    End With
    
End If

End Sub

Private Sub MakeColumns(IsCompany As Boolean)

    ' 清除 ColumnHeaders 集合。
    lvwResult.ColumnHeaders.Clear
    
    ' 添加五个 ColumnHeaders。
    If Not IsCompany Then
        lvwResult.ColumnHeaders.Add , , "单位名称", 1800
        lvwResult.ColumnHeaders.Add , , "文书名称", 1800
        ' 设置 EventFlag 变量使这个过程不要再三发生。
        EventFlag = "Company"
    Else
        lvwResult.ColumnHeaders.Add , , "文书名称", 1800
        lvwResult.ColumnHeaders.Add , , "单位名称", 1800
        ' 设置 EventFlag 变量使这个过程不要再三发生。
        EventFlag = "Case"
    End If
    lvwResult.ColumnHeaders.Add , , "导入日期", 800
    lvwResult.ColumnHeaders.Add , , "所属时期", 800
    lvwResult.ColumnHeaders.Add , , "是否备份", 500
    
End Sub

Private Sub AddlvwResultSubItems(Node As MSComctlLib.Node, ByRef ListItem As MSComctlLib.ListItem)
    
    '根据父节点的不同,添加不同的SubItems
    'ListItem.SubItems(0) = rstImage!Img_Case_Name
    If Node.Parent.Tag = "Company" Then
        ListItem.SubItems(1) = rstImage!QYBM & csSeperator & rstImage!Nsrmc
    Else
        ListItem.SubItems(1) = rstImage!Img_Case_Code & csSeperator & rstImage!Img_Case_Name
    End If
    ListItem.SubItems(2) = rstImage!Img_Import_Date
    ListItem.SubItems(3) = IIf(IsNull(rstImage!Img_SSSQ), "没有该属性", rstImage!Img_SSSQ)
    ListItem.SubItems(4) = rstImage!Img_BackupMode
    
End Sub

Private Sub OpenSubItemImage(Node As MSComctlLib.Node)

    On Error GoTo ErrorHandler
    
    Dim strSQL As String
    
    '生成查询语句
    If Node.Parent.Tag = "Company" Then
        strSQL = "SELECT * FROM sys_Image " & _
                "WHERE QYBM='" & Left(Node.Parent.Text, QYBMLength) & _
                "' AND Img_Case_Code='" & Left(Node.Text, CaseCodeLength) & "'"
    
    End If
    If Node.Parent.Tag = "Case" Then
        strSQL = "SELECT * FROM sys_Image " & _
                "WHERE QYBM='" & Left(Node.Text, QYBMLength) & _
                "' AND Img_Case_Code='" & Left(Node.Parent.Text, CaseCodeLength) & "'"
    
    End If
    If Right(Node.Tag, 1) <> 0 Then
        strSQL = strSQL & " AND Img_SSSQ='" & Node.Tag & "'"
    End If
    strSQL = strSQL & " ORDER BY Img_Page"
    
    Set rstImage = New ADODB.Recordset
    rstImage.Open strSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText

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