mtownbound
Technical User
Thinking about switching current Access db to Oracle9i. Anybody experience any significant issues or have any input for this transition??
Thanks!!!!
Mtown
Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations wOOdy-Soft on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Importing Access/Excel into Oracle
- Thread starter mtownbound
- Start date
- Status
Thinking about switching current Access db to Oracle9i. Anybody experience any significant issues or have any input for this transition??
Thanks!!!!
Mtown
I haven't tried this, but I got it from a guru on this site a couple years ago. Supposed to create scripts to generate your Access structure in an Oracle DB...
*******************************************************
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.
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
Terry
**************************
* General Disclaimor - Please read *
**************************
Please make sure your post is in the CORRECT forum, has a descriptive title, gives as much detail to the problem as possible, and has examples of expected results. This will enable me and others to help you faster...
*******************************************************
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.
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"
.ValueCase 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"
.ValueEnd Select
Select Case oFld.Properties("Required"
.ValueCase 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"
.ValueNext 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"
.ValueCase 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"
.ValueCase 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 ThenintSpaces = intTab2 - intSize - 2
strDescription = "," & Space(intSpaces) & "--" _
& Mid$(oFld.Properties("Description"
.Value, 1, 28) & vbCrLfstrOutput = 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 & "
;" & vbCrLfWrite #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"
.ValuestrValues = strValues & GetFieldValue(oFld, oRcds.Fields(intFld).Value)
Else
strFields = strFields & ", " & oFld.Properties("Name"
.ValuestrValues = strValues & ", " & GetFieldValue(oFld,
Nz(oRcds.Fields(intFld).Value, ""
)End If
intFld = intFld + 1
DoEvents
Next oFld
strFields = strFields & "
" & vbCrLfstrValues = 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"
.ValueCase 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 ThenstrResult = "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
Terry
**************************
* General Disclaimor - Please read *
**************************
Please make sure your post is in the CORRECT forum, has a descriptive title, gives as much detail to the problem as possible, and has examples of expected results. This will enable me and others to help you faster...
- Thread starter
- #3
You're welcome... Like I said though, Steve King wrote it, he deserves the credit... Terry
**************************
* General Disclaimor - Please read *
**************************
Please make sure your post is in the CORRECT forum, has a descriptive title, gives as much detail to the problem as possible, and has examples of expected results. This will enable me and others to help you faster...
**************************
* General Disclaimor - Please read *
**************************
Please make sure your post is in the CORRECT forum, has a descriptive title, gives as much detail to the problem as possible, and has examples of expected results. This will enable me and others to help you faster...
Hi,
Not trying to be dense, but how do you 'run' the code?
In Access, I started the VB editor, created a new module (called it 'convert'), pasted in the code... but now what? Just clicking the run button gives a list of macros to run-
FieldProperties
FieldX
GetProperties
InitScriptLine
... how do I get it to 'go'?
I vaguely remember getting some VBA code to work in FrontPage, and adding a hook to it in FP's menu, but it's been a LONG time.
Thanks.
Not trying to be dense, but how do you 'run' the code?
In Access, I started the VB editor, created a new module (called it 'convert'), pasted in the code... but now what? Just clicking the run button gives a list of macros to run-
FieldProperties
FieldX
GetProperties
InitScriptLine
... how do I get it to 'go'?
I vaguely remember getting some VBA code to work in FrontPage, and adding a hook to it in FP's menu, but it's been a LONG time.
Thanks.
- Status
Similar threads
- Locked
- Question
- Locked
- Question