How to run code? Access VBA

BarkinB · Mar 12, 2003

Hi,
Sorry if this is a FAQ...
I found some VBA code on this forum that seems like it would do exactly what I need, but I don't know how to run it. I've opened the VB editor, created a new module (calling it 'convert', but now what? When I just try to run it, I get a list of 'macros' (they really seem to be subs), and get nowhere....
I'm missing something here.
Here's the code....

I have not tested this code. The following is from one of the Access forums and GURU's on this site:
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&quot

.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&quot

.Value
End Select
Select Case oFld.Properties("Required&quot

.Value
Case True
strRequired = "* "
Case False
strRequired = "o "
Case Else
strRequired = "Unknown "
End Select
Debug.Print strRequired & oFld.Name & ";" _
& strType & " (" & oFld.Properties("Size&quot

.Value & &quot

;" _
& oFld.Properties("Description&quot

.Value & ";" _
& oFld.Properties("ValidationRule&quot

.Value & ";" _
& oFld.Properties("ValidationText&quot

.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&quot

.Value
Case 1 ' Boolean
strType = "Char(1)"
strSize = ""
Case 3 ' Integer
strType = "number"
strSize = "(" & 5 & &quot

"
Case 4 ' Numeric
strType = "number"
strSize = "(" & oFld.Properties("Size&quot

.Value & &quot

"
Case 8 ' Date
strType = "date"
strSize = ""
Case 10 ' Text
strType = "varchar2"
strSize = "(" & oFld.Properties("Size&quot

.Value & &quot

"
Case 12 ' Memo
strType = "varchar2"
strSize = ""
Case Else
strType = "varchar2"
strSize = "(" & oFld.Properties("Size&quot

.Value & &quot

"
End Select
Select Case oFld.Properties("Required&quot

.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&quot

.Value) > 0 Then
intSpaces = intTab2 - intSize - 2
strDescription = "," & Space(intSpaces) & "--" _
& Mid$(oFld.Properties("Description&quot

.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 & &quot

;" & 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, " &quot

Do While intPtr > 0
strTemp = Mid$(strWord, 1, intPtr - 1)
strTemp = strTemp & "_"
strTemp = strTemp & Mid$(strWord, intPtr + 1)
strWord = strTemp
intPtr = InStr(1, strWord, " &quot

Loop
FormatTableName = LCase(strWord) & vbCrLf
End Function
Public Sub CreateInsertSQL(Optional strFilename As String =
"CreateInsertSQL.txt&quot

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&quot

.Value
strValues = strValues & GetFieldValue(oFld, oRcds.Fields(intFld).Value)
Else
strFields = strFields & ", " & oFld.Properties("Name&quot

.Value
strValues = strValues & ", " & GetFieldValue(oFld,
Nz(oRcds.Fields(intFld).Value, "&quot

)
End If
intFld = intFld + 1
DoEvents
Next oFld
strFields = strFields & &quot

" & vbCrLf
strValues = strValues & &quot

;"
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 & &quot

"
Debug.Print "-------------------------"
For Each oFld In .TableDefs(intCtr).Fields
intCtr2 = 0
Debug.Print "SourceField (" & oFld.SourceField & &quot

"
Debug.Print "-------------------------"
For intCtr2 = 1 To oFld.Properties.Count
Debug.Print intCtr2 & &quot

" & 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&quot

.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&quot

.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

cainemart · Mar 12, 2003

You have to make something trigger the specific code that you want run. Like when you push this button, this code will execute. You have a few differnt functions in the code listed. Would need more info on what you are doing.

cainebean

BarkinB · Mar 12, 2003

I'm trying to convert an Access db to Oracle (8i). I did some searching, and ran into this code. The person posting it wasn't the author. There isn't much to go on, there's no instructions.
My experience with VBA is limited. In the VB editor from Access, I can't see how to create a new form to put buttons on in the first place... I can't see a way to get started.
I did some little bit of VBA in FrontPage a long time ago, but it has an 'Insert UserForm' menu item and there's none in the VB editor with Access... where do you create buttons, etc., to trigger something?

cainemart · Mar 12, 2003

You create a form, then you use the toolbox to create a button. Then you highlight the button, right click and go to properties. Find the onclick event then put in the specific code you are trying to run. You have a bunch of different functions in the code you have listed so you can't just cut all of that and paste it in. The above code has many different steps(functions) and you need to find the starting point so you can put that code behind the button. I know this doesn't make sense since you don't understand VBA but I can't think of a way to explain this to you with out looking through all of the above code and walking you through the process step by step. Couldn't you just import the tables into your database then reproduce the queries and form? I know you are looking for a quick fix but this isn't one of them, sorry.

cainebean

BarkinB · Mar 12, 2003

Hmm. The toolbox choice in the View menu is grayed out. No wonder I wasn't getting anywhere. I did get back to Access (not the VB editor, but Access itself), and try creating a form there. I created a button, and then had to build a macro whose action was 'OpenModule' and point it to the module I created in the VB editor, and am going to try various things there.
You're right, I have to look over the code to find where to start it.

I can't just import Access database tables straight into an Oracle database, can I?

cainemart · Mar 12, 2003

I don't use Oracle but I would think it would have an import or link option. If you can't import the tables that way, import them into a Excel file then import that file into Access.

beetee · Mar 12, 2003

I kinda took a quick look at the code.

if you define an 'entry point' as a function that isn't called by any other function, the code appears to have these entry points:

GetProperties
FieldX
CreateOracleTableScript
InitScriptLine
GetScriptLines
FormatTableName
CreateInsertSQL
FieldProperties

The question is, how did the designer expect you to run these functions?

One way is to use the immediate window, which you can get by pressing ^G. Then, you type in a function name (e.g. one of the above names), with any parameters, and press enter.

Another way is via macros. You might look to see if the programmer created any macros with 'RunCode' actions.

Finally, there may be another module that calls the above procedures in the correct order.

To really get into the code and get it working is more consultant-level work than forum work, however.

BarkinB · Mar 12, 2003

cainemart:
The real task is to convert the existing schema of an Access db to Oracle. Not even worried about the actual data yet, I need to build the tables in Oracle. This code I found would supposedly examine the Access db and write scripts to run in Oracle to re-create the db there.

beetee:
"The question is, how did the designer expect you to run these functions?"... it sure is. I have no contact with the designer (yet), but I may have to track him down (name is supposedly Steve King).
I have been trying some things in the immediate window, and may be getting close... it does create the file, but fails with a 'type mismatch' error dialog generated by the code. There may be hope yet.

Thanks for all your help!!!!!!!!!!!!!

beetee · Mar 12, 2003

Just for fun, I massaged the code a bit.

Option Compare Database
Option Explicit

Dim mintFileNbr
Type ScriptType
Line As String
End Type
Dim ScriptBuf() As ScriptType

Public Sub GetProperties()
On Error GoTo HandleErr
Dim dbsCurrent As DAO.Database
Dim oFld As DAO.Field
Dim oRel As Relation
Dim oTable As DAO.TableDef
Dim oPrp As DAO.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&quot

.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&quot

.Value
End Select
Select Case oFld.Properties("Required&quot

.Value
Case True
strRequired = "* "
Case False
strRequired = "o "
Case Else
strRequired = "Unknown "
End Select
On Error Resume Next
Dim Description As String
Description = ""
Description = oFld.Properties("Description&quot

.Value

Dim ValidationRule As String
ValidationRule = ""
ValidationRule = oFld.Properties("ValidationRule&quot

.Value

Dim ValidationText As String
ValidationText = ""
ValidationText = oFld.Properties("ValidationText&quot

.Value

Debug.Print strRequired & oFld.Name & ";" _
& strType & " (" & oFld.Properties("Size&quot

.Value & &quot

;" _
& Description & ";" _
& ValidationRule & ";" _
& ValidationText
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

' THIS LOOKS UNFINISHED
Sub FieldX()
Dim dbsCurrent As DAO.Database
Dim rstEmployees As DAO.Recordset
Dim fldTableDef As DAO.Field
Dim fldQueryDef As DAO.Field
Dim fldRecordset As DAO.Field
Dim fldRelation As DAO.Field
Dim fldIndex As DAO.Field
Dim prpLoop As DAO.Property
Dim oTable As DAO.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
' NOTE HOW only the last fldTableDef is used.. seems strange
' Print report.
FieldOutput "TableDef", fldTableDef
FieldOutput "Relation", fldRelation
dbsCurrent.Close
End Sub

Sub FieldOutput(strTemp As String, fldTemp As DAO.Field)
On Error GoTo HandleErr:
' Report function for FieldX.
Dim prpLoop As DAO.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 = "c:\OracleTableScript.txt&quot

On Error GoTo HandleErr
Dim dbsCurrent As DAO.Database
Dim oFld As DAO.Field
Dim oRel As Relation
Dim oTable As DAO.TableDef
Dim oPrp As DAO.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&quot

.Value
Case 1 ' Boolean
strType = "Char(1)"
strSize = ""
Case 3 ' Integer
strType = "number"
strSize = "(" & 5 & &quot

"
Case 4 ' Numeric
strType = "number"
strSize = "(" & oFld.Properties("Size&quot

.Value & &quot

"
Case 8 ' Date
strType = "date"
strSize = ""
Case 10 ' Text
strType = "varchar2"
strSize = "(" & oFld.Properties("Size&quot

.Value & &quot

"
Case 12 ' Memo
strType = "varchar2"
strSize = ""
Case Else
strType = "varchar2"
strSize = "(" & oFld.Properties("Size&quot

.Value & &quot

"
End Select
Select Case oFld.Properties("Required&quot

.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&quot

.Value) > 0 Then
intSpaces = intTab2 - intSize - 2
strDescription = "," & Space(intSpaces) & "--" _
& Mid$(oFld.Properties("Description&quot

.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 & &quot

;" & 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, " &quot

Do While intPtr > 0
strTemp = Mid$(strWord, 1, intPtr - 1)
strTemp = strTemp & "_"
strTemp = strTemp & Mid$(strWord, intPtr + 1)
strWord = strTemp
intPtr = InStr(1, strWord, " &quot

Loop
FormatTableName = LCase(strWord) & vbCrLf
End Function

Public Sub CreateInsertSQL(Optional strFilename As String = "c:\CreateInsertSQL.txt&quot

On Error GoTo HandleErr
Dim dbsCurrent As DAO.Database
Dim oRcds As DAO.Recordset
Dim oFld As DAO.Field
Dim oRel As Relation
Dim oTable As DAO.TableDef
Dim oPrp As DAO.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&quot

.Value
If IsNull(oRcds.Fields(intFld).Value) Then
strValues = strValues & "<NULL>"
Else
strValues = strValues & GetFieldValue(oFld, oRcds.Fields(intFld).Value)
End If
Else
strFields = strFields & ", " & oFld.Properties("Name&quot

.Value
strValues = strValues & ", " & GetFieldValue(oFld, Nz(oRcds.Fields(intFld).Value, "&quot

)
End If
intFld = intFld + 1
DoEvents
Next oFld
strFields = strFields & &quot

" & vbCrLf
strValues = strValues & &quot

;"
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 DAO.Database
Dim oFld As DAO.Field
Dim oTable As DAO.TableDef
Dim oPrp As DAO.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 & &quot

"
Debug.Print "-------------------------"
For Each oFld In .TableDefs(intCtr).Fields
intCtr2 = 0
Debug.Print "SourceField (" & oFld.SourceField & &quot

"
Debug.Print "-------------------------"
For intCtr2 = 1 To oFld.Properties.Count
On Error Resume Next
Dim PropValue As String
PropValue = ""
PropValue = oFld.Properties(intCtr2).Value
If Len(PropValue) > 0 Then
Debug.Print intCtr2 & &quot

" & oFld.Properties(intCtr2).Name & " Value: " & PropValue
End If
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:
End Sub

Public Function GetFieldValue(oField As DAO.Field, varValue As Variant) 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
Dim strValue As String
strValue = Nz(varValue, "<NULL>&quot

On Error GoTo HandleErr
Select Case oField.Properties("Type&quot

.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&quot

.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

BarkinB · Mar 13, 2003

Wow, Thanks!
I did some more work on it, too.
Type ScriptType
Line As String
End Type

had to be changed to:

Private Type ScriptType....

Some other lines had to be commented out to get it to compile cleanly. I still can't get it to work in the DB I'm dealing with, but I did get it to work on the NorthWind DB as a test. I'm sure it will eventually work. I'll just keep poking at it.
Some 'type mismatch' keeps popping up, but it's not being caught by the error handling the author built.

The DB I'm working on isn't big at all, so I just did the table creation by hand, which I had to do all along, anyway...

I have to be honest, and admit this is for an assignment in school. HOWEVER, my intention has not been to get anyone to 'do my homework' for me. Getting this code to work was a way to check my work in converting the DB, not to circumvent the assingnment. Along the way I was hoping to re-acquaint my brain with VBA and learn some more. In my previous job (unemployed since 09/02) I've always had to find automated ways of doing things, so when I found this code, I just HAD to try to make it work.

beetee · Mar 13, 2003

I've always been fond of automated systems, so we both benefitted from this code.

The code *does* compile in my Access 2000, and also more-or-less run (at least, some output is visible, and I caught some of the easier to find flaws [e.g. not checking to see if a property value exists])

You may need to slip in a few more DAO., and make sure that you have Tools:References Microsoft Access DAO 3.6 selected (do that from the module editor).

I think I might play around with it a bit. I have always felt that Access is a nice way to model a database, but you want large apps obviously on Oracle or Sql server (or even MySql). This code could provide a means to keep a specification on the Access side, and be able to generate SQL definitions. Of course, one would have to move the data around a bit to.

BarkinB · Mar 13, 2003

Wow, Thanks!
I did some more work on it, too.
Type ScriptType
Line As String
End Type

had to be changed to:

Private Type ScriptType....

Some other lines had to be commented out to get it to compile cleanly. I still can't get it to work in the DB I'm dealing with, but I did get it to work on the NorthWind DB as a test. I'm sure it will eventually work. I'll just keep poking at it.
Some 'type mismatch' keeps popping up, but it's not being caught by the error handling the author built.

The DB I'm working on isn't big at all, so I just did the table creation by hand, which I had to do all along, anyway...

I have to be honest, and admit this is for an assignment in school. HOWEVER, my intention has not been to get anyone to 'do my homework' for me. Getting this code to work was a way to check my work in converting the DB, not to circumvent the assingnment. Along the way I was hoping to re-acquaint my brain with VBA and learn some more. In my previous job (unemployed since 09/02) I've always had to find automated ways of doing things, so when I found this code, I just HAD to try to make it work.

BarkinB · Mar 13, 2003

Oops. Sorry about the duplicate post.

I agree with everything you said.

I checked, and MS DAO 3.6 is active.

beetee · Mar 13, 2003

The code I posted would not be comfortable living with the eariler version.

Maybe you ran a few things I did not run and that's why you have to comment code out.

However, I think it would be much preferable to fix any items that fail to compile or run.

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!

How to run code? Access VBA

BarkinB

Programmer

cainemart

Programmer

BarkinB

Programmer

cainemart

Programmer

BarkinB

Programmer

cainemart

Programmer

beetee

Programmer

BarkinB

Programmer

beetee

Programmer

BarkinB

Programmer

beetee

Programmer

BarkinB

Programmer

BarkinB

Programmer

beetee

Programmer

Similar threads

Part and Inventory Search

Sponsor