📄 部门收款查询.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form 部门收款查询
Caption = "部门收款查询"
ClientHeight = 7845
ClientLeft = 60
ClientTop = 345
ClientWidth = 8715
Icon = "部门收款查询.frx":0000
LinkTopic = "Form1"
ScaleHeight = 7845
ScaleWidth = 8715
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame1
Caption = "请输入年份的后两位数及部门名称"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 2895
Left = 720
TabIndex = 2
Top = 600
Width = 4455
Begin VB.ComboBox Combo1
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Left = 1560
TabIndex = 9
Top = 1200
Width = 2055
End
Begin VB.CommandButton Command4
Caption = "重 置"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 2640
TabIndex = 5
Top = 2160
Width = 975
End
Begin VB.CommandButton Command3
Caption = "确 定"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 840
TabIndex = 4
Top = 2160
Width = 975
End
Begin VB.TextBox Text1
Height = 375
Left = 1560
TabIndex = 3
Top = 480
Width = 1215
End
Begin VB.Label Label5
Caption = "年 份："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 360
TabIndex = 7
Top = 600
Width = 1335
End
Begin VB.Label Label2
Caption = "部门名称："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 360
TabIndex = 6
Top = 1200
Width = 1335
End
End
Begin VB.CommandButton Command1
Caption = "输出到EXCEL"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 6120
TabIndex = 1
Top = 1080
Width = 1575
End
Begin VB.CommandButton Command2
Caption = "返 回"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 6120
TabIndex = 0
Top = 2400
Width = 1575
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 375
Left = 6480
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 3600
Visible = 0 'False
Width = 1335
End
Begin VB.Data Data2
Caption = "Data2"
Connect = "Access"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 345
Left = 5040
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 3720
Visible = 0 'False
Width = 1140
End
Begin MSFlexGridLib.MSFlexGrid Grid1
Height = 3495
Left = 0
TabIndex = 8
Top = 4320
Width = 8655
_ExtentX = 15266
_ExtentY = 6165
_Version = 393216
Cols = 6
BackColorFixed = 12648447
End
End
Attribute VB_Name = "部门收款查询"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim db1 As ADODB.Connection
Dim db2 As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim rs2 As ADODB.Recordset
Dim res As Integer
Dim sqlcx, bt As String
Dim bh As String
Dim jn As String
Dim rq As String
Dim slqcx, strsql As String
Dim xlApp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim strSource, strDestination As String
Dim jls, i, j, f, k, n As Integer
'Dim dblj As String
Dim dylj As String
Dim htdb, jgdb As ADODB.Connection
Dim htrs, jgrs As ADODB.Recordset
Private Sub Command1_Click() '打印
' On Error GoTo er
aa = MsgBox("你要打印数据吗?", vbYesNo, "打印按是, 否则按否!")
If aa = 6 Then
If Grid1.Rows > 2 Then
Set xlApp = New Excel.Application '建立excel应用程序
Set xlApp = CreateObject("Excel.Application") '激活EXCEL应用程序
'Set xlbook = xlApp.Workbooks.Add
'设定工作表
strSource = App.Path + "\rpt\收款情况表.xls" 'jcchzb.xls是一个模版文件
strDestination = App.Path + "\temp\收款情况表.xls"
FileCopy strSource, strDestination '将模版文件拷贝到一个临时文件
Set xlbook = xlApp.Workbooks.Open(strDestination) '打开工作簿，strDestination为一个EXCEL报表文件
Set xlsheet = xlbook.Worksheets(1) '打开工作表1
xlsheet.Cells(1, 1) = "20" & Trim(Text1.Text) & "年" & Trim(Combo1.Text) & "合同收款情况表"
xlsheet.Cells(2, 1) = bt
For i = 0 To Grid1.Rows - 1
xlsheet.Cells(i + 3, 1) = Trim(Grid1.TextMatrix(i, 1))
xlsheet.Cells(i + 3, 2) = Trim(Grid1.TextMatrix(i, 2))
xlsheet.Cells(i + 3, 3) = Trim(Grid1.TextMatrix(i, 3))
xlsheet.Cells(i + 3, 4) = Trim(Grid1.TextMatrix(i, 4))
xlsheet.Cells(i + 3, 5) = Trim(Grid1.TextMatrix(i, 5))
Next i
xlsheet.Cells(i + 5, 4) = "打印日期：" & Date
With xlsheet
.Range(.Cells(3, 1), .Cells(i + 3, 5)).Borders.LineStyle = xlContinuous '设置边框
End With
xlApp.Caption = "表打印预览"
xlApp.Visible = True
xlApp.ActiveSheet.PrintPreview '打印预览
xlbook.Save '保存文件
xlbook.Close
xlApp.Quit '退出EXCEL
Exit Sub
Else
aa = MsgBox("没有需要打印数据!", vbOKOnly, "信息提示!")
End If
Exit Sub
End If
Exit Sub
er:
htrs.ActiveConnection = Nothing
htdb.Close
xlbook.Close
xlApp.Quit '退出EXCEL
Unload Me
End Sub
Private Sub Command2_Click() '返回
On Error GoTo ex
rs1.Close
rs1.ActiveConnection = Nothing
Unload Me
ex:
Unload Me
End Sub
Private Sub Command4_Click() '重置
Text1.Text = ""
Combo1.Text = ""
Text1.SetFocus
End Sub
Private Sub DBC1_Change()
Data2.RecordSource = "select * from 合同信息表 where 单位名称 like '*" & Trim(DBC1.Text) & "*'"
Data2.Refresh
End Sub
Private Sub Command3_Click() '确定
On Error GoTo cc
Dim sqltr As String
Dim a() As String
ljs = 0
sqltr = ""
If Trim(Text1.Text) <> "" Then
Set db2 = New ADODB.Connection
Set rs2 = New ADODB.Recordset
db2.Open "Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & dblj & ";Persist Security Info=False"
sqlcx = "select 编号 from 开票情况表 where left(编号,2) = '" & Trim(Text1.Text) & "' AND 部门 like '" & Trim(Combo1.Text) & "%' GROUP BY 编号"
rs2.Open sqlcx, db2, adOpenKeyset, adLockBatchOptimistic
jls = rs2.RecordCount
If rs2.EOF Then
aa = MsgBox("你输入的合同号不存在, 请重新输入", vbOKOnly)
Text1.Text = ""
Combo1.Text = ""
Text1.SetFocus
Else
i = jls
ReDim a(i)
For j = 1 To i
a(j) = rs2!编号
rs2.MoveNext
Next j
部门收款查询.Caption = ""
部门收款查询.Caption = Trim(Text1.Text) & "年" & Trim(Combo1.Text) & "收款情况查询"
End If
rs2.Close
rs2.ActiveConnection = Nothing
db2.Close
n = 0
k = 0
For j = 1 To jls
Set db1 = New ADODB.Connection
db1.CursorLocation = adUseClient
db1.Open "Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & dblj & ";Persist Security Info=False"
Set rs1 = New ADODB.Recordset
sqltr = "select * from 收款情况 where " & " 编号 = '" & a(j) & "'"
rs1.Open sqltr, db1, adOpenKeyset, adLockOptimistic
res = rs1.RecordCount
n = n + res
Grid1.Rows = res + 1 + n
For i = 0 To res
If rs1.EOF = False Then
Grid1.TextMatrix(i + 1 + k, 1) = rs1!编号
Grid1.TextMatrix(i + 1 + k, 2) = Format(rs1!收款日期, "yy-mm-dd")
Grid1.TextMatrix(i + 1 + k, 3) = rs1!收款情况
Grid1.TextMatrix(i + 1 + k, 4) = rs1!收款金额
Grid1.TextMatrix(i + 1 + k, 5) = rs1!收款类型
'ljs = ljs + Val(Trim(rs1!收款金额))
rs1.MoveNext
End If
Next i
rs1.Close
rs1.ActiveConnection = Nothing
db1.Close
k = k + n
Next j
If res = 0 Then
MsgBox "没有查询到你需要的数据", vbOKOnly, "信息提示!!"
Text1.SetFocus
Exit Sub
End If
Else
MsgBox "你没有输入需要查询的条件", vbOKOnly, "提示信息!"
Text1.SetFocus
End If
Erase a()
cc:
End Sub
Private Sub Form_Activate()
Text1.SetFocus
End Sub
Private Sub Form_Load()
'dblj = "c:\htgl\data\htxxk.mdb"
Data2.DatabaseName = dblj
Data2.RecordSource = "开票情况表"
Combo1.AddItem "本部"
Combo1.AddItem "丁部"
Combo1.AddItem "郭部"
Combo1.AddItem "王部"
Grid1.ColWidth(0) = 0
Grid1.ColWidth(1) = 1000
Grid1.ColWidth(2) = 2500
Grid1.ColWidth(3) = 1800
Grid1.ColWidth(4) = 1800
Grid1.ColWidth(5) = 1800
Grid1.Rows = 2
Grid1.TextMatrix(0, 1) = "合同编号"
Grid1.TextMatrix(0, 2) = " 收款日期"
Grid1.TextMatrix(0, 3) = " 收款类型"
Grid1.TextMatrix(0, 4) = " 收到金额"
Grid1.TextMatrix(0, 5) = " 收款情况"
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -