home *** CD-ROM | disk | FTP | other *** search
- VERSION 5.00
- Begin VB.Form frmVBADOComplex
- Caption = "Form1"
- ClientHeight = 3210
- ClientLeft = 60
- ClientTop = 345
- ClientWidth = 2910
- LinkTopic = "Form1"
- ScaleHeight = 3210
- ScaleWidth = 2910
- StartUpPosition = 3 'Windows Default
- Begin VB.CommandButton cmdCellsetToExcel
- Caption = "Cell Set to Excel 8.0"
- Height = 555
- Left = 360
- TabIndex = 0
- Top = 405
- Width = 2130
- End
- Attribute VB_Name = "frmVBADOComplex"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- Private Sub cmdCellsetToExcel_Click()
- Dim cat As New ADOMD.Catalog
- Dim cst As New ADOMD.Cellset
- Dim axs As ADOMD.Axis
- Dim i As Integer
- Dim j As Integer
- Dim k As Integer
- Dim intCellX As Integer
- Dim intCellY As Integer
- Dim appExcel As New Excel.Application
- Dim wbkNew As Excel.Workbook, wksNew As Excel.Worksheet
- On Error GoTo Error_cmdCellsetToExcel_Click
- '*--------------------------------------------------------------------------------------------------
- '* Set Server to Local Host
- '*--------------------------------------------------------------------------------------------------
- strServer = "LOCALHOST"
- '*--------------------------------------------------------------------------------------------------
- '* Set MDX query string Source
- '*--------------------------------------------------------------------------------------------------
- strSource = strSource & "SELECT "
- strSource = strSource & "{[Measures].members} ON COLUMNS,"
- strSource = strSource & "NON EMPTY [Store].[Store City].members ON ROWS"
- strSource = strSource & " FROM Sales"
- '*--------------------------------------------------------------------------------------------------
- '* Set Active Connection
- '*--------------------------------------------------------------------------------------------------
- cat.ActiveConnection = "Data Source=" & strServer & ";Provider=msolap;"
- '*--------------------------------------------------------------------------------------------------
- '* Set Cell Set source to MDX query string
- '*--------------------------------------------------------------------------------------------------
- cst.Source = strSource
- '*--------------------------------------------------------------------------------------------------
- '* Set Cell Sets active connection to current connection
- '*--------------------------------------------------------------------------------------------------
- Set cst.ActiveConnection = cat.ActiveConnection
- '*--------------------------------------------------------------------------------------------------
- '* Open Cell Set
- '*--------------------------------------------------------------------------------------------------
- cst.Open
- '*--------------------------------------------------------------------------------------------------
- '* Create Workbook and Worksheet Objects
- '*--------------------------------------------------------------------------------------------------
- Set wbkNew = appExcel.Workbooks.Add
- Set wksNew = wbkNew.Worksheets.Add
- With wksNew
- '*--------------------------------------------------------------------------------------------------
- '* Read in All Column Headers
- '*--------------------------------------------------------------------------------------------------
- For i = 0 To cst.Axes(0).Positions.Count - 1
- intCellY = i + 2
- .Cells(1, intCellY).Value = cst.Axes(0).Positions(i).Members(0).Caption
- Next
- '*--------------------------------------------------------------------------------------------------
- '* Read in Row Header
- '*--------------------------------------------------------------------------------------------------
- For j = 0 To cst.Axes(1).Positions.Count - 1
- intCellX = j + 2
- .Cells(intCellX, 1).Value = cst.Axes(1).Positions(j).Members(0).Caption
- '*--------------------------------------------------------------------------------------------------
- '* Read in values for corresponding row header
- '*--------------------------------------------------------------------------------------------------
- For k = 0 To cst.Axes(0).Positions.Count - 1
- intCellY = k + 2
- .Cells(intCellX, intCellY).Value = cst(k, j).FormattedValue
- Next
- Next
- End With
- '*--------------------------------------------------------------------------------------------------
- '* Set Excel sheet to Visible
- '*--------------------------------------------------------------------------------------------------
- appExcel.Visible = True
- Set appExcel = Nothing
- Exit Sub
- Error_cmdCellsetToExcel_Click:
- Beep
- MsgBox "The Following OLE Error has occurred:" & vbCrLf & Err.Description, vbCritical, "OLE Error!"
- Set appExcel = Nothing
- End Sub
-