用类做自定义SQL读取函数及数组转置函数

microyip · 发表于 2020-1-11 17:27

本帖最后由 microyip 于 2020-1-17 08:03 编辑

今天看了一个帖子http://club.excelhome.net/thread-1517776-1-1.html，自己封装的VBA 连接数据库的函数
首先，我对作者的做适合自己使用的函数表示衷心赞赏。
接着，其实这个对一些对SQL应用有需求的人来说，也无疑是一个省事的操作。于是，把自己做的一个类修改成类似教程的样式，分享出来给大家使用。

SQL方式读取数据、数组转置的类(by.micro).rar (68.18 KB, 下载次数: 306)
1578734750(1).jpg

大家如果发现什么问题，欢迎提出质疑。（另，表格数据是来自今天的另一个贴，我回复后，顺手牵羊拿来做案例，请贴主opiona莫怪）

为方便阅读，先列个目录
1、类模块代码（二楼，http://club.excelhome.net/forum. ... 517858&pid=10209419）
2、示例模块（三楼，http://club.excelhome.net/forum. ... 517858&pid=10209420）

microyip · 发表于 2020-1-11 17:27

本帖最后由 microyip 于 2020-1-17 08:00 编辑

建立类模块ClassSQL

Private oConn As Object, oRS As Object, dicConnString As Object
Private Sub Class_Initialize() '类初始化过程
Set oConn = CreateObject("Adodb.Connection") '设置ADO连接对象
Set oRS = CreateObject("Adodb.RecordSet") '设置ADO记录对象
With oRS
.CursorLocation = 3 ' （实际是adUseClient值，考虑到没有引用ActiveX Data Objects Library，无法直接引用，改用数值代替）
.CursorType = 3 ' （实际是adOpenStatic值，考虑到没有引用ActiveX Data Objects Library，无法直接引用，改用数值代替）
.LockType = 4 ' （实际是adLockBatchOptimistic值，考虑到没有引用ActiveX Data Objects Library，无法直接引用，改用数值代替）
End With
Set dicConnString = CreateObject("Scripting.Dictionary") '建立打开ADO连接对象的语句字典
dicConnString("SQL") = "Provider=SQLOLEDB; User ID=SqlUserID;Password =SqlPassword;Data Source=SqlServerIP" 'SQL的打开ADO连接对象语句
If Val(Application.Version) < 12 Then
dicConnString("Excel") = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source=" 'Excel2003及以下的打开ADO连接对象语句
dicConnString("Access") = "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" 'Access2003及以下的打开ADO连接对象语句
Else
dicConnString("Excel") = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2';Data Source=" 'Excel2007及以上的打开ADO连接对象语句
dicConnString("Access") = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" 'Access2007及以上的打开ADO连接对象语句
End If
End Sub
'——————数组转置——————开始
Function Transpose(ByVal Data As Variant, Optional To2Dim As Boolean) As Variant
'------------------------------
'功能：转置二维以下的数组
'参数说明：
'To2Dim,强制为二维数组
'------------------------------
Dim vNew As Variant, nNewRow As Double, nNewCol As Double
Dim nRow As Double, nCol As Double, nDim As Long
Dim nMinRow As Double, nMaxRow As Double, nMinCol As Double, nMaxCol As Double
If Not IsArray(Data) Then '如果源数组不是数组
If To2Dim Then
ReDim vNew(1 To 1, 1 To 1)
vNew(1, 1) = Data
Else
ReDim vNew(1 To 1)
vNew(1) = Data
End If
Else
nDim = 1 '预设源数组维度为1维
On Error Resume Next
Do
vNew = UBound(Data, nDim + 1) '尝试读取源数组数据的第nDim+1维的最大上限值
If Err.Number <> 0 Then Exit Do
nDim = nDim + 1
Loop
Err.Clear
On Error GoTo 0
If nDim >= 3 Then Exit Function '源数组维数大于或等于3时
nMinRow = LBound(Data) '源数组最少行号
nMaxRow = UBound(Data) '源数组最大行号
If nDim = 1 Then
ReDim vNew(1 To 1, 1 To nMaxRow - nMinRow + 1)
For nRow = nMinRow To nMaxRow
nNewRow = nNewRow + 1
If Not IsError(Data(nRow)) Then vNew(1, nNewRow) = Data(nRow)
Next
Else
nMinCol = LBound(Data, 2) '源数组最小列号
nMaxCol = UBound(Data, 2) '源数组最大列号
If nMinRow = nMaxRow And Not To2Dim Then
ReDim vNew(1 To nMaxCol - nMinCol + 1)
nRow = nMinRow
For nCol = nMinCol To nMaxCol
nNewCol = nNewCol + 1
If Not (IsError(Data(nRow, nCol)) Or IsNull(Data(nRow, nCol))) Then vNew(nNewCol) = Data(nRow, nCol)
'IsError的检查，目的是解决Excel读取的数值可能存在错误值
'Isnull的检查，目的是解决Access或SQL读取的数据可能存在Null数值
Next
Else
ReDim vNew(1 To nMaxCol - nMinCol + 1, 1 To nMaxRow - nMinRow + 1)
For nRow = nMinRow To nMaxRow
nNewCol = nNewCol + 1
nNewRow = 0
For nCol = nMinCol To nMaxCol
nNewRow = nNewRow + 1
If Not (IsError(Data(nRow, nCol)) Or IsNull(Data(nRow, nCol))) Then vNew(nNewRow, nNewCol) = Data(nRow, nCol)
Next
Next
End If
End If
End If
Transpose = vNew
End Function
'——————数组转置——————结束
'——————SQL获取数据——————开始
Function GetDataBySQL(ByVal SQL As String, ByVal SqlType As String, ByVal FileOrServer As String, _
Optional ByVal UserID As String, Optional UserPassword As String, Optional ByVal OutputTitle As Boolean, Optional ByVal ExcelUseTitle As Boolean = True) As Variant
'----------------------------------------------------------------------------------------------------
'参数说明：
'SQL，SQL语句
'SqlType，SQL读取对象类型，注意大小写，包括"SQL"、"Excel"、"Access"
'FileOrServer，Excel和Access文件全路径名或者SQL服务器IP
'UserID，读取SQL服务器时的用户帐号，对于读取Excel和Access时不用填
'UserPassword，读取SQL服务器时的用户密码，对于读取Excel和Access时不用填
'OutputTitle，可选项，默认为False，输出数据是否带标题
'ExcelUseTitle，可选项，默认为True，只对Excel读取产生作用，读取Excel时是否将第一行认为是标题
'----------------------------------------------------------------------------------------------------
Dim vTmp As Variant, nRow As Double, nCol As Double, vRS As Variant, sConnString As String
If dicConnString.exists(SqlType) Then '检查是否存在打开ADO连接的语句
sConnString = dicConnString(SqlType)
Else
GetDataBySQL = "不是指定的SQL读取对象类型！请使用""SQL""、""Excel""、""Access""其中一种！"
Exit Function
End If
If FileOrServer = "" Then
If SqlType = "SQL" Then
GetDataBySQL = "未设置SQL读取对象的SQL服务器IP！"
Else
GetDataBySQL = "未设置SQL读取对象的Excel或Access文件的全路径文件名！"
End If
Exit Function
End If
If SqlType = "SQL" Then
If UserID = "" Then UserID = "sa"
sConnString = Replace(sConnString, "SqlUserID", UserID)
sConnString = Replace(sConnString, "SqlPassword", UserPassword)
sConnString = Replace(sConnString, "SqlServerIP", FileOrServer)
Else
If SqlType = "Excel" And Not ExcelUseTitle Then sConnString = Replace(sConnString, "YES", "NO")
sConnString = sConnString & FileOrServer
End If
On Error Resume Next
With oConn
If oRS.State Then oRS.Close '检查ADO记录对象是否处于打开，如果打开就关闭
If .State Then .Close '检查ADO连接对象是否处于打开，如果打开就关闭
.ConnectionString = sConnString '设置ADO连接对象的连接方式
.Open '打开ADO连接对象
If Err.Number <> 0 Then
Err.Clear
If SqlType = "SQL" Then
GetDataBySQL = "SQL服务器连接失败，请检查服务器IP、用户帐号、用户密码！"
Else
GetDataBySQL = SqlType & "连接失败，请检查全路径文件名是否正确！"
End If
On Error GoTo 0
Exit Function
End If
If SqlType = "SQL" Then
.CommandTimeout = 720 '设置命令执行超时时间
.ConnectionTimeout = 720 '设置连接超时时间
End If
Set oRS = .Execute(SQL) '执行SQL语句并返回到ADO记录对象
If Err.Number <> 0 Then
Err.Clear
GetDataBySQL = "SQL语句错误！"
On Error GoTo 0
Exit Function
End If
On Error GoTo 0
If oRS.State Then '如果执行Delete，Update之类语句，此记录处于关闭状态
If OutputTitle Then
ReDim vTmp(1 To oRS.Fields.Count, 1 To 1) '建立标题数组
Do While nCol < oRS.Fields.Count '
vTmp(nCol + 1, 1) = oRS.Fields(nCol).Name '字段名
nCol = nCol + 1
Loop
End If
If Not (oRS.EOF And oRS.BOF) Then
vRS = oRS.GetRows '从ADO记录对象中获取数据数组
If IsArray(vRS) Then
vRS = Transpose(Data:=vRS, To2Dim:=True) '转置数据数组
If OutputTitle Then
ReDim Preserve vTmp(1 To UBound(vTmp), 1 To 1 + UBound(vRS)) '将标题数组扩展到数据数组的行数
vTmp = Transpose(Data:=vTmp, To2Dim:=True) '转置带标题的空数据数组
For nRow = 1 To UBound(vRS)
For nCol = 1 To UBound(vRS, 2)
vTmp(1 + nRow, nCol) = vRS(nRow, nCol) '从数据数组向带标题的数组赋值数据
Next
Next
vRS = vTmp
End If
End If
ElseIf OutputTitle Then
vRS = Transpose(Data:=vTmp, To2Dim:=True) '转置标题数组
Else
vRS = "没有符合条件数据！"
End If
GetDataBySQL = vRS
oRS.Close
End If
If .State Then .Close
End With
End Function
'——————SQL获取数据——————结束

复制代码

microyip · 发表于 2020-1-11 17:28

示例模块代码

Private clsSQL As ClassSQL
Sub Tr_Sample()
'转置二维以下的数组示例
Dim vData As Variant, vNew As Variant
If clsSQL Is Nothing Then Set clsSQL = New ClassSQL '如果clsSQL变量未初始化设置，进行初始化设置
vNew = clsSQL.Transpose(Data:=vData) '对未进行设置的vData变形变量进行转置
MsgBox "成功转置未进行设置的vData变形变量成功转置！"
vNew = clsSQL.Transpose(Data:="这是字符串") '对字符串进行转置
MsgBox "成功转置字符串并得到vNew一维数值！"
vNew = clsSQL.Transpose(Data:=123, To2Dim:=True) '对数字进行强制转置为二维数组
MsgBox "成功强制转置数字并得到vNew二维数值！"
ReDim vData(1 To 2) '设置vData为一维数组
vNew = clsSQL.Transpose(Data:=vData) '对一维vData数组进行转置
MsgBox "成功转置一维数组并得到vNew二维数值！"
vData = Sheet1.[A1:C1].Value '从表中获取一列数组
vNew = clsSQL.Transpose(Data:=vData) '对vData数组进行转置
MsgBox "成功转置只有一行数据的二维数组并得到vNew一维数值！"
vNew = clsSQL.Transpose(Data:=vData, To2Dim:=True) '对vData数组进行强制转置为二维数组
MsgBox "成功强制转置只有一行数据的二维数组并得到vNew二维数值！"
vData = Sheet1.[A1:C30].Value '从表中获取数组
vNew = clsSQL.Transpose(vData) '对vData数组进行转置
MsgBox "成功转置数组并得到vNew二维数值！"
End Sub
Sub BT_Click(ByVal SqlType As String)
'SQL方式读取数据
Dim sSQL As String, vData As Variant, bOutputTitle As Boolean, wSH As Worksheet
If clsSQL Is Nothing Then Set clsSQL = New ClassSQL '如果clsSQL变量未初始化设置，进行初始化设置
bOutputTitle = Sheet1.ToggleButton1.Value '使用输出有标题数据
If bOutputTitle Then
Set wSH = Sheet2 '有标题的输出表
Else
Set wSH = Sheet3 '无标题的输出表
End If
If SqlType = "SQL" Then
sSQL = "Select * From [库名].dbo.[表名]"
'注意：库名为数据库的名字，表名为数据库内的表的名字
vData = clsSQL.GetDataBySQL(SQL:=sSQL, SqlType:=SqlType, FileOrServer:="192.168.1.231", UserID:="sa", UserPassword:="sa", OutputTitle:=bOutputTitle)
ElseIf SqlType = "Excel" Then
sSQL = "Select * From [源数据$] Where [数值]>500"
vData = clsSQL.GetDataBySQL(SQL:=sSQL, SqlType:=SqlType, FileOrServer:=ThisWorkbook.Path & "\test.xlsx", OutputTitle:=bOutputTitle)
ElseIf SqlType = "Access" Then
sSQL = "Select * From [源数据] Where [数值]<200"
vData = clsSQL.GetDataBySQL(SQL:=sSQL, SqlType:=SqlType, FileOrServer:=ThisWorkbook.Path & "\test.accdb", OutputTitle:=bOutputTitle)
End If
If Not IsArray(vData) Then '说明SQL读取失败
MsgBox vData
Else
With wSH
.UsedRange.Offset(1 + 1 * bOutputTitle).ClearContents
.[A1].Offset(1 + 1 * bOutputTitle).Resize(UBound(vData), UBound(vData, 2)) = vData
.Select
End With
End If
End Sub

复制代码

microyip · 发表于 2020-1-12 10:34

霸多一层楼，留待以后更新用

shandongdxl · 发表于 2020-1-16 21:59

感谢分享~代码值得收藏

FOB_FN_L · 发表于 2020-1-17 02:47

代码值得收藏

水和米 · 发表于 2020-10-9 11:20

小火箭，这个肯定用的到，收藏了！

zhangmi · 发表于 2020-10-9 21:06

感谢分享，收藏一下

yzxfelix · 发表于 2022-4-13 22:57

大师啊，好资料，虽然看不懂

yzxfelix · 发表于 2022-4-13 23:08

这个举例挺不错奥

		自动登录	找回密码
密码			免费注册

[原创] 用类做自定义SQL读取函数及数组转置函数

评分

最新热点 /1