frmdelcase.frm

用vb编了一个数据库程序

End Sub

Private Sub cmdDel_Click()
    Dim i As Integer
    Dim Msg As String
    
    If lvwCase.ListItems.Count = 0 Then
        MsgBox "没有可以删除的文书!", vbInformation
        Exit Sub
    End If
    If lvwCase.SelectedItem.Checked = True Then
        Msg = MsgBox("确定删除这些文书吗?", vbYesNo + vbInformation)
        Select Case Msg
            Case vbYes
                For i = 1 To lvwCase.ListItems.Count
                    If lvwCase.ListItems(i).Selected = True Then
                        If DeleteCase(i, rstImage) = False Then
                            MsgBox "删除错误!", vbInformation
                            Exit Sub
                        End If
                    End If
                Next i
            Case vbNo
        End Select
    End If
    MsgBox "成功删除!", vbInformation
    
    Call cmdSearch_Click
End Sub

Private Sub cmdSearch_Click()

    '为了防止某些无聊的人改变企业编码,再次检查企业编码
    If QYBM_NSRMC(Left(cmbQY.Text, QYBMLength)) = vbNullString Then
        Exit Sub
    End If
    
    '生成SQL
    Dim strSQL As String
    Dim XItem As ListItem
    
    strSQL = "SELECT QYBM,Img_Case_Code,Img_Case_Name,Img_Page,Img_Import_Date,Img_SSSQ FROM sys_Image " & _
             "WHERE QYBM='" & Left(cmbQY.Text, QYBMLength) & "'"
    
    '选择了所属时期,则将满足所属时期条件的文书
    '和无所属时期属性的登记类文书一同选出
    If ChkSSSQ.Value = vbChecked Then
        strSQL = strSQL & " AND ( Img_SSSQ BETWEEN '" & txtSSSQ1 & "' AND '" & txtSSSQ2 & "'"
        strSQL = strSQL & " OR Img_IsRegister=True) "
    End If
    If ChkDate.Value = vbChecked Then
        strSQL = strSQL & " AND Img_Import_Date BETWEEN '" & DTPDate1.Value & "' AND '" & DTPDate2.Value & "'"
    End If
    
    '向lvwCase中添加项目
    If lvwCase.ListItems.Count > 0 Then
        lvwCase.ListItems.Clear
    End If
    Set rstImage = New ADODB.Recordset
    rstImage.Open strSQL, conCaseMain, 1, 1 ', adCmdText
    With rstImage
        If Not .EOF Then .MoveLast
        If Not .BOF Then .MoveFirst
        If .RecordCount > 0 Then
            Do Until .EOF
                Set XItem = lvwCase.ListItems.Add(Text:=!Img_Case_Name)
                    XItem.SmallIcon = "Case"
                    XItem.SubItems(1) = IIf(IsNull(!Img_SSSQ), "无此属性", !Img_SSSQ)
                    XItem.SubItems(2) = !Img_Import_Date
                    XItem.SubItems(3) = !Img_Page
                .MoveNext
            Loop
        End If
    End With
End Sub

Private Sub cmdSure_Click()
    Unload Me
End Sub

Private Sub Form_Initialize()
    
    '初始化cmbQY(企业列表)
    Dim i As Integer
    Dim SQL(4) As String
    Dim rstCompany As ADODB.Recordset
    
    SQL(0) = csDJ_QYSQL
    SQL(1) = csDJ_GTSQL
    SQL(2) = csDJ_WZSQL
    SQL(3) = csDJ_WGSQL
    SQL(4) = csDJ_ZCSQL
        
    Screen.MousePointer = vbHourglass
    
    '连接新数据库:CaseMain.mdb
    Set conCaseMain = New ADODB.Connection
'    conCaseMain.Provider = csProvider
'    conCaseMain.CursorLocation = adUseServer
'    conCaseMain.ConnectionTimeout = 60
    conCaseMain.Open csConCaseMain

    Set rstCompany = New ADODB.Recordset
    
    cmbQY.Text = vbNullString
    cmbQY.AddItem Space(20)
    
    For i = 0 To 4
        rstCompany.Open SQL(i), conCaseMain, 1, 1 ', adCmdText
        With rstCompany
            If Not .EOF Then .MoveLast
            If Not .BOF Then .MoveFirst
            If .RecordCount > 0 Then
                Do Until .EOF
                    cmbQY.AddItem !QYBM & csSeperator & !Nsrmc
                    .MoveNext
                Loop
            End If
        End With
        rstCompany.Close
    Next i
    
    Screen.MousePointer = vbDefault
    
End Sub

Private Sub Form_Load()

    '初始化所属时期
    ChkSSSQ.Value = vbChecked
    txtSSSQ1 = Year(DateAdd("M", -1, Date)) & Format(Month(DateAdd("M", -1, Date)), "0#")
    txtSSSQ2 = Year(Date) & Format(Month(Date), "0#")
    
    '初始化导入日期
    ChkDate.Value = vbChecked
    DTPDate1.Format = dtpLongDate
    DTPDate2.Format = dtpLongDate
    DTPDate1.Value = DateAdd("D", -1, Date)
    DTPDate2.Value = Date
    
    '初始化lvwCase(文书)
    With lvwCase
        .View = lvwReport
        .ColumnHeaders.Add , , "文书名称", 3000
        .ColumnHeaders.Add , , "所属时期", 1000
        .ColumnHeaders.Add , , "导入日期", 1000
        .ColumnHeaders.Add , , "页    码", 1000
        '.ColumnHeaders.Add , , "文书数量", 1000
        '.ColumnHeaders.Add , , "文件数量", 1000

    End With
    

    
End Sub

Private Function QYBM_NSRMC(QYBM As String) As String
'***********************************************
'功能:根据传入的企业编码,返回企业编码+纳税人名称
'调用:cmbQY_KeyPress
'***********************************************
    If Len(QYBM) <> QYBMLength Then
        QYBM_NSRMC = vbNullString
        Exit Function
    End If

    Dim i As Integer
    Dim SQL(4) As String
    Dim rstCompany As ADODB.Recordset
    
    SQL(0) = csDJ_QYSQL
    SQL(1) = csDJ_GTSQL
    SQL(2) = csDJ_WZSQL
    SQL(3) = csDJ_WGSQL
    SQL(4) = csDJ_ZCSQL
    
    Set rstCompany = New ADODB.Recordset
    For i = 0 To 4
        rstCompany.Open SQL(i), conCaseMain, 1, 1 ', adCmdText
        With rstCompany
            If Not .EOF Then .MoveLast
            If Not .BOF Then .MoveFirst
            rstCompany.Find "QYBM='" & QYBM & "'"
            If Not .EOF Then
                QYBM_NSRMC = QYBM & csSeperator & !Nsrmc
                Exit For
            End If
        End With
        rstCompany.Close
    Next i

End Function

Private Function DeleteCase(RecordNumber, rstImage As ADODB.Recordset) As Boolean
    
On Error GoTo ErrorHandler
    
With rstImage
    .MoveFirst
    If RecordNumber < rstImage.RecordCount Then
        .Move RecordNumber
        .Delete
        .Update
        DeleteCase = True
    Else
        .Move rstImage.RecordCount - 1
        .Delete
        .Update
        DeleteCase = True
    End If
End With
Exit Function
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbInformation
        Err.Clear
        DeleteCase = False
    End If
End Function

Private Sub UpDown1_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ1, 4) & "/" & Right(txtSSSQ1, 2) & "/01")
    txtSSSQ1.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDown1_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ1, 4) & "/" & Right(txtSSSQ1, 2) & "/01")
    txtSSSQ1.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Sub UpDown2_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ2, 4) & "/" & Right(txtSSSQ2, 2) & "/01")
    txtSSSQ2.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDown2_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ2, 4) & "/" & Right(txtSSSQ2, 2) & "/01")
    txtSSSQ2.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub