将表转换为ARFF的VBA程序返回“未定义的用户定义类型”

时间:2013-12-31 11:53:25

标签: vba ms-access ms-access-2007 weka arff

我找到了这个WEKA table to ARFF file converter VBA脚本。我对VBA编程一无所知,我只想用这个文件来帮助我进行研究。

我尝试将其运行到我的MS Access 2007程序中,但是"编译错误"消息User-defined type not defined显示并突出显示该行

Dim rs As ADODB.Recordset

以下是感兴趣的人的整个脚本:

Option Compare Database
    Option Explicit
    'Created by Ashutosh Nandeshwar: a7n9 AT Yahoo
    'Use this procedure to convert Access Tables to ARFF data format
    'Some highlights of this procedure
    '   - Takes care of spaces in Attribute name and data values
    '   - Finds unique values of nominal variables
    '   - Assigns equivalent ARFF datatype
    '   - Replaces missing values with question marks

    Sub ConvertTbl2Arff()

       On Error GoTo ConvertTbl2Arff_Error
    '--------------------Declarations Area-----------------
    Dim sTblName As String
    Dim rs As ADODB.Recordset
    Dim cn As ADODB.Connection
    Dim fld As ADODB.Field
    Dim sFileName As String
    Dim iOPFile As Integer
    Dim sInstance As String, sVal As String
    Dim vStart As Variant
    '--------------------Declarations End-------------------

    'Enter the table name to convert to ARFF
    sTblName = InputBox("Enter table name", , "weather")

    'Do the basic ADO stuff
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset

    'Open the table using ADO
    rs.Open sTblName, cn, adOpenStatic, adLockReadOnly, adCmdTable

    vStart = Timer ' Note start time
    'Create the file name using table name and current path
    sFileName = Application.CurrentProject.Path & Chr(92) & sTblName & ".arff"
    iOPFile = FreeFile 'Assign an avaialble freefile number to a variable
    Open sFileName For Output As iOPFile 'Open a file for output
    'Print the first line of ARFF- @relation
    Print #iOPFile, "@relation " & sTblName

    'Start a loop to print all the attribute names
    'The function FieldType takes care of nominal, boolean, numeric and string variables
    'If it is a string variable programs asks if it is a nominal variable, if it is a nominal
    'variable then a SQL query is run to get the unique values
    For Each fld In rs.Fields
       Print #iOPFile, "@attribute " & TrimAll(fld.Name) & Chr(32) & FieldType(fld.Type, sTblName, fld.Name)
    Next

    'Print the @data line
    Print #iOPFile, "@data"

    'Run a loop thru all the records to print the records
    'Chr(63)="?" Chr(44)= ","
    Do Until rs.EOF
        sInstance = ""
        For Each fld In rs.Fields
            sVal = IfNull(fld.value, "?")
            If sVal <> Chr(63) Then
                sInstance = sInstance & IfSpace(sVal) & Chr(44)
            Else
                sInstance = sInstance & sVal & Chr(44)
            End If
        Next
        Print #iOPFile, Left(sInstance, Len(sInstance) - 1) 'Prints each instance
        rs.MoveNext ' Move to next record
    Loop
    MsgBox "Succesfully converted an Access table to ARFF file-" & vbCrLf & _
            sFileName & vbCrLf & _
            "Time taken: " & Timer - vStart & " seconds."


    'Make a clean exit
    ConvertTbl2Arff_CleanUpExit:
        Close iOPFile
        If Not rs Is Nothing Then
            If rs.State = adStateOpen Then rs.Close
        End If
        Set rs = Nothing
        If Not cn Is Nothing Then
            If cn.State = adStateOpen Then cn.Close
        End If
       Exit Sub

    'Error handling
    ConvertTbl2Arff_Error:
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ConvertTbl2Arff", vbInformation
        Resume ConvertTbl2Arff_CleanUpExit

    End Sub
    'Find the Access table field types and return equivalent ARFF data types
    Public Function FieldType(intType As Integer, sTblNm As String, sFldNm As String) As String
    Dim strSQl As String
    Dim rs As ADODB.Recordset
    Dim cn As ADODB.Connection
       On Error GoTo FieldType_Error
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset
        Select Case intType
            Case adBigInt, adBinary, adBSTR, adChar, adLongVarBinary, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar, adWChar
                Select Case MsgBox("Is variable " & sFldNm & " a nominal variable?", vbYesNo Or vbQuestion Or vbDefaultButton1, "Nominal Variable")
                   Case vbYes
                        strSQl = "SELECT [" & sFldNm & "]"
                        strSQl = strSQl & " FROM [" & sTblNm & "]"
                        strSQl = strSQl & " GROUP BY [" & sFldNm & "];"
                        rs.Open strSQl, cn
                        FieldType = Chr(123)
                        Do Until rs.EOF
                            If Not IsNull(rs.Fields(0)) Then
                                FieldType = FieldType & IfSpace(rs.Fields(0)) & Chr(44)
                            End If
                            rs.MoveNext
                        Loop
                        FieldType = Left(FieldType, Len(FieldType) - 1)
                        FieldType = FieldType & Chr(125)
                    Case vbNo
                        FieldType = "string"
                End Select
            Case adBigInt, adDecimal, adDouble, adInteger, adNumeric, adSmallInt, adTinyInt, adUnsignedBigInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt, adVarNumeric
                FieldType = "numeric"
            Case adDate, adDBDate, adDBTime
                FieldType = "Date"
            Case adBoolean
                FieldType = "{True, False}"
        End Select

    FieldType_CleanUpExit:
        If Not rs Is Nothing Then
            If rs.State = adStateOpen Then rs.Close
        End If
        Set rs = Nothing
        If Not cn Is Nothing Then
            If cn.State = adStateOpen Then cn.Close
        End If
       Exit Function

    FieldType_Error:
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FieldType", vbInformation
        Resume FieldType_CleanUpExit

    End Function
    'If the field value is Null replace it with optional NullValue, in this case a ?
    Public Function IfNull(value As Variant, Optional NullValue As Variant = "") As Variant
        If IsNull(value) Or Len(Trim(value)) = 0 Then
            IfNull = NullValue
        Else
            IfNull = value
        End If
    End Function
    'Remove special chars from a string
    Public Function TrimAll(sString As String)
        Dim sResult As String, l As Long
        sResult = sString
        For l = 32 To 47
            sResult = Replace(sResult, Chr(l), "")
        Next l
        For l = 58 To 64
            sResult = Replace(sResult, Chr(l), "")
        Next l
        For l = 91 To 96
            sResult = Replace(sResult, Chr(l), "")
        Next l
        For l = 123 To 127
            sResult = Replace(sResult, Chr(l), "")
        Next l

        TrimAll = sResult
    End Function
    'If there is a space in given string return a string with quotations  around it
    'Chr(34)=""
    Public Function IfSpace(sString As String) As String
        Dim sResult As String, sResStr As String
        sResStr = TrimAll(sString)
        If Len(sResStr) <> Len(sString) Then
            sResult = Chr(34) & sString & Chr(34)
        Else
            sResult = sString
        End If
        IfSpace = sResult
    End Function

1 个答案:

答案 0 :(得分:1)

它说“用户定义的类型未定义”,因为应用程序不了解此类/对象,因为它的程序集/命名空间未导入到项目中。 VBA假设默认情况下这是一个用户定义的对象。

您需要在Office文件项目引用中添加对ADODB程序集的引用。我认为这需要Microsoft ActiveX Data Objects x.x Library,如here所述,但我不确定。

添加引用很简单,只需对组件进行Visual Basic引用:

1. On the Project menu, click References.
2. Click to select the check box next to the component(s) you want to add.
3. Click OK.