16.1 数据库基础
16.2 提高你的技巧
16.3 原始Excel数据库的集成
16.4 ADO
16.4.1 建立一个连接
代码
'代码清单16.1：一个简单的连接例子
Sub MakeConnectionExample()
Dim conn As ADODB.Connection
On Error GoTo ErrHandler
Set conn = New ADODB.Connection
conn.Provider = "Microsoft.Jet.OLEDB.4.0;"
conn.ConnectionString = "Data Source=F:\DataBase\cslBasicData.mdb"
conn.Open
If conn.State = adStateOpen Then
MsgBox "connected!", vbOKOnly
conn.Close
Else
MsgBox "not connected!", vbOKCancel
End If
Set conn = Nothing
Exit Sub
ErrHandler:
MsgBox "could not connect to database." & Err.Description, vbOKOnly
End Sub
Sub MakeConnectionExample()
Dim conn As ADODB.Connection
On Error GoTo ErrHandler
Set conn = New ADODB.Connection
conn.Provider = "Microsoft.Jet.OLEDB.4.0;"
conn.ConnectionString = "Data Source=F:\DataBase\cslBasicData.mdb"
conn.Open
If conn.State = adStateOpen Then
MsgBox "connected!", vbOKOnly
conn.Close
Else
MsgBox "not connected!", vbOKCancel
End If
Set conn = Nothing
Exit Sub
ErrHandler:
MsgBox "could not connect to database." & Err.Description, vbOKOnly
End Sub
16.4.2 准备、设置、查询
代码清单16.2：使用RECORDSET执行并显示一个查询
代码
'代码清单16.2：使用RECORDSET执行并显示一个查询
Sub RecordsetExample()
Dim rst As ADODB.Recordset
Dim sConn As String
Dim sSQL As String
Dim rg As Range
On Error GoTo ErrHandler
Set rg = ThisWorkbook.Worksheets(1).Range("A1")
'Create a new recordset object
Set rst = New ADODB.Recordset
'Connection details - this is the kind of thing
'that you can use the settings class for
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=F:\DataBase\cslBasicData.mdb"
'sql statement to retrieve list of employees
sSQL = "SELECT LastName, FirstName, Title FROM employees"
'Open the recordset
rst.Open sSQL, sConn
'copy recordset to the range
rg.CopyFromRecordset rst
'adjust column sizes
rg.CurrentRegion.Columns.AutoFit
'close the recordset
rst.Close
'clean up
Set rst = Nothing
Set rg = Nothing
Exit Sub
ErrHandler:
MsgBox "Sorry, an error occured. " & Err.Description, vbOKOnly
End Sub
Sub RecordsetExample()
Dim rst As ADODB.Recordset
Dim sConn As String
Dim sSQL As String
Dim rg As Range
On Error GoTo ErrHandler
Set rg = ThisWorkbook.Worksheets(1).Range("A1")
'Create a new recordset object
Set rst = New ADODB.Recordset
'Connection details - this is the kind of thing
'that you can use the settings class for
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=F:\DataBase\cslBasicData.mdb"
'sql statement to retrieve list of employees
sSQL = "SELECT LastName, FirstName, Title FROM employees"
'Open the recordset
rst.Open sSQL, sConn
'copy recordset to the range
rg.CopyFromRecordset rst
'adjust column sizes
rg.CurrentRegion.Columns.AutoFit
'close the recordset
rst.Close
'clean up
Set rst = Nothing
Set rg = Nothing
Exit Sub
ErrHandler:
MsgBox "Sorry, an error occured. " & Err.Description, vbOKOnly
End Sub
代码清单16.3：循环一个记录集
代码
'代码清单16.3：循环一个记录集
Sub LoopThroughRecordset(rst As ADODB.Recordset, rg As Range)
Dim nColumnOffset As Integer
Dim fld As ADODB.Field
'Use With...End With on rst to
'save typing & increase performance
'Downside - harder to read.
With rst
'Loop until we hit the end of the
'recordset
Do Until .EOF
'Loop through each field and retrieve it's value
nColumnOffset = 0
For Each fld In .Fields
rg.Offset(0, nColumnOffset).Value = fld.Value
nColumnOffset = nColumnOffset + 1
Next
'move down one row on the worksheet
Set rg = rg.Offset(1, 0)
'move to the next record
.MoveNext
Loop
End With
'clean up.
Set fld = Nothing
End Sub
Sub LoopThroughRecordset(rst As ADODB.Recordset, rg As Range)
Dim nColumnOffset As Integer
Dim fld As ADODB.Field
'Use With...End With on rst to
'save typing & increase performance
'Downside - harder to read.
With rst
'Loop until we hit the end of the
'recordset
Do Until .EOF
'Loop through each field and retrieve it's value
nColumnOffset = 0
For Each fld In .Fields
rg.Offset(0, nColumnOffset).Value = fld.Value
nColumnOffset = nColumnOffset + 1
Next
'move down one row on the worksheet
Set rg = rg.Offset(1, 0)
'move to the next record
.MoveNext
Loop
End With
'clean up.
Set fld = Nothing
End Sub
16.4.3 不仅仅是取回数据
代码清单16.4：执行查询动作
代码
'代码清单16 0.4: 执行查询动作
Sub TestActionQuery()
Dim conn As ADODB.Connection
Dim lRecordsAffected As Long
Dim sSql As String
On Error GoTo ErrHandler
Set conn = New ADODB.Connection
conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\Northwind.mdb"
conn.Open
If conn.State = adStateOpen Then
'add a new category
sSql = "INSERT INTO Categories([CategoryName],[Description])" & _
"Values('Jerky','Beef jerky, turkey jerky, and other tasty jerkies');"
lRecordsAffected = ActionQuery(conn, sSql)
MsgBox "added" & lRecordsAffected & " records.", vbOKOnly
'edit an existing category
sSql = "UPDATE Categories SET [Description] = " & _
"'Prepared meats except for jerky'" & _
"Where [Categories]='Meat/Poultry';"
lRecordsAffected = ActionQuery(conn, sSql)
MsgBox "Updated " & lRecordsAffected & " records.", vbOKOnly
conn.Close
End If
Set conn = Nothing
Exit Sub
ErrHandler:
MsgBox "Could not connect to database. " & Err.Description, vbOKOnly
End Sub
'/ returns number of records affected
Function ActionQuery(conn As ADODB.Connection, sSql As String) As Long
Dim lRecordsAffected As Long
Dim cmd As ADODB.Command
On Error GoTo ErrHandler
lRecordsAffected = 0
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = conn
.CommandText = sSql
.CommandType = adCmdText
.Execute lRecordsAffected
End With
'clean up.
Set cmd = Nothing
ExitPoint:
ActionQuery = lRecordsAffected
Exit Function
ErrHandler:
Debug.Print "ActionQuery error: " & Err.Description
Resume ExitPoint
End Function
Sub TestActionQuery()
Dim conn As ADODB.Connection
Dim lRecordsAffected As Long
Dim sSql As String
On Error GoTo ErrHandler
Set conn = New ADODB.Connection
conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\Northwind.mdb"
conn.Open
If conn.State = adStateOpen Then
'add a new category
sSql = "INSERT INTO Categories([CategoryName],[Description])" & _
"Values('Jerky','Beef jerky, turkey jerky, and other tasty jerkies');"
lRecordsAffected = ActionQuery(conn, sSql)
MsgBox "added" & lRecordsAffected & " records.", vbOKOnly
'edit an existing category
sSql = "UPDATE Categories SET [Description] = " & _
"'Prepared meats except for jerky'" & _
"Where [Categories]='Meat/Poultry';"
lRecordsAffected = ActionQuery(conn, sSql)
MsgBox "Updated " & lRecordsAffected & " records.", vbOKOnly
conn.Close
End If
Set conn = Nothing
Exit Sub
ErrHandler:
MsgBox "Could not connect to database. " & Err.Description, vbOKOnly
End Sub
'/ returns number of records affected
Function ActionQuery(conn As ADODB.Connection, sSql As String) As Long
Dim lRecordsAffected As Long
Dim cmd As ADODB.Command
On Error GoTo ErrHandler
lRecordsAffected = 0
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = conn
.CommandText = sSql
.CommandType = adCmdText
.Execute lRecordsAffected
End With
'clean up.
Set cmd = Nothing
ExitPoint:
ActionQuery = lRecordsAffected
Exit Function
ErrHandler:
Debug.Print "ActionQuery error: " & Err.Description
Resume ExitPoint
End Function
16.5 我喜欢款待
代码清单16.5：一个使用Analysis Services数据的基本例子
代码
Const msCONNECTION = "Data Source=localhost;Initial Catalog=FoodMart 2000;Provider=msolap;"
Sub BasicQueryExampleI()
Dim rst As ADODB.Recordset
Dim sMDX As String
Dim ws As Worksheet
On Error GoTo ErrHandler
Set ws = ThisWorkbook.Worksheets(2)
'an analysis services query
sMDX = "SELECT {[Measures].[Units Shipped],[Measures].[Units Ordered]} on columns, " & _
"NON EMPTY [Store].[Store City].members on rows " & _
"from Warehouse"
'You can use adodb.recordset or adomd.cellset
Set rst = New ADODB.Recordset
'open the recordset - implicit connection object creation
rst.Open sMDX, msCONNECTION
'use of the recordset object is handy because
'it allows use of the CopyFromRecordset method
ws.Cells(1, 1).CopyFromRecordset rst
rst.Close
ExitPoint:
Set rst = Nothing
Set ws = Nothing
Exit Sub
ErrHandler:
MsgBox "an error occured - " & Err.Description, vbOKOnly
Resume ExitPoint
End Sub
Sub BasicQueryExampleI()
Dim rst As ADODB.Recordset
Dim sMDX As String
Dim ws As Worksheet
On Error GoTo ErrHandler
Set ws = ThisWorkbook.Worksheets(2)
'an analysis services query
sMDX = "SELECT {[Measures].[Units Shipped],[Measures].[Units Ordered]} on columns, " & _
"NON EMPTY [Store].[Store City].members on rows " & _
"from Warehouse"
'You can use adodb.recordset or adomd.cellset
Set rst = New ADODB.Recordset
'open the recordset - implicit connection object creation
rst.Open sMDX, msCONNECTION
'use of the recordset object is handy because
'it allows use of the CopyFromRecordset method
ws.Cells(1, 1).CopyFromRecordset rst
rst.Close
ExitPoint:
Set rst = Nothing
Set ws = Nothing
Exit Sub
ErrHandler:
MsgBox "an error occured - " & Err.Description, vbOKOnly
Resume ExitPoint
End Sub
代码清单16.6: 一个使用ADOMD的基本范例
代码
'代码清单16.6: 一个使用ADOMD的基本范例
Const msCONNECTION = "Data Source=localhost;Initial Catalog=FoodMart 2000;Provider=msolap;"
Sub BasicQueryExampleII()
Dim cst As ADOMD.Cellset
Dim cat As ADOMD.Catalog
Dim sMDX As String
Dim ws As Worksheet
On Error GoTo ErrHandler
Set ws = ThisWorkbook.Worksheets(2)
'an analysis services query
sMDX = "SELECT {[Measures].[Units Shipped],[Measures].[Units Ordered]} on columns, " & _
"NON EMPTY [Store].[Store City].members on rows " & _
"from Warehouse"
'unfortunately you need to explicitly create
'this object for the Cellset object (a Cellset
'object can't implicitly create a connection
'like a recordset object can)
Set cat = New ADOMD.catalog
cat.ActiveConnection = msCONNECTION
'create new Cellset and query away
Set cst = New ADOMD.Cellset
cst.Open sMDX, cat.ActiveConnection
'call procedure to display the data
DisplayCellset cst, ws.Cells(1, 1)
cst.Close
ExitPoint:
Set cat = Nothing
Set cst = Nothing
Set ws = Nothing
Exit Sub
ErrHandler:
MsgBox "an error occured - " & Err.Description, vbOKOnly
Resume ExitPoint
End Sub
Sub DisplayCellset(cst As ADOMD.Cellset, rgTopLeft As Range)
Dim nRow As Integer
Dim nRowDimensionCount As Integer
Dim nColumnMember As Integer
Dim nRowDimension As Integer
Dim nRowMember As Integer
On Error GoTo ErrHandler
nRowDimensionCount = cst.Axes(1).DimensionCount
'Loop through the rows contained in the Cellset
For nRow = 0 To cst.Axes(1).positions.Count - 1
'display labels for each row item
For nRowDimension = 0 To nRowDimensionCount - 1
rgTopLeft.Offset(nRow, nRowDimension).Value = _
cst.Axes(1).positions(nRow).Members(nRowDimension).Caption
Next
'Display values at each dimension intersection
For nColumnMember = 0 To cst.Axes(0).Posions.Count - 1
rgTopLeft.Offset(nRow, nRowDimensionCount + nColumnMember).Value = _
cst.Item(nColumnMember, nRow).FormattedValue
Next
Next
ExitPoint:
Exit Sub
ErrHandler:
Debug.Print "DisplayCellset Error: " & Err.Description, vbOKOnly
Resume ExitPoint
End Sub
Const msCONNECTION = "Data Source=localhost;Initial Catalog=FoodMart 2000;Provider=msolap;"
Sub BasicQueryExampleII()
Dim cst As ADOMD.Cellset
Dim cat As ADOMD.Catalog
Dim sMDX As String
Dim ws As Worksheet
On Error GoTo ErrHandler
Set ws = ThisWorkbook.Worksheets(2)
'an analysis services query
sMDX = "SELECT {[Measures].[Units Shipped],[Measures].[Units Ordered]} on columns, " & _
"NON EMPTY [Store].[Store City].members on rows " & _
"from Warehouse"
'unfortunately you need to explicitly create
'this object for the Cellset object (a Cellset
'object can't implicitly create a connection
'like a recordset object can)
Set cat = New ADOMD.catalog
cat.ActiveConnection = msCONNECTION
'create new Cellset and query away
Set cst = New ADOMD.Cellset
cst.Open sMDX, cat.ActiveConnection
'call procedure to display the data
DisplayCellset cst, ws.Cells(1, 1)
cst.Close
ExitPoint:
Set cat = Nothing
Set cst = Nothing
Set ws = Nothing
Exit Sub
ErrHandler:
MsgBox "an error occured - " & Err.Description, vbOKOnly
Resume ExitPoint
End Sub
Sub DisplayCellset(cst As ADOMD.Cellset, rgTopLeft As Range)
Dim nRow As Integer
Dim nRowDimensionCount As Integer
Dim nColumnMember As Integer
Dim nRowDimension As Integer
Dim nRowMember As Integer
On Error GoTo ErrHandler
nRowDimensionCount = cst.Axes(1).DimensionCount
'Loop through the rows contained in the Cellset
For nRow = 0 To cst.Axes(1).positions.Count - 1
'display labels for each row item
For nRowDimension = 0 To nRowDimensionCount - 1
rgTopLeft.Offset(nRow, nRowDimension).Value = _
cst.Axes(1).positions(nRow).Members(nRowDimension).Caption
Next
'Display values at each dimension intersection
For nColumnMember = 0 To cst.Axes(0).Posions.Count - 1
rgTopLeft.Offset(nRow, nRowDimensionCount + nColumnMember).Value = _
cst.Item(nColumnMember, nRow).FormattedValue
Next
Next
ExitPoint:
Exit Sub
ErrHandler:
Debug.Print "DisplayCellset Error: " & Err.Description, vbOKOnly
Resume ExitPoint
End Sub
