Function qh_excel_query(qh_strSQL0, Optional qh_PathStr0 = "", Optional qh_file0 = True) 'sql方式查询本表的数据,返回二维数组 作者:阙辉 2021.03.29
Dim qh_Conn As Object, qh_Rst As Object
Dim qh_strConn As String, qh_strSQL As String
Dim qh_i As Integer, qh_PathStr As String
Dim qh_result_array
Dim qh_result_array_l As Long
Dim qh_result_array_row
Dim qh_count As Long
Dim qh_is_wps
Dim qh_RstConn
Dim qh_RstRst
Dim qh_file
qh_strSQL = qh_strSQL0
qh_file = qh_file0
Set qh_Conn = CreateObject("ADODB.Connection")
Set qh_Rst = CreateObject("ADODB.Recordset")
'设置工作簿的完整路径和名称
If qh_PathStr0 = "" Then
qh_PathStr = ThisWorkbook.FullName
Else
qh_PathStr = qh_PathStr0
End If
On Error GoTo QH_MyErr
'如果程序执行报错,则跳转至QH_MyErr
qh_strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & qh_PathStr
'设置SQL查询语句
'qh_strSQL = "SELECT * FROM [凭证$]"
qh_Conn.Open qh_strConn '打开数据库链接
Set qh_Rst = qh_Conn.Execute(qh_strSQL) '执行^查询,并将结果输出到记录集对象
With qh_Rst
qh_count = .Fields.Count
If qh_file Then '输出结果是否需要标题 true是需要 false不需要
'重置行数组
ReDim qh_result_array_row(1 To qh_count)
'获取标题
For qh_i = 0 To qh_count - 1 '填写标题
qh_result_array_row(qh_i + 1) = .Fields(qh_i).Name
Next qh_i
'重置结果数组
ReDim qh_result_array(0 To 0)
qh_result_array(0) = qh_result_array_row
qh_star = 0
Else
'重置结果数组
ReDim qh_result_array(1 To 1)
qh_star = 1
End If
'获取结果数据
On Error Resume Next
qh_count_row = 1 'flag
Do Until .EOF
'解析行数据
ReDim qh_result_array_row(1 To qh_count)
For qh_i = 0 To qh_count - 1
qh_value = .Fields(qh_i).Value
If IsNull(qh_value) Then
qh_value = ""
End If
qh_result_array_row(qh_i + 1) = qh_value
Next
qh_result_array_l = qh_len_arr(qh_result_array)
If qh_star = 1 And qh_count_row = 1 Then
' 如果qh_star = 1 And qh_count_row = 1则不需要重置结果数组
Else
qh_result_array_l = qh_result_array_l + qh_star '因为数组是从0开始,所以不用加1
ReDim Preserve qh_result_array(qh_star To qh_result_array_l)
End If
qh_result_array(qh_result_array_l) = qh_result_array_row
qh_count_row = qh_count_row + 1 'flag
.MoveNext
Loop
.Close '关闭数据库连接
End With
qh_Conn.Close
Set qh_RstConn = Nothing
Set qh_RstRst = Nothing
qh_excel_query = qh_result_array
Exit Function
QH_MyErr: '当排柜表有序号时,SQL需要加序号后执行
qh_strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & qh_PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
'设置SQL查询语句
'qh_strSQL = "SELECT * FROM [凭证$]"
qh_Conn.Open qh_strConn '打开数据库链接
Set qh_Rst = qh_Conn.Execute(qh_strSQL) '执行^查询,并将结果输出到记录集对象
With qh_Rst
qh_count = .Fields.Count
If qh_file Then '输出结果是否需要标题 true是需要 false不需要
'重置行数组
ReDim qh_result_array_row(1 To qh_count)
'获取标题
For qh_i = 0 To qh_count - 1 '填写标题
qh_result_array_row(qh_i + 1) = .Fields(qh_i).Name
Next qh_i
'重置结果数组
ReDim qh_result_array(0 To 0)
qh_result_array(0) = qh_result_array_row
qh_star = 0
Else
'重置结果数组
ReDim qh_result_array(1 To 1)
qh_star = 1
End If
'获取结果数据
On Error Resume Next
qh_count_row = 1 'flag
Do Until .EOF
'解析行数据
ReDim qh_result_array_row(1 To qh_count)
For qh_i = 0 To qh_count - 1
qh_value = .Fields(qh_i).Value
If IsNull(qh_value) Then
qh_value = ""
End If
qh_result_array_row(qh_i + 1) = qh_value
Next
qh_result_array_l = qh_len_arr(qh_result_array)
If qh_star = 1 And qh_count_row = 1 Then
' 如果qh_star = 1 And qh_count_row = 1则不需要重置结果数组
Else
qh_result_array_l = qh_result_array_l + qh_star '因为数组是从0开始,所以不用加1
ReDim Preserve qh_result_array(qh_star To qh_result_array_l)
End If
qh_result_array(qh_result_array_l) = qh_result_array_row
qh_count_row = qh_count_row + 1 'flag
.MoveNext
Loop
.Close '关闭数据库连接
End With
qh_Conn.Close
Set qh_RstConn = Nothing
Set qh_RstRst = Nothing
qh_excel_query = qh_result_array
End Function
VBA-SQL封装查询函数
最新推荐文章于 2023-08-10 15:45:27 发布
![](https://img-home.csdnimg.cn/images/20240711042549.png)