一个VB中的代码直接复制到ACCESS中的问题

大熊屋　发表于：2008-04-15 17:02:34 　

网上找了一段代码：如下

Public Sub ExportToExcel(ByVal dc As DynamiCubeLib.DCube) 'access 中
DynamiCubeLibCtl.DCube 'vb中

一下均为VB中代码，我直接拷到ACCESS中了。
Dim oXLApp As Object, cnt As Integer, iMaxRowDepth As Integer, iMaxColDepth As Integer
Dim iCol As Integer, iRow As Integer, iColDepth As Integer, iRowDepth As Integer
Dim xlCol As Integer, xlRow As Integer, iTempMaxColDepth As Integer, viscnt As Integer

On Error Resume Next
Screen.MousePointer = 11

If dc.ColCount > 256 Then
    MsgBox "The view has to many columns for Excel to handle.", vbCritical
    Screen.MousePointer = 0
    Exit Sub
End If

' Creates OLE object to Excel
    Set oXLApp = CreateObject("excel.application")
    If Err Or (oXLApp Is Nothing) Then
        Call MsgBox("Could not create excel application object. Please check Excel installation.", vbCritical, "Oops")
        Exit Sub
    End If
        oXLApp.Workbooks.Add
        oXLApp.Visible = True

' Find out MaxRowDepth
    cnt = 0
    Do While cnt < dc.RowCount
        If dc.GetRowDepth(cnt) > iMaxRowDepth Then iMaxRowDepth = dc.GetRowDepth(cnt)
        cnt = dc.GetNextRow(cnt)
    Loop
' Find out MaxColDepth
    iMaxColDepth = 0
    cnt = 0
    Do While cnt < dc.ColCount - 1
        If iMaxColDepth < dc.GetColDepth(cnt) Then iMaxColDepth = dc.GetColDepth(cnt)
        cnt = dc.GetNextCol(cnt)
    Loop

' Export Column Headings; start at iMaxRowDepth
If MultipleVisDatas(dc) Then
iTempMaxColDepth = (iMaxColDepth + 1)
Else
iTempMaxColDepth = iMaxColDepth
End If

For iColDepth = 1 To (iTempMaxColDepth)
    iCol = 0
    xlCol = (iMaxRowDepth + 1)
    Do While iCol < dc.ColCount

        If MultipleVisDatas(dc) Then
            If iColDepth < dc.GetColDepth(iCol) Then
                oXLApp.Cells(iColDepth, xlCol).Value = dc.ColHeading(iCol, iColDepth)
            End If
        Else
            If iColDepth <= dc.GetColDepth(iCol) Then
                oXLApp.Cells(iColDepth, xlCol).Value = dc.ColHeading(iCol, iColDepth)
            End If
        End If

        iCol = dc.GetNextCol(iCol)
        xlCol = xlCol + 1
    Loop
Next iColDepth

If MultipleVisDatas(dc) Then
    ' multiple visible datafields confirmed, now export captions
    xlCol = (iMaxRowDepth + 1)
    xlRow = (iMaxColDepth) ' Works for multi datas

    iCol = 0
    Do While iCol < dc.ColCount
        oXLApp.Cells(xlRow, xlCol).Value = dc.ColHeading(iCol, (dc.ColFields.Count + 1))
        iCol = dc.GetNextCol(iCol)
        xlCol = (xlCol + 1)
    Loop
End If

' Now export RowHeadings and Data
iRow = 0

xlRow = (iMaxColDepth + 1)

Do While iRow < dc.RowCount
    ' Get RowHeading(s)
    xlCol = 1
    For iRowDepth = 1 To dc.GetRowDepth(iRow)
        oXLApp.Cells(xlRow, xlCol).Value = dc.RowHeading(iRow, iRowDepth)
        xlCol = xlCol + 1
    Next iRowDepth
' Get Data
    iCol = 0
    xlCol = (iMaxRowDepth + 1)
    Do While iCol < dc.ColCount
        oXLApp.Cells(xlRow, xlCol).Value = dc.DataValue(iRow, iCol)
        iCol = dc.GetNextCol(iCol)
        xlCol = (xlCol + 1)
    Loop ' iCol
iRow = dc.GetNextRow(iRow)
xlCol = 1
xlRow = (xlRow + 1)
Loop ' iRow

Screen.MousePointer = 0

End Sub

Top

大熊屋发表于：2008-04-15 17:02:53

接上段

Function MultipleVisDatas(dc As DynamiCubeLib.DCube) As Boolean
' This function returns true if there are mulitple VISIBLE data fields else it returns false
Dim viscnt As Integer, cnt As Integer

If dc.DataFields.Count > 1 Then ' There more than one, now see if they're all visible
    viscnt = 0
    For cnt = 0 To dc.DataFields.Count - 1
        If dc.DataFields(cnt).Visible = False Then viscnt = viscnt + 1
    Next cnt
    If viscnt > 0 Then ' at least one datfield is set to invisible
        If (dc.DataFields.Count - viscnt) > 1 Then ' there are multiple datafields visible
            MultipleVisDatas = True
            Exit Function
        Else ' then only one datafield is actually visible
            MultipleVisDatas = False
            Exit Function
        End If
    Else 'There are no invisible datafields
        MultipleVisDatas = True
        Exit Function
    End If

End If
End Function

在VB中直接调用就可以

On Error GoTo eh_cmdExportExcel_Click

    If ActiveCube Is Nothing Then Exit Sub

    ' this line exports DynamiCube to Excel:
    ExportToExcel frmMDI.ActiveCube

    Exit Sub
eh_cmdExportExcel_Click:
    Debug.Print "Error while exporting"

但是我在ACCESS中调用总是提示“要求对象”错误。

请问我怎么改一下呢。

我尝试着把

If ActiveCube Is Nothing Then Exit Sub

改成了

if dcube0 is nothing then exit sub 'dcube0是窗体中的一个控件

这句没问题了，但是下句也提示要求对象的错误
ExportToExcel frmMDI.ActiveCube

这句怎么该呀！

Top

sosopain 发表于：2008-04-15 18:19:11

frmMDI.ActiveCube

DynamiCubeLib.DCube