📄 frmstatuspay.frm
字号:
VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Begin VB.Form FrmStatusPay
Caption = "实收房款统计"
ClientHeight = 4995
ClientLeft = 60
ClientTop = 450
ClientWidth = 7050
LinkTopic = "Form1"
ScaleHeight = 4995
ScaleWidth = 7050
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command2
Caption = "导出"
Height = 495
Left = 3840
TabIndex = 5
Top = 4200
Width = 1215
End
Begin VB.TextBox txtDate
Height = 270
Left = 1200
TabIndex = 2
Top = 52
Width = 1095
End
Begin VB.CommandButton Cmd_Search
Caption = "查 询"
Height = 375
Left = 3840
TabIndex = 1
Top = 0
Width = 975
End
Begin VB.CommandButton Cmd_Close
Caption = "关 闭"
Height = 495
Left = 2040
TabIndex = 0
Top = 4200
Width = 1215
End
Begin MSAdodcLib.Adodc Adodc1
Height = 330
Left = 240
Top = 4147
Visible = 0 'False
Width = 1935
_ExtentX = 3413
_ExtentY = 582
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 8
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = ""
OLEDBString = ""
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = ""
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin MSDataGridLib.DataGrid DataGrid1
Bindings = "FrmStatusPay.frx":0000
Height = 3375
Left = 0
TabIndex = 3
Top = 547
Width = 6855
_ExtentX = 12091
_ExtentY = 5953
_Version = 393216
HeadLines = 1
RowHeight = 15
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 2
BeginProperty Column00
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
EndProperty
BeginProperty Column01
EndProperty
EndProperty
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "收款日期："
Height = 180
Left = 120
TabIndex = 4
Top = 90
Width = 900
End
End
Attribute VB_Name = "FrmStatusPay"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private DataConn As New ADODB.Connection
Private DataRec As New ADODB.Recordset
Private DataCmd As New ADODB.Command
Private Sub Refresh_Pay()
Dim strSearch As String
If Trim(txtDate) <> "" Then
strSearch = " WHERE OptTime='" + Trim(txtDate.Text) + "'"
End If
'设置记录源
Adodc1.ConnectionString = Conn
'Adodc1.RecordSource = "SELECT OptTime As 收费日期, Sum(Amount) As 收费总金额" _
' + " FROM PayforRoom" + strSearch + " GROUP BY OptTime"
Adodc1.RecordSource = "SELECT RegId as 编号,OptTime As 收费日期, Amount As 收费金额,UserName as 经办人" _
+ " FROM PayforRoom" + strSearch
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.Columns(0).Width = 1000
DataGrid1.Columns(1).Width = 1500
DataGrid1.Columns(2).Width = 1500
DataGrid1.Columns(3).Width = 1500
End Sub
Private Sub Cmd_Close_Click()
Unload Me
End Sub
'查询客户消费信息
Private Sub Cmd_Search_Click()
Refresh_Pay
Print_E
Insert
End Sub
Private Sub Command2_Click()
Call ExporToExcel
End Sub
Private Sub Form_Load()
Refresh_Pay
End Sub
Public Sub Print_E()
SqlStmt = "DELETE FROM DZ"
SQLExt (SqlStmt)
End Sub
Public Sub Insert()
Dim strID As String
Dim strDate As String
Dim strAmount As String
Dim strName As String
While (Not (Adodc1.Recordset.EOF))
strID = Adodc1.Recordset.Fields("编号").Value
strDate = Adodc1.Recordset.Fields("收费日期").Value
strAmount = Adodc1.Recordset.Fields("收费金额").Value
strName = Adodc1.Recordset.Fields("经办人").Value
SqlStmt = "insert into DZ(CostId,OptTime,Amount,UserName) values('" + strID + "','" + strDate + "'," + strAmount + ",'" + strName + "')"
SQLExt (SqlStmt)
Adodc1.Recordset.MoveNext
Wend
End Sub
Public Sub ExporToExcel()
'建立一个ADO数据连接
Dim DataConn As New ADODB.Connection
Dim DataRec As New ADODB.Recordset
Dim strSQL As String
'若数据库连接出错，则转向ConnectionERR
On Error GoTo ConnectionERR
'建立一个连接字串
'这个连接串可能根据数据库配置的不同而不同
DataConn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;;Persist Security Info=False;Initial Catalog=Hotel;Data Source=114EF334F637425"
'建立数据库连接
DataConn.Open
'若RecordSet建立出错，则转向RecordsetERR
On Error GoTo RecordSetERR
strSQL = "SELECT * "
'从表authors查询
strSQL = strSQL & "FROM DZ"
Dim lngRowCount As Integer
Dim lngColCount As Integer
Dim ExcelAppX As Excel.Application
Dim ExcelBookX As Excel.Workbook
Dim ExcelSheetX As Excel.Worksheet
Dim ExcelQueryX As Excel.QueryTable
With DataRec
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = DataConn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strSQL
.Open
End With
With DataRec
If .RecordCount < 1 Then
Call MsgBox("没有记录!", vbExclamation, "错误")
Exit Sub
End If
'记录总数
lngRowCount = .RecordCount
'字段总数
lngColCount = .Fields.Count
End With
On Error GoTo ExcelERR
'建立Excel应用程序
Set ExcelAppX = CreateObject("Excel.Application")
'建立WorkBook
Set ExcelBookX = ExcelAppX.Workbooks().Add(App.Path & "\authors.xlsx")
'建立表格sheet1
Set ExcelSheetX = ExcelBookX.Worksheets("sheet1")
ExcelAppX.Visible = True
'添加查询，填充Excel表格
'注意此句！！！
'从A3处向右下填充表格
Set ExcelQueryX = ExcelSheetX.QueryTables.Add(DataRec, ExcelSheetX.Range("A3"))
'查询设置
With ExcelQueryX
'是否显示字段名
.FieldNames = False
'是否显示行号
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
'后台搜索
.BackgroundQuery = True
'刷新样式
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
'是否保存数据
.SaveData = True
'是否自动调整列宽度
.AdjustColumnWidth = False
'自动刷新间距，设置为0是关闭自动刷新
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
'进行查询
ExcelQueryX.Refresh
'设置字体和表格属性
With ExcelSheetX
.Range(.Cells(1, 1), .Cells(lngRowCount + 2, lngColCount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
'设置打印信息
' With ExcelSheetX.PageSetup
' .LeftHeader = "&""楷体_GB2312,常规""&10公司名称："
' .CenterHeader = "&""楷体_GB2312,常规""&10日期："
' .RightHeader = "&""楷体_GB2312,常规""&10单位："
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" & Date
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
' End With
ExcelAppX.Application.Visible = True
ExcelSheetX.PrintPreview
ExcelAppX.DisplayAlerts = False
ExcelAppX.Quit
Set ExcelAppX = Nothing '"交还控制给Excel
Set ExcelBookX = Nothing
Set ExcelSheetX = Nothing
Exit Sub
ConnectionERR:
'错误处理程序
MsgBox "数据库连接错误，" & Err.Description, vbCritical, "出错"
Exit Sub
RecordSetERR:
MsgBox "RecordSet生成错误，" & Err.Description, vbCritical, "出错"
DataConn.Close
Exit Sub
ExcelERR:
MsgBox "填充Excel表格错误，" & Err.Description, vbCritical, "出错"
If Not ExcelAppX Is Nothing Then ExcelAppX.Quit
DataRec.Close
DataConn.Close
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -