![[pc3]](/data/assets/smilies/pc3.gif "[pc3] [pc3]")
![[profile]](/data/assets/smilies/profile.gif "[profile] [profile]")
This message contains Access 2000 VBA code to build Oracle SQL scripts for table creation and data loading. Although it was not built for Access 97 I suspect that it would work if you attached the Access 97 tables to the Access 2000 database and ran this code. I believe these scripts will work with all databases using ANSI SQL but haven't tested them. Email me if you have any questions.
Steve King
Option Compare Database
Dim mintFileNbr
Type ScriptType
Line As String
End Type
Dim ScriptBuf() As ScriptType
Public Sub GetProperties()
On Error GoTo HandleErr
Dim dbsCurrent As Database
Dim oFld As Field
Dim oRel As Relation
Dim oTable As TableDef
Dim oPrp As Property
Dim intCtr As Integer
Dim intFld As Integer
Dim strType As String
Dim strRequired As String
intCtr = 0
intFld = 0
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
With dbsCurrent
' Display the attributes of a TableDef object's
' fields.
For Each oTable In .TableDefs
If Left$(.TableDefs(intCtr).Name, 3) <> "MSys" Then
Debug.Print .TableDefs(intCtr).Name & ";;;;"
For Each oFld In .TableDefs(intCtr).Fields
Select Case oFld.Properties("Type").Value
Case 1 ' Boolean
strType = "Boolean"
Case 3 ' Integer
strType = "Integer"
Case 4 ' Numeric
strType = "Long"
Case 8 ' Date
strType = "Date"
Case 10 ' Text
strType = "Text"
Case 12 ' Memo
strType = "Memo"
Case Else
strType = oFld.Properties("Type").Value
End Select
Select Case oFld.Properties("Required").Value
Case True
strRequired = "* "
Case False
strRequired = "o "
Case Else
strRequired = "Unknown "
End Select
Debug.Print strRequired & oFld.Name & ";" _
& strType & " (" & oFld.Properties("Size").Value & ");" _
& oFld.Properties("Description").Value & ";" _
& oFld.Properties("ValidationRule").Value & ";" _
& oFld.Properties("ValidationText").Value
Next oFld
End If
intCtr = intCtr + 1
Next oTable
' Display the attributes of the Northwind database's
' relations.
Debug.Print .Name & ";"
For Each oRel In .Relations
Debug.Print oRel.Name & " = " & _
oRel.Attributes
Next oRel
Debug.Print vbCrLf
.Close
End With
Exit_Proc:
Set dbsCurrent = Nothing
Set oFld = Nothing
Set oRel = Nothing
Set oTable = Nothing
Set oPrp = Nothing
Exit Sub
HandleErr:
Select Case Err.Number
Case 3265, 3270
Resume Next
End Select
End Sub
Sub FieldX()
Dim dbsCurrent As Database
Dim rstEmployees As Recordset
Dim fldTableDef As Field
Dim fldQueryDef As Field
Dim fldRecordset As Field
Dim fldRelation As Field
Dim fldIndex As Field
Dim prpLoop As Property
Dim oTable As TableDef
Dim intCtr As Integer
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
Set oTable = dbsCurrent.TableDefs(0)
intCtr = 0
' Assign a Field object from different Fields
' collections to object variables.
For Each oTable In dbsCurrent.TableDefs
intCtr = intCtr + 1
Set oTable = dbsCurrent.TableDefs(intCtr)
Set fldTableDef = _
dbsCurrent.TableDefs(intCtr).Fields(0)
Set fldRelation = dbsCurrent.Relations(0).Fields(0)
Set fldIndex = _
dbsCurrent.TableDefs(0).Indexes(0).Fields(0)
Next oTable
' Print report.
FieldOutput "TableDef", fldTableDef
FieldOutput "Relation", fldRelation
dbsCurrent.Close
End Sub
Sub FieldOutput(strTemp As String, fldTemp As Field)
On Error GoTo HandleErr:
' Report function for FieldX.
Dim prpLoop As Property
Debug.Print "Valid Field properties in " & strTemp
' Enumerate Properties collection of passed Field
' object.
For Each prpLoop In fldTemp.Properties
' Some properties are invalid in certain
' contexts (the Value property in the Fields
' collection of a TableDef for example). Any
' attempt to use an invalid property will
' trigger an error.
If prpLoop.Name = "Description" Then
Debug.Print " " & prpLoop.Name & " = " & _
prpLoop.Value
End If
Next prpLoop
Exit_Proc:
Exit Sub
HandleErr:
MsgBox Err.Number & ", " & Err.Description
Resume Exit_Proc
Resume
End Sub
Public Sub CreateOracleTableScript(Optional strFilename As String)
On Error GoTo HandleErr
Dim dbsCurrent As Database
Dim oFld As Field
Dim oRel As Relation
Dim oTable As TableDef
Dim oPrp As Property
Dim intTableCount As Integer
Dim intCtr As Integer
Dim intFld As Integer
Dim intTab1 As Integer
Dim intTab2 As Integer
Dim intLastCommaPtr As Integer
Dim intSize As Integer
Dim intSpaces As Integer
Dim strType As String
Dim strSize As String
Dim strOutput As String
Dim strRequired As String
Dim strDescription As String
Dim RetVal
intTableCount = 0
intCtr = 0
intTab1 = 25
intTab2 = 50
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
With dbsCurrent
mintFileNbr = FreeFile()
Open strFilename For Output As #mintFileNbr
' Display the attributes of a TableDef object's
' fields
For Each oTable In .TableDefs
If Left$(.TableDefs(intCtr).Name, 4) <> "MSys" Then
Debug.Print " Creating " & FormatTableName(.TableDefs(intCtr).Name)
intTableCount = intTableCount + 1
strOutput = "drop table " & FormatTableName(.TableDefs(intCtr).Name) & ";" &
vbCr
strOutput = strOutput & "create table " &
FormatTableName(.TableDefs(intCtr).Name) & vbCr & " ("
'Write #mintFileNbr, strOutput
intFld = 0
For Each oFld In .TableDefs(intCtr).Fields
intFld = intFld + 1
If intFld > 1 Then
strOutput = strOutput & " "
End If
intSize = 4
Select Case oFld.Properties("Type").Value
Case 1 ' Boolean
strType = "Char(1)"
strSize = ""
Case 3 ' Integer
strType = "number"
strSize = "(" & 5 & ")"
Case 4 ' Numeric
strType = "number"
strSize = "(" & oFld.Properties("Size").Value & ")"
Case 8 ' Date
strType = "date"
strSize = ""
Case 10 ' Text
strType = "varchar2"
strSize = "(" & oFld.Properties("Size").Value & ")"
Case 12 ' Memo
strType = "varchar2"
strSize = ""
Case Else
strType = "varchar2"
strSize = "(" & oFld.Properties("Size").Value & ")"
End Select
Select Case oFld.Properties("Required").Value
Case True
strRequired = " not null"
Case False
strRequired = ""
Case Else
strRequired = ""
End Select
intSize = intSize + Len(oFld.Name)
If intSize < intTab1 Then
intSpaces = intTab1 - intSize
strOutput = strOutput & oFld.Name & Space(intSpaces) _
& strType & strSize & strRequired
intSize = intSize + intSpaces + Len(strType) + Len(strSize) +
Len(strRequired)
intSpaces = intTab2 - intSize
If Len(oFld.Properties("Description").Value) > 0 Then
intSpaces = intTab2 - intSize - 2
strDescription = "," & Space(intSpaces) & "--" _
& Mid$(oFld.Properties("Description").Value, 1, 28) & vbCrLf
strOutput = strOutput & strDescription
Else
strOutput = strOutput & vbCr
End If
Else
End If
Next oFld
End If
intCtr = intCtr + 1
If InStr(1, strOutput, strDescription) Then
intLastCommaPtr = InStr(1, strOutput, strDescription)
strOutput = Mid$(strOutput, 1, Len(strOutput) - Len(strDescription))
strDescription = " " & Mid$(strDescription, 2)
strOutput = strOutput & strDescription & " );" & vbCrLf
End If
'strOutput = Mid$(strOutput, 1, Len(strOutput) - 3) & vbCrLf & ");" & vbCrLf
Write #mintFileNbr, strOutput
Next oTable
Close #mintFileNbr
RetVal = Shell("c:\Program Files\Accessories\Wordpad.exe " & strFilename,
vbMaximizedFocus)
.Close
End With
MsgBox "Completed creation of " & intTableCount & " Oracle tables."
Exit_Proc:
Set dbsCurrent = Nothing
Set oFld = Nothing
Set oRel = Nothing
Set oTable = Nothing
Set oPrp = Nothing
Exit Sub
HandleErr:
Select Case Err.Number
Case 3265, 3270
Resume Next
End Select
MsgBox "Error: " & Err.Number & ", " & Err.Description
Resume Exit_Proc
Resume
End Sub
Public Sub InitScriptLine()
ReDim Preserve ScriptBuf(UBound(ScriptBuf) + 1)
End Sub
Public Function GetScriptLines() As String
Dim intCtr As Integer
Dim intFileNbr As Integer
Dim strTemp As String
For intCtr = 0 To UBound(ScriptBuf)
Debug.Print ScriptBuf(intCtr).Line
strTemp = ScriptBuf(intCtr).Line & vbCrLf
Next intCtr
GetScriptLines = strTemp
Write #intFileNbr, strTemp
End Function
Public Function FormatTableName(strWord As String) As String
Dim strTemp As String
Dim intPtr As String
intPtr = InStr(1, strWord, " ")
Do While intPtr > 0
strTemp = Mid$(strWord, 1, intPtr - 1)
strTemp = strTemp & "_"
strTemp = strTemp & Mid$(strWord, intPtr + 1)
strWord = strTemp
intPtr = InStr(1, strWord, " ")
Loop
FormatTableName = LCase(strWord) & vbCrLf
End Function
Public Sub CreateInsertSQL(Optional strFilename As String =
"CreateInsertSQL.txt")
On Error GoTo HandleErr
Dim dbsCurrent As Database
Dim oRcds As Recordset
Dim oFld As Field
Dim oRel As Relation
Dim oTable As TableDef
Dim oPrp As Property
Dim intCtr As Integer
Dim intFld As Integer
Dim intTab1 As Integer
Dim intTab2 As Integer
Dim intSize As Integer
Dim intSpaces As Integer
Dim strType As String
Dim strSize As String
Dim strHeader As String
Dim strFields As String
Dim strOutput As String
Dim strValues As String
Dim strRequired As String
Dim RetVal
intCtr = 0
intTab1 = 25
intTab2 = 50
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
With dbsCurrent
mintFileNbr = FreeFile()
Open strFilename For Output As #mintFileNbr
' Display the attributes of a TableDef object's
' fields
For Each oTable In .TableDefs
If Left$(.TableDefs(intCtr).Name, 4) <> "MSys" Then
Set oRcds = dbsCurrent.OpenRecordset(.TableDefs(intCtr).Name)
If oRcds.RecordCount <> 0 Then
oRcds.MoveFirst
Do While Not oRcds.EOF
strFields = " ("
strValues = " VALUES("
'Write #mintFileNbr, strOutput
intFld = 0
strHeader = "INSERT INTO " & FormatTableName(.TableDefs(intCtr).Name)
For Each oFld In .TableDefs(intCtr).Fields
If intFld = 0 Then
strFields = strFields & oFld.Properties("Name").Value
strValues = strValues & GetFieldValue(oFld, oRcds.Fields(intFld).Value)
Else
strFields = strFields & ", " & oFld.Properties("Name").Value
strValues = strValues & ", " & GetFieldValue(oFld,
Nz(oRcds.Fields(intFld).Value, ""))
End If
intFld = intFld + 1
DoEvents
Next oFld
strFields = strFields & ")" & vbCrLf
strValues = strValues & ");"
strOutput = strHeader _
& " " & strFields _
& " " & strValues & vbCr
Write #mintFileNbr, strOutput
oRcds.MoveNext
DoEvents
Loop
End If
End If
intCtr = intCtr + 1
Next oTable
Close #mintFileNbr
RetVal = Shell("c:\Program Files\Accessories\Wordpad.exe " & strFilename,
vbMaximizedFocus)
.Close
End With
Exit_Proc:
Set dbsCurrent = Nothing
Set oFld = Nothing
Set oRel = Nothing
Set oTable = Nothing
Set oPrp = Nothing
Set oRcds = Nothing
Close
Exit Sub
HandleErr:
Select Case Err.Number
Case 3265, 3270
Resume Next
End Select
MsgBox "Error: " & Err.Number & ", " & Err.Description
Resume Exit_Proc
Resume
End Sub
Public Sub FieldProperties()
Dim dbsCurrent As Database
Dim oFld As Field
Dim oTable As TableDef
Dim oPrp As Property
Dim intCtr As Integer
Dim intCtr2 As Integer
On Error GoTo HandleErr
intCtr = 0
Set dbsCurrent = OpenDatabase(CurrentDb.Name)
With dbsCurrent
For Each oTable In .TableDefs
intCtr = intCtr + 1
If Left$(.TableDefs(intCtr).Name, 4) <> "MSys" Then
Debug.Print "Table(" & .TableDefs(intCtr).Name & ")"
Debug.Print "-------------------------"
For Each oFld In .TableDefs(intCtr).Fields
intCtr2 = 0
Debug.Print "SourceField (" & oFld.SourceField & ")"
Debug.Print "-------------------------"
For intCtr2 = 1 To oFld.Properties.Count
Debug.Print intCtr2 & ") " & oFld.Properties(intCtr2).Name _
& " Value: " & oFld.Properties(intCtr2).Value
intCtr2 = intCtr2 + 1
Next intCtr2
Debug.Print vbCrLf
Next oFld
End If
Exit Sub
Next oTable
End With
Exit_Proc:
Exit Sub
HandleErr:
MsgBox Err.Number & ", " & Err.Description
Resume Exit_Proc:
Resume
End Sub
Public Function GetFieldValue(oField As Field, strValue As String) As String
Const BOOL As Integer = 1
Const INTGR As Integer = 3
Const NBR As Integer = 4
Const DT As Integer = 8
Const TXT As Integer = 10
Const MEMO As Integer = 12
Dim strResult As String
On Error GoTo HandleErr
Select Case oField.Properties("Type").Value
Case INTGR, NBR ' Boolean
strResult = strValue
Case DT ' Date
If Len(strValue) < 8 Then
' Ensure you have a valid 8 character date DD/MM/YY
' Check for M/... And insert zero
If Mid$(strValue, 2, 1) = "/" Then
strValue = "0" & strValue
End If
' Check for MM/D/YY And insert zero
If Mid$(strValue, 5, 1) = "/" Then
strValue = Mid$(strValue, 1, 3) _
& "0" _
& Mid$(strValue, 4)
End If
End If
' Don't use to_date on an empty date
If Len(strValue) > 4 Then
strResult = "to_date('" & strValue & "', 'DD/MM/RR')"
Else
strResult = "''"
End If
Case TXT, MEMO ' Text
strResult = "'" & DoubleUp(strValue) & "'"
Case BOOL
If oField.Properties("Type").Value = False Then
strResult = "N"
Else
strResult = "Y"
End If
Case Else
strResult = "'" & DoubleUp(strValue) & "'"
End Select
GetFieldValue = strResult
'Debug.Print strResult
Exit_Proc:
Exit Function
HandleErr:
MsgBox Err.Number & ", " & Err.Description & vbCr _
& "GetFieldValue"
Resume Exit_Proc:
Resume
End Function
Public Function DoubleUp(strTextIn As String) As String
Dim SGLQUOTE1
Dim SGLQUOTE2
Dim intPtr1 As Integer
On Error GoTo HandleErr
SGLQUOTE1 = Chr(39)
SGLQUOTE2 = Chr(39) & Chr(39)
intPtr1 = 1
If InStr(1, strTextIn, SGLQUOTE1) Then
Do While InStr(intPtr1, strTextIn, SGLQUOTE1)
intPtr1 = InStr(intPtr1, strTextIn, SGLQUOTE1)
strTextIn = Left$(strTextIn, intPtr1 - 1) _
& SGLQUOTE2 & Mid$(strTextIn, intPtr1 + 1)
intPtr1 = intPtr1 + 2
Loop
DoubleUp = strTextIn
Else
DoubleUp = strTextIn
End If
Exit_Proc:
Exit Function
HandleErr:
MsgBox Err.Number & ", " & Err.Description & vbCr _
& "DoubleUp"
Resume Exit_Proc:
Resume
End Function
are necessary. 