[AccessD] Code to auto-load an ORACLE schema

Good job there, Benson.

Jim

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Benson, William
(GE Global Research, consultant)
Sent: Friday, May 18, 2012 6:55 PM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Code to auto-load an ORACLE schema

Resolved the error. I needed to append the field to the fields collection
and then I also benefited from assigning the property values as I created
them and definitely did need to append the properties. I guess order of
events is important.

Sub CreateTableAndFields()
Dim XL As Excel.Application
Dim R As Excel.Range
Dim WS As Excel.Worksheet
Dim WB As Excel.Workbook
Dim rBegin As Range
Dim rEnd As Range
Dim Cell As Excel.Range
Dim D As DAO.Database
Dim T As DAO.TableDef
Dim F As DAO.Field
Dim Ar()
Dim P As DAO.Property
Dim sLastTable As String
Dim ub As Long
Set XL = MyXL
Set D = CurrentDb
Set WB = XL.ActiveWorkbook
Set WS = WB.ActiveSheet
Set R = WB.Names("MyFields").RefersToRange
Set rBegin = R.Cells(1, 1).Offset(1, 0)
Set rEnd = WS.Cells(WS.Rows.Count, 1).End(xlUp)
If rEnd.Row > R.Cells(1, 1).Row Then
    'There is data
    Set rBegin = R.Cells(1, 1).Offset(1, 0)
    Set rEnd = WS.Cells(WS.Rows.Count, 1).End(xlUp)
    For Each Cell In XL.Range(rBegin, rEnd).Cells
        If sLastTable <> XL.Trim(Cell) Then
            '1 =Table Name (don't need this but may as well)
            '2 = Field Name
            '3 = Type
            '4 = Size
            '5 = Decimals
            '6 = ValidationRule
            '7 = Required
            
            ReDim Ar(1 To 7, 1 To 1)
            On Error Resume Next
            DoCmd.DeleteObject acTable, XL.Trim(Cell)
            On Error GoTo 0
            Set T = D.CreateTableDef(Name:=XL.Trim(Cell))
            ub = 1
        Else
            ub = UBound(Ar, 2) + 1
            ReDim Preserve Ar(1 To 7, 1 To ub)
        End If
        Ar(1, ub) = XL.Trim(Cell) 'Table Name
        Ar(2, ub) = XL.Trim(Cell.Offset(0, 1)) 'Field Name
        Ar(3, ub) = CLng(Cell.Offset(0, 2)) ' Type
        Ar(4, ub) = CLng(Cell.Offset(0, 3)) ' Size
        If Len(XL.Trim(Cell.Offset(0, 4))) > 0 Then
            Ar(5, ub) = CLng(Cell.Offset(0, 4)) 'Decimals
        End If
        If Len(XL.Trim(Cell.Offset(0, 5))) > 0 Then
            Ar(6, ub) = XL.Trim(Cell.Offset(0, 5)) 'ValidationRule
        End If
        If XL.Trim(Cell.Offset(0, 6)) = "NOT NULL" Then
            Ar(7, ub) = True 'Required
        Else
            Ar(7, ub) = False
        End If
        Set F = T.CreateField(Ar(2, ub), Ar(3, ub), Ar(4, ub))
        T.Fields.Append F
        F.Required = Ar(7, ub)
        If CStr(Ar(6, ub)) <> "" Then
            F.ValidationRule = CStr(Ar(6, ub))
        End If
        If CStr(Ar(5, ub)) <> "" Then
            Set P = F.CreateProperty(Name:="DecimalPlaces", Type:=2,
Value:=Ar(5, ub))
            'P.Value = Ar(5, ub)
            F.Properties.Append P
        End If
        If CLng(Ar(3, ub)) = 8 And CLng(Ar(4, ub)) = 8 Then
   
            Set P = F.CreateProperty(Name:="Format", Type:=10,
Value:="General Date")
        '    P.Value = "General Date"
            F.Properties.Append P
        End If
        If ub = 1 Then
            D.TableDefs.Append T
'            D.TableDefs.Refresh
        End If
        
        sLastTable = Cell
    Next
End If
Application.RefreshDatabaseWindow

End Sub 

-- 
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com