Option Compare Database Option Explicit Sub CreatePostgreSQLBuildScript() Dim tableList 'As TableDefs Dim table 'As TableDef Dim field 'As field Dim relLoop 'As Relation Dim index 'As index Dim x As Integer Dim fieldTypeStr, description, SQLScript, OutputFile As String Dim SQLDBName Dim DropDB, MakeDB, OutputTables, OutputIndexes, OutputConstraints, OutputData Set tableList = CurrentDb.TableDefs 'Where the SQL file will be written (Same directory as current open DB) OutputFile = Left(CurrentDb.Name, Len(CurrentDb.Name) - 4) & "_" & Format(Now(), "yyyy_mm_dd") & ".sql" 'Make user aware machine is doing something, for some reason, VBA Scripts don't change the cursor when they're 'running, so it looks like the machine hasn't started doing anything yet... DoCmd.Hourglass True Dim tempInt tempInt = 1 Do While InStr(tempInt, CurrentDb.Name, "\") tempInt = InStr(tempInt, CurrentDb.Name, "\") + 1 Loop SQLDBName = Mid(Left(CurrentDb.Name, Len(CurrentDb.Name) - 4), tempInt, 10000) DropDB = False MakeDB = False OutputTables = True OutputIndexes = False OutputConstraints = False OutputData = True SQLScript = "-- ----------------------------------------------------- --" & vbLf & _ "-- Access to SQL Build Script Creator Ver. 1.69 04/04/28 --" & vbLf & _ "-- Copyright 2001-2004, Philip Tanner. --" & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- Build script created: " & Format(Now(), "dd/mmm/yyyy (HH:nn:ss)") & " --" & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- Outputting Table definitions --" & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & vbLf 'If DropDB Or MakeDB Then 'SQLScript = SQLScript & "USE master" & vbLf & _ '"GO" & vbLf 'End If If DropDB Then SQLScript = SQLScript & "DROP DATABASE " & SQLDBName & ";" & vbLf & vbLf End If If MakeDB Then SQLScript = SQLScript & _ "CREATE DATABASE " & SQLDBName & ";" & vbLf & vbLf End If SQLScript = SQLScript & "USE " & SQLDBName & ";" & vbLf If OutputTables Then For Each table In tableList 'Ignore any system tables, coz they're part of Access and thus we don't want them in Sybase 'We also don't want any linked tables to be copied across. If Not Left(table.Name, 4) = "MSys" And Len(Trim(table.Connect)) = 0 Then SQLScript = SQLScript & vbLf & vbLf x = 1 'We grab the description of the table to store as a comment in the SQL description = "" Do While x < table.Properties.Count If table.Properties(x).Name = "Description" Then description = table.Properties(x).Value End If x = x + 1 Loop If Len(description) > 0 Then SQLScript = SQLScript & "-- ------- " & description & " ------- --" & vbLf End If SQLScript = SQLScript & "CREATE TABLE " & table.Name & vbLf & "(" & vbLf For Each field In table.Fields 'Work out what the Sybase SQL equivalent is for each of the field's datatypes. If field.Type = 1 Then 'Previously dbBoolean fieldTypeStr = "INT" ElseIf field.Type = 3 Then 'Previously dbInteger fieldTypeStr = "INT" 'Updated due to Alex's Email "Alex's Database Design Edict no. 18273" - 22 Oct 02. We all agree that we don't need 'to store interstellar distances, so a mere 999,999 numbers will do us in every instance I can think of.... ElseIf field.Type = 4 And field.Attributes = 17 Then fieldTypeStr = "SERIAL" ElseIf field.Type = 4 Then 'Previously dbLong fieldTypeStr = "INT" ElseIf field.Type = 5 Or field.Type = 7 Then 'Previously dbCurrency and dbDouble fieldTypeStr = "DECIMAL(8,2)" 'This also has been changed, as we're not interested in storing dates after 2079 or before 1900. Neither do 'we need to have accuracy down to 3 ms, 1 second will do, I'm sure... So we've gone from DATETIME to SMALLDATETIME 'and thus halved the space each one uses. ElseIf field.Type = 8 Then 'Previously dbDate and dbTime fieldTypeStr = "TIMESTAMP" ElseIf field.Type = 9 Then 'Previously dbBinary fieldTypeStr = "INT" 'Changed to NVARCHAR so that we can handle multi-byte character sets (for Asia mainly) ElseIf field.Type = 10 Then 'Previously dbText fieldTypeStr = "VARCHAR( " & field.Size & " )" ElseIf field.Type = 12 Then 'Previously dbMemo fieldTypeStr = "TEXT" 'If undefined type found then throw error and stop processing (no use continuing, as the script wont run!) Else MsgBox "Out of Cheese Error 33145:" & vbLf & _ "Unknown field type found " & vbLf & _ " Table: " & table.Name & vbLf & _ " Field: " & field.Name & vbLf & _ " Type: " & field.Type & vbLf & _ "Processing Stopped.", vbCritical GoTo EndSub End If x = 1 description = "" 'Now we want the description for this Field, not just the table, to output as a comment Do While x < field.Properties.Count If field.Properties(x).Name = "Description" Then description = field.Properties(x).Value End If x = x + 1 Loop If Len(description) > 0 Then SQLScript = SQLScript & " -- " & description & " --" & vbLf End If SQLScript = SQLScript & " " & field.Name & vbLf & " " & fieldTypeStr If Len(field.DefaultValue) > 0 Then 'If the field is date_created (a default for me in each table :)) or 'date_last_modified (likewise) then set the default value to SQL equivalent of Now() 'If field.Name = "date_created" Or field.Name = "date_last_modified" Or field.DefaultValue = "Now()" Then 'SQLScript = SQLScript & vbLf & " DEFAULT getdate()" 'We need to convert dates from access format to Sybase format If fieldTypeStr = "TIMESTAMP" Then 'Date literals are not considered as real dates by access If Not IsDate(field.DefaultValue) Then If field.DefaultValue = "#1/1/1901#" Then SQLScript = SQLScript & vbLf & " DEFAULT '01 jan 1901 00:00'" ElseIf field.DefaultValue = "#12/31/2078#" Then SQLScript = SQLScript & vbLf & " DEFAULT '31 dec 2078 00:00'" End If End If 'But we don't need to worry about the differences between numeric and text defaults 'because Access automatically wraps ""'s around text default values for us.... Else SQLScript = SQLScript & vbLf & " DEFAULT " & field.DefaultValue & "" End If End If 'Not sure on this, how AllowZeroLength and Required interact to work out the NULL/NOT NULL values, 'but it appears to work as needed If field.Required Then 'We make sure it's not a BIT field, as they're not allowed to be NULLable If field.AllowZeroLength And Not field.Type = 1 Then SQLScript = SQLScript & vbLf & " NULL" Else SQLScript = SQLScript & vbLf & " NOT NULL" End If End If 'If Access says it's a Number and the attributes are 17, then it's an 'autonumber (I think, a bit of trial and error here :) If field.Type = 4 And field.Attributes = 17 Then SQLScript = SQLScript & vbLf & " NOT NULL" 'I have my autonums as my primary keys, so set this up too SQLScript = SQLScript & vbLf & " PRIMARY KEY" End If SQLScript = SQLScript & "," & vbLf Next 'If we're at the last field, remove the last 2 chars (the CR and the last comma) before 'adding the closing parentheses and "go" statement for this table SQLScript = Mid(SQLScript, 1, Len(SQLScript) - 2) & vbLf & ");" & vbLf End If 'Loop to the next table in the list Next End If If OutputIndexes Then SQLScript = SQLScript & vbLf & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- Outputting Table Indexes --" & vbLf & _ "-- ----------------------------------------------------- --" For Each table In tableList If Not Left(table.Name, 4) = "MSys" And Len(Trim(table.Connect)) = 0 Then SQLScript = SQLScript & vbLf & "-- " & table.Name & " Indexes --" & vbLf For Each index In table.Indexes 'Ignore the primary key one, as it seems to be irrelevant If Not index.Name = "PrimaryKey" Then Dim i As Integer Dim NewName As String NewName = "" For i = 1 To Len(index.Name) If Mid(index.Name, i, 1) = "-" Then NewName = NewName & "_" Else NewName = NewName & Mid(index.Name, i, 1) End If Next SQLScript = SQLScript & "CREATE INDEX " & Left(NewName & "_idx", 28) & vbLf & _ " ON " & table.Name & " (" & index.Fields(0).Name & ");" & vbLf End If Next End If Next End If If OutputConstraints Then SQLScript = SQLScript & vbLf & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- Outputting Relationships and Constraints --" & vbLf & _ "-- ----------------------------------------------------- --" 'Now run back through the tables, to output any relationships to other tables For Each relLoop In CurrentDb.Relations With relLoop 'Sometimes Access makes up it's own UUID constraint names, and we don't want that.... 'However, we can't just make them up, coz that makes life hard when we have 2 links 'between the same 2 tables. So I just strip the { off the front in that case. If Left(.Name, 1) = "{" Then SQLScript = SQLScript & vbLf & vbLf & _ "ALTER TABLE " & .ForeignTable & vbLf & _ " ADD CONSTRAINT " & Right(Left(.Name, 29), 28) & vbLf & _ " foreign key (" & .Fields(0).ForeignName & ") REFERENCES " & .table & " (" & .Fields(0).Name & ");" & vbLf Else SQLScript = SQLScript & vbLf & vbLf & _ "ALTER TABLE " & .ForeignTable & vbLf & _ " ADD CONSTRAINT " & Left(.Name, 28) & vbLf & _ " foreign key (" & .Fields(0).ForeignName & ") REFERENCES " & .table & " (" & .Fields(0).Name & ");" & vbLf End If End With Next relLoop End If If OutputData Then Dim OutputDataRST, OutputDataSQL Dim Columns, ColumnData SQLScript = SQLScript & vbLf & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- Outputting Table Data --" & vbLf & _ "-- ----------------------------------------------------- --" For Each table In tableList 'Ignore any system tables, coz they're part of Access and thus we don't want them in Sybase 'We also don't want any linked table data If Not Left(table.Name, 4) = "MSys" And Len(Trim(table.Connect)) = 0 Then OutputDataSQL = "SELECT * FROM " & table.Name Set OutputDataRST = CurrentDb.OpenRecordset(table.Name) If Not OutputDataRST.EOF Then SQLScript = SQLScript & vbLf & vbLf & _ "DELETE FROM " & table.Name & vbLf & ";" & vbLf Do While Not OutputDataRST.EOF Columns = "" ColumnData = "" For Each field In OutputDataRST.Fields 'Work out what the Sybase SQL equivalent is for each of the field's datatypes. If field.Type = 1 Then 'Previously dbBoolean fieldTypeStr = "BIT" ElseIf field.Type = 3 Then 'Previously dbInteger fieldTypeStr = "INT" 'Updated due to Alex's Email "Alex's Database Design Edict no. 18273" - 22 Oct 02. We all agree that we don't need 'to store interstellar distances, so a mere 999,999 numbers will do us in every instance I can think of.... ElseIf field.Type = 4 Then 'Previously dbLong fieldTypeStr = "INT)" ElseIf field.Type = 5 Or field.Type = 7 Then 'Previously dbCurrency and dbDouble fieldTypeStr = "DECIMAL(8,2)" 'This also has been changed, as we're not interested in storing dates after 2079 or before 1900. Neither do 'we need to have accuracy down to 3 ms, 1 second will do, I'm sure... So we've gone from DATETIME to SMALLDATETIME 'and thus halved the space each one uses (8 -> 4 bytes). ElseIf field.Type = 8 Then 'Previously dbDate and dbTime fieldTypeStr = "DATETIME" ElseIf field.Type = 9 Then 'Previously dbBinary fieldTypeStr = "BINARY(" & field.Size & ")" 'Changed to NVARCHAR so that we can handle multi-byte character sets (for Asia mainly) ElseIf field.Type = 10 Then 'Previously dbText fieldTypeStr = "VARCHAR(" & field.Size & ")" ElseIf field.Type = 12 Then 'Previously dbMemo fieldTypeStr = "TEXT" 'If undefined type found then throw error and stop processing (no use continuing, as the script wont run!) Else MsgBox "Out of Cheese Error 33145:" & vbLf & _ "Unknown field type found " & vbLf & _ " Table: " & table.Name & vbLf & _ " Field: " & field.Name & vbLf & _ " Type: " & field.Type & vbLf & _ "Processing Stopped.", vbCritical GoTo EndSub End If 'We don't want to insert empty values, not valid SQL If Len(field.Value) Then Columns = Columns & " " & field.Name & "," & vbLf If InStr(1, fieldTypeStr, "datetime") Or InStr(1, fieldTypeStr, "varchar") Or InStr(1, fieldTypeStr, "text") Then ColumnData = ColumnData & " '" & Replace(field.Value, Chr(39), Chr(39) & Chr(39)) & "'," & vbLf Else If field.Value = False Then ColumnData = ColumnData & " 0," & vbLf ElseIf field.Value = True Then ColumnData = ColumnData & " -1," & vbLf Else ColumnData = ColumnData & " " & field.Value & "," & vbLf End If End If End If Next Columns = " (" & vbLf & Left(Columns, Len(Columns) - 2) & vbLf & " )" ColumnData = " (" & vbLf & Left(ColumnData, Len(ColumnData) - 2) & vbLf & " )" SQLScript = SQLScript & _ " INSERT INTO " & table.Name & vbLf & _ Columns & vbLf & _ " VALUES " & vbLf & _ ColumnData & ";" & vbLf OutputDataRST.MoveNext Loop OutputDataRST.Close End If End If Next End If 'Add a footer to the file to confirm the file executed to the end SQLScript = SQLScript & vbLf & vbLf & _ "-- ----------------------------------------------------- --" & vbLf & _ "-- End of output file --" & vbLf & _ "-- ----------------------------------------------------- --" 'Open an output file for the script to be put into Open OutputFile For Output As #1 Print #1, SQLScript Close #1 MsgBox "SQL Script has been generated and output to file: " & vbLf & OutputFile 'This is where an error dumps you to when it occurs, just to exit the sub :) EndSub: DoCmd.Hourglass False End Sub Function Replace(str, replacechar, withchar) Dim i For i = 1 To Len(str) If Mid(str, i, 1) = replacechar Then Replace = Replace & withchar Else Replace = Replace & Mid(str, i, 1) End If Next End Function