批处理之家 - Powered by Discuz! Board

Dim objConnection 'CONNECTION对象实例
Dim objRecordSet 'RECORDSET对象实例
Dim objCommand '命令对象实例
Dim strConnectionString '连接字符串
Dim Tsql 'sql操作
Dim MyArray() '数组（存储表有多少列名）
' ********************************************************************
' 函数说明：连接数据库;
' 参数说明：(1)strDBType（数据库类型：如ORACEL；DB2；SQL；ACCESS）
' (2)strDBAlias（数据库别名）
' (3)strUID（用户名）
' (4)strPWD（密码）
' (5)strIP（数据库IP地址：仅SQL SERVER 使用）
' (6)strLocalHostName（本地主机名：仅SQL SERVER 使用）
' (7)strDataSource（数据源：仅ACCESS使用；如d:\yysc.mdb）
' 返回结果：无
' 调用方法: ConnectDatabase(strDBType, strDBAlias, strUID, strPWD, strIP, strLocalHostName, strDataSource)
' ********************************************************************
Sub ConnectDatabase(strDBType, strDBAlias, strUID, strPWD, strIP, strLocalHostName, strDataSource)
Set objConnection = CreateObject("ADODB.CONNECTION") '1 - 建立CONNECTION对象的实例
Select Case UCase(Trim(strDBType))
Case "ORACLE"
strConnectionString = "Driver={Microsoft ODBC for Oracle};Server=" & strDBAlias & ";Uid="_
& strUID & ";Pwd=" & strPWD & ";" '2 - 建立连接字符串
objConnection.Open strConnectionString '3 - 用Open 方法建立与数据库连接
Case "DB2"
strConnectionString = "Driver={IBM DB2 ODBC DRIVER};DBALIAS=" & strDBAlias & ";Uid="_
& strUID & ";Pwd=" & strPWD & ";"
objConnection.Open strConnectionString
Case "SQL"
strConnectionString = "DRIVER=SQL Server; SERVER=" & strIP & "; UID=" & strUID & "; PWD="_
& strPWD & "; APP=Microsoft Office 2003;WSID=" & strLocalHostName & "; DATABASE=" & strDBAlias & ";"
objConnection.Open strConnectionString
Case "ACCESS"
strConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & strDataSource &_
";Jet OLEDB:Database Password=" & strPWD & ";" 'win7X64位 access驱动用
'strConnectionString = "provider=microsoft.jet.oledb.4.0;data source=" & strDataSource &_
' ";Jet OLEDBatabase Password=" & strPWD & ";" ’'winXP access驱动用
objConnection.Open strConnectionString
Case Else
MsgBox "输入的数据库类型格式有误" & vbCrLf & "支持的数据库类型格式：ORACLE；DB2；SQL；ACCESS；EXCEL"
End Select
If (objConnection.State = 0) Then
MsgBox "连接数据库失败！"
End If
End Sub
' ********************************************************************
' 函数说明：查询数据库（查询单列）;
' 参数说明： (1)strSql：SQL语句
' (2)strFieldName：字段名
' (3)str_Array_QueryResult：数组名（用来返回单列查询结果）
' 返回结果： intArrayLength：查询数据库返回的记录行数
' str_Array_QueryResult：数组名（用来返回单列查询结果）
' 调用方法: intArrayLength = QueryDatabase(strSql, strFieldName, str_Array_QueryResult)
' ********************************************************************
Function QueryDatabase(strSql, strFieldName, str_Array_QueryResult)
Dim intArrayLength '数组长度
Dim i
i = 0
str_Array_QueryResult = Array() '重新初始化数组为一个空数组
Set objRecordSet = CreateObject("ADODB.RECORDSET") '4 - 建立RECORDSET对象实例
Set objCommand = CreateObject("ADODB.COMMAND") '5 - 建立COMMAND对象实例
objCommand.ActiveConnection = objConnection
objCommand.CommandText = strSql
objRecordSet.CursorLocation = 3
objRecordSet.Open objCommand '6 - 执行SQL语句,将结果保存在RECORDSET对象实例中
intArrayLength = objRecordSet.RecordCount '将查询结果的行数作为数组的长度
If intArrayLength > 0 Then
ReDim str_Array_QueryResult(intArrayLength-1)
Do While NOT objRecordSet.EOF '将数据库查询的列值赋值给数组
str_Array_QueryResult(i) = objRecordSet(strFieldName)
MsgBox str_Array_QueryResult(i)
objRecordSet.MoveNext
i = i + 1
Loop
Else
'ReDim str_Array_QueryResult(0)
'str_Array_QueryResult(0) = ""
End If
QueryDatabase = intArrayLength
End Function
' ********************************************************************
' 函数说明：返回符合查询结果的列的长度
' 参数说明：(1)strSql：SQL语句
' 返回结果：返回符合查询结果的列的长度
' 调用方法: MaxLength = GetLenOfField(strSql)
' ********************************************************************
Function GetLenOfField(strSql)
'如果SQL语句为空，则默认返回的列长度为0，结束函数;否则返回列的实际长度
If strSql = "" Then
GetLenOfField = 0
Exit Function
Else
Set objRecordSet = CreateObject("ADODB.RECORDSET") '4 - 建立RECORDSET对象实例
Set objCommand = CreateObject("ADODB.COMMAND") '5 - 建立COMMAND对象实例
objCommand.ActiveConnection = objConnection
objCommand.CommandText = strSql
objRecordSet.CursorLocation = 3
objRecordSet.Open objCommand '6 - 执行SQL语句,将结果保存在RECORDSET对象实例中
GetLenOfField = objRecordSet.RecordCount '返回符合查询结果的列的长度
Set objCommand = Nothing
Set objRecordSet = Nothing
End If
End Function
' ********************************************************************
' 函数说明：返回符合查询结果的行的长度
' 参数说明：(1)strSql：SQL语句
' 返回结果：无
' 调用方法: count=GetLenght(strSql)
' ********************************************************************
Function GetLenght(strSql)
Dim objCommand
Dim objField
If strSql = "" Then
GetLenght = 0
Exit Function
Else
Set objCommand = CreateObject("ADODB.COMMAND")
Set objRecordSet = CreateObject("ADODB.RECORDSET")
objCommand.CommandText = strSql
objCommand.ActiveConnection = objConnection
Set objRecordSet = objCommand.Execute
ii=0
Do Until objRecordSet.EOF
For Each objField In objRecordSet.Fields
ii=ii+1
Next
objRecordSet.MoveNext
Debug.WriteLine
Loop
GetLenght = ii
Set objCommand = Nothing
Set objRecordSet = Nothing
End If
End Function
' ********************************************************************
' 函数说明：返回符合查询结果的表的名称
' 参数说明：(1)strSql：SQL语句
' 返回结果：无
' 调用方法: Array()=GetArray(strSql)
' ********************************************************************
Sub GetArray(strSql)
Dim objCommand
Dim objField
GetdataArray = Array()
hh = GetLenOfField(strSql) '列长
ll = GetLenght(strSql) '行长
Set objCommand = CreateObject("ADODB.COMMAND")
Set objRecordSet = CreateObject("ADODB.RECORDSET")
objCommand.CommandText = strSql
objCommand.ActiveConnection = objConnection
Set objRecordSet = objCommand.Execute
Set objExcel = CreateObject("Excel.Application")
Set objWorkBook = objExcel.Workbooks.Open("d:\\1.xls")
Set objWorkSheet = objWorkBook.Sheets(1)
objExcel.Visible = False
k=1
ReDim GetdataArray(ll)
Do Until objRecordSet.EOF
For Each objField In objRecordSet.Fields
If k Mod (ll/hh)<> 0 Then
GetdataArray(k-1)=objField.Name
k=k+1
Else
GetdataArray(k-1)=objField.Name
Exit Do
End If
Next
objRecordSet.MoveNext
Loop
For i=1 To ll/hh
objWorkSheet.cells(1,i)=GetdataArray(i-1)
Next
objExcel.Workbooks(1).Save
objExcel.Workbooks(1).Close
objExcel.Quit
Set objExcel = Nothing
Set objWorkBook = Nothing
Set objWorkSheet = Nothing
Set objCommand = Nothing
Set objRecordSet = Nothing
End Sub
' ********************************************************************
' 函数说明：更新数据库;包括INSERT、DELETE 和 UPDATE操作
' 参数说明：(1)strSql：SQL语句
' 返回结果：无
' 调用方法: UpdateDatabase(strSql)
' ********************************************************************
Sub UpdateDatabase(strSql)
Dim objCommand
Dim objField
hh = GetLenOfField(strSql) '列长
ll = GetLenght(strSql) '行长
Set objCommand = CreateObject("ADODB.COMMAND")
Set objRecordSet = CreateObject("ADODB.RECORDSET")
objCommand.CommandText = strSql
objCommand.ActiveConnection = objConnection
Set objRecordSet = objCommand.Execute
Set objExcel = CreateObject("Excel.Application")
Set objWorkBook = objExcel.Workbooks.Open("d:\\1.xls")
Set objWorkSheet = objWorkBook.Sheets(1)
objExcel.Visible = True
i=1
ii=1
Do While NOT objRecordSet.EOF '将数据库查询的列值赋值给EXECL
For ii=1 To ll/hh
objWorkSheet.cells(i+1,ii) = objRecordSet(ii-1)
Next
objRecordSet.MoveNext
i = i + 1
Loop
objExcel.Workbooks(1).Save
'objExcel.Workbooks(1).Close
'objExcel.Quit
Set objExcel = Nothing
Set objWorkBook = Nothing
Set objWorkSheet = Nothing
Set objCommand = Nothing
Set objRecordSet = Nothing
End Sub
' ********************************************************************
' 函数说明：关闭数据库连接;
' 参数说明：无
' 返回结果：无
' 调用方法: CloseDatabase()
' ********************************************************************
Sub CloseDatabase()
objRecordSet.Close
objConnection.Close
Set objCommand = Nothing
Set objRecordSet = Nothing
Set objConnection = Nothing
End Sub
Dim data1,data2
data1= InputBox("请输入开始日期","提示","2016-06-01")
If IsEmpty(data1) Then WScript.Quit
'MsgBox data1 显示输入日期
data2= InputBox("请输入结束日期","提示","2016-07-01")
If IsEmpty(data2) Then WScript.Quit
'MsgBox data2
Tsql ="select rfkh ,xfje From lssj where xfzl='消费' and xfsj between '" & data1 & "' and '"& data2 &"'" 'dtmTargetDate >= dtmStartDate AND dtmTargetDate <= dtmEndDate
'Tsql ="select a.姓名 , a.当前余额,b.xf from (select rfkh,ryxm as 姓名 ,rfye as 当前余额 From ryxx) a left join "_
' &"(select rfkh ,max(xfje) as xf From lssj where xfzl='消费' and xfsj between '" & data1 & "' and '"& data2 &"' group by rfkh) b on a.rfkh=b.rfkh "
'Tsql= Tsql&"(select rfkh ,sum(xfje) as 本月增款金额 From lssj "&" "
'Tsql= Tsql&"where xfzl='增款' and xffs='现金交费' and xfsj between '" & data1 & "' and '" & data2 &"' group by rfkh) c on a.rfkh=c.rfkh join "&" "
'Tsql= Tsql&"(select rfkh ,sum(xfje) 总消费金额 From lssj "&" "
'Tsql= Tsql&"where xfzl='消费' group by rfkh) x on a.rfkh=x.rfkh join "&" "
'Tsql= Tsql&"(select rfkh ,sum(xfje) 总增款金额 From lssj "&" "
'Tsql= Tsql&"where xfzl='增款' and xffs='现金交费' group by rfkh) z on a.rfkh=z.rfkh where a.姓名 <>'院' order by a.姓名"
'Call ConnectDatabase("ORACLE","longtj","ltjn","ltjn","","","") '数据连接操作
Call ConnectDatabase("ACCESS","","","","","","D:\Program Files\小麦科技消费系统\database\xf.mdb") '数据连接操作
Call GetArray(Tsql)
Call UpdateDatabase(Tsql)