form4.frm

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

Attribute VB_Exposed = False
Dim conn, connxls 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 xmxx.*,jbxx.dwbh as dwbh,jbxx.dwmc as dwmc,jbxx.zgbm as zgbm,jbxx.dwxz as dwxz,jbxx.sfxk as sfxk,wjxx.bh as wjbh from jbxx,xmxx,wjxx where xmxx.dwid=jbxx.id and xmxx.yjwj=wjxx.mc"
If Text1(0).Text <> "" Then SQL = SQL & " and jbxx.dwbh like '%" & Text1(0).Text & "%'"
If Text1(1).Text <> "" Then SQL = SQL & " and jbxx.dwmc like '%" & Text1(1).Text & "%'"
If Combo1.ListIndex > 0 Then SQL = SQL & " and jbxx.zgbm='" & Combo1.List(Combo1.ListIndex) & "'"
If Combo2.ListIndex > 0 Then SQL = SQL & " and jbxx.dwxz='" & Combo2.List(Combo2.ListIndex) & "'"
If Text1(2).Text <> "" Then SQL = SQL & " and xmxx.xmbm like '%" & Text1(2).Text & "%'"
If Text1(3).Text <> "" Then SQL = SQL & " and xmxx.xmmc like '%" & Text1(3).Text & "%'"
If Text1(4).Text <> "" Then SQL = SQL & " and xmxx.sfbz like '%" & Text1(4).Text & "%'"
If Text1(5).Text <> "" Then SQL = SQL & " and xmxx.bz like '%" & Text1(5).Text & "%'"
SQL = SQL & " order by jbxx.dwbh"
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(5) & "]？", vbYesNoCancel)
    If msgvb = 2 Then Exit Sub
        If msgvb = 6 Then
        SQL = "delete from xmxx where id=" & 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
SQL = "select xmxx.*,jbxx.dwbh as dwbh,jbxx.dwmc as dwmc,jbxx.zgbm as zgbm,jbxx.dwxz as dwxz,jbxx.sfxk as sfxk,wjxx.bh as wjbh from jbxx,xmxx,wjxx where xmxx.dwid=jbxx.id and xmxx.yjwj=wjxx.mc order by jbxx.dwbh"
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(, , "备注")
   Set clm = lv.ColumnHeaders.Add(, , "", 0)
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("xmbm") & ""
      itm.SubItems(5) = rs("xmmc") & ""
      itm.SubItems(6) = rs("sfxz") & ""
      itm.SubItems(7) = rs("yjwj") & ""
      itm.SubItems(8) = rs("sfbz") & ""
      itm.SubItems(9) = rs("bz") & ""
      itm.SubItems(10) = rs("dwid") & ""
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
' 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) = "sfxk"
fd(6) = "项目编码"
frs(6) = "xmbm"
fd(7) = "项目名称"
frs(7) = "xmmc"
fd(8) = "收费性质"
frs(8) = "sfxz"
fd(9) = "收费标准"
frs(9) = "sfbz"
fd(10) = "依据文件"
frs(10) = "TS1"
fd(11) = "备注"
frs(11) = "bz"
fd(12) = "NONE"
frs(12) = "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
ElseIf frs(i) = "TS1" Then
xlSheet.Cells(a + 2, i).Value = "《" & rs("yjwj") & "》(" & rs("wjbh") & ")"
Else
xlSheet.Cells(a + 2, i).Value = rs(frs(i))
End If
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 = xlPaperA3      '设置打印纸的打下
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).SubItems(10))
Form1.Show
End Sub