form2.frm

一、 设计构想： 为减轻财政局非税收入管理处票据准购薄管理工作量

End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim SQL, connstr As String

Private Sub Command1_Click()
On Error Resume Next
Call returnSQL
Call RefillList(ListView1)
End Sub

Sub returnSQL()
On Error Resume Next
SQL = "select * from jbxx where 1=1"
If Text1(0).Text <> "" Then SQL = SQL & " and dwbh like '%" & Text1(0).Text & "%'"
If Text1(1).Text <> "" Then SQL = SQL & " and dwmc like '%" & Text1(1).Text & "%'"
If Text1(2).Text <> "" Then SQL = SQL & " and pjmc like '%" & Text1(2).Text & "%'"
If Text1(3).Text <> "" Then SQL = SQL & " and xkzh like '%" & Text1(3).Text & "%'"
If Text1(4).Text <> "" Then SQL = SQL & " and bkfs like '%" & Text1(4).Text & "%'"
If Check1.Value = 1 Then SQL = SQL & " and xkqx<#" & DTPicker1.Value & "#"
If Combo1.ListIndex > 0 Then SQL = SQL & " and zgbm='" & Combo1.List(Combo1.ListIndex) & "'"
If Combo2.ListIndex > 0 Then SQL = SQL & " and dwxz='" & Combo2.List(Combo2.ListIndex) & "'"
End Sub

Private Sub Command2_Click()
On Error Resume Next
Dim msgvb As Integer
For i = 1 To ListView1.ListItems.Count
    If ListView1.ListItems(i).Checked Then
    msgvb = MsgBox("确定要删除[" & ListView1.ListItems(i).SubItems(2) & "]？", vbYesNoCancel)
    If msgvb = 2 Then Exit Sub
        If msgvb = 6 Then
        SQL = "delete from jbxx where id=" & ListView1.ListItems(i).Text
        conn.Execute SQL
        SQL = "delete from xmxx where dwid=" & ListView1.ListItems(i).Text
        conn.Execute SQL
            If Err.Number <> 0 Then
            MsgBox ("删除过程中出现错误，请重新操作")
            Exit For
            End If
        End If
    End If
Next
Call returnSQL
Call RefillList(ListView1)
End Sub

Private Sub Command3_Click()
On Error Resume Next
Call returnSQL
Call RefillList(ListView1)
End Sub

Private Sub Form_Load()
On Error Resume Next
    connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\GLNHHY.DLL;Persist Security Info=False"
    Set conn = New ADODB.Connection
    conn.Open connstr
    Set rs = New ADODB.Recordset
    Me.Width = 9000
    Me.Height = 8000
    ListView1.Width = Me.Width - 100
    ListView1.Height = Me.Height - 2800
    Frame1.Left = Me.Width / 2 - 4300
    Combo1.AddItem "全部"
    SQL = "select * from zgbm order by num"
    rs.Open SQL, conn, 1, 1
    Do Until rs.EOF
    Combo1.AddItem rs("zgbm")
    rs.MoveNext
    Loop
    rs.Close
    Combo1.ListIndex = 0
    DTPicker1.Value = Year(Now()) & "-12-31"
SQL = "select * from jbxx"
Call RefillList(ListView1)
End Sub



Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState <> 1 Then
If Me.Width < 9000 Then Me.Width = 9000
If Me.Height < 8000 Then Me.Height = 8000
ListView1.Width = Me.Width - 100
ListView1.Height = Me.Height - 2800
Frame1.Left = Me.Width / 2 - 4300
End If
End Sub


Private Sub RefillList(ByVal lv As ListView)
On Error Resume Next
   Dim clm As ColumnHeader
   Dim itm As ListItem
   Dim i As Long, j As Long
   lv.ListItems.Clear
   lv.ColumnHeaders.Clear
   lv.View = lvwReport
   lv.LabelEdit = lvwManual
   '
   '
   Set clm = lv.ColumnHeaders.Add(, , "ID")
   Set clm = lv.ColumnHeaders.Add(, , "单位编号")
   Set clm = lv.ColumnHeaders.Add(, , "单位名称")
   Set clm = lv.ColumnHeaders.Add(, , "主管部门")
   Set clm = lv.ColumnHeaders.Add(, , "单位性质")
   Set clm = lv.ColumnHeaders.Add(, , "收费许可证号")
   Set clm = lv.ColumnHeaders.Add(, , "许可证期限")
   Set clm = lv.ColumnHeaders.Add(, , "联系电话")
   Set clm = lv.ColumnHeaders.Add(, , "联系人")
   Set clm = lv.ColumnHeaders.Add(, , "票据名称")
i = 0
rs.Open SQL, conn, 1, 1
If rs.EOF Then
rs.Close
Exit Sub
End If
Do Until rs.EOF
If rs.EOF Then Exit Do
i = i + 1
      Set itm = lv.ListItems.Add(, , rs("id"))
      itm.SubItems(1) = rs("dwbh") & ""
      itm.SubItems(2) = rs("dwmc") & ""
      itm.SubItems(3) = rs("zgbm") & ""
      itm.SubItems(4) = rs("dwxz") & ""
      itm.SubItems(5) = rs("sfxk") & ""
      If rs("xkqx") = "9999-12-31" Then
      itm.SubItems(6) = ""
      Else
      itm.SubItems(6) = rs("xkqx") & ""
      End If
      itm.SubItems(7) = rs("lxdh") & ""
      itm.SubItems(8) = rs("lxr") & ""
      itm.SubItems(9) = rs("pjmc") & ""
rs.MoveNext
Loop
rs.Close
End Sub

Private Sub Image2_Click()
On Error Resume Next

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim fd(20) As String
Dim frs(20) As String
Dim fw(20) As String
Dim tit As String
' Open the destination Excel workbook.

Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.ActiveSheet

MDIForm1.StatusBar1.Panels(1).Text = "导出操作可能需要很长时间，请耐心等待..."
xlBook.PrintPreview
' Open the recordset.
rs.Open SQL, conn, 1, 1

' Title
xlSheet.Cells.Font.Size = 12
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 10)).MergeCells = True
Text2.Text = comp
tit = Text2.Text & "各执收执罚单位基本信息表"
xlSheet.Cells(1, 1).Value = tit
xlSheet.Cells(1, 1).Font.Size = 18
xlSheet.Cells(1, 1).Font.Bold = True
xlSheet.Cells(1, 1).HorizontalAlignment = xlVAlignCenter
' Tabel Heads

fd(1) = "序号"
frs(1) = "ABC"
fd(2) = "单位名称"
frs(2) = "dwmc"
fd(3) = "单位编号"
frs(3) = "dwbh"
fd(4) = "主管部门"
frs(4) = "zgbm"
fd(5) = "票据名称"
frs(5) = "pjmc"
fd(6) = "单位性质"
frs(6) = "dwxz"
fd(7) = "收费许可证号"
frs(7) = "sfxk"
fd(8) = "单位地址"
frs(8) = "dwdz"
fd(9) = "联系人"
frs(9) = "lxr"
fd(10) = "联系电话"
frs(10) = "lxdh"
fd(11) = "NONE"
frs(11) = "NONE"
i = 0
Do
i = i + 1
If fd(i) = "NONE" Or i > 100 Then Exit Do
xlSheet.Cells(2, i).Value = fd(i)
'xlSheet.Cells(2, i).Font.Size = 10
xlSheet.Cells(2, i).Font.Name = "宋体"
xlSheet.Cells(2, i).Font.Bold = True
xlSheet.Cells(2, i).BorderAround xlContinuous
xlSheet.Cells(2, i).HorizontalAlignment = xlVAlignCenter
Loop
For a = 1 To rs.RecordCount
i = 0
Do
i = i + 1
If frs(i) = "NONE" Or i > 100 Then Exit Do
If frs(i) = "ABC" Then
xlSheet.Cells(a + 2, i).Value = a
Else
xlSheet.Cells(a + 2, i).Value = rs(frs(i))
End If
'xlSheet.Cells(a + 2, i).Font.Size = 9
xlSheet.Cells(a + 2, i).Font.Name = "仿宋_GB2312"
xlSheet.Cells(a + 2, i).BorderAround xlContinuous
xlSheet.Cells(a + 2, i).EntireColumn.AutoFit
Loop
rs.MoveNext
Next
   
'直接数据集拷贝
'xlBook.Worksheets(1).Range("A3").CopyFromRecordset rs
xlApp.ActiveWindow.DisplayZeros = False
    
xlBook.Worksheets(1).Range("A3").Select
    
xlApp.Visible = True
' Clean up everything.
'xlBook.Save
'xlBook.Close False
'xlApp.Quit
rs.Close
'Set xlBook = Nothing
'Set xlApp = Nothing
xlApp.ActiveSheet.PageSetup.Orientation = 2    '设置打印方向

xlApp.ActiveSheet.PageSetup.PaperSize = xlPaperA4      '设置打印纸的打下
Text2.Text = comp
tit = "C:\" & Text2.Text & "各执收执罚单位基本信息表.xls"
xlBook.SaveAs tit

If Err.Number = 0 Then
MDIForm1.StatusBar1.Panels(1).Text = "导出成功。已导出到" & tit
Else
MDIForm1.StatusBar1.Panels(1).Text = "导出失败!" & Err.Description
End If
'xlApp.Caption = "打印预览"               '设置预览窗口的标题

'xlApp.ActiveSheet.PrintPreview            '打印预览

'xlApp.ActiveSheet.PrintOut
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

End Sub

Private Sub Image2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Image2.Top = 30
Image2.Left = 7810
End Sub

Private Sub Image2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Image2.Top = 20
Image2.Left = 7800
End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
ListView1.SortKey = ColumnHeader.Index - 1
ListView1.Sorted = True
If ListView1.SortOrder = lvwDescending Then
ListView1.SortOrder = lvwAscending
Else
ListView1.SortOrder = lvwDescending
End If
End Sub

Private Sub ListView1_DblClick()
On Error Resume Next
Pub_dwID = CLng(ListView1.ListItems(ListView1.SelectedItem.Index).Text)
Form1.Show
End Sub