'TITLE: SELECTIVELY OUTPUT PK AND FK DDL.BAS 'DESCRIPTION: This macro outputs DDL for primary and foreign ' constraints for all selected tables. To operate, selected ' the desired tables, then right-click on the macro to execute. ' The DDL can be previewed or written to a file. 'MODIFY DATE: 2/27/02 Dim ent As Entity Dim mdl As Model Dim diag As Diagram Dim so As SelectedObject Dim submdl As SubModel Dim attr As AttributeObj Dim rel As Relationship Dim fkpair As FKColumnPair Dim fileoutput As String Dim pkchbx As Integer Dim fkchbx As Integer Dim filepath As String Dim delimiter As String Sub Main Debug.Clear Set diag = DiagramManager.ActiveDiagram Set mdl = diag.ActiveModel Set submdl = mdl.ActiveSubModel Begin Dialog UserDialog 590,161,"Generate Constraints",.DialogFunc ' %GRID:10,7,1,1 Text 30,21,90,14,"Save to:",.Text1 TextBox 100,14,340,21,.path TextBox 460,70,90,21,.delimiter Text 370,77,70,14,"Delimiter:",.Text2 PushButton 470,14,90,21,"Browse",.Browse OKButton 350,119,90,21 CancelButton 460,119,90,21 CheckBox 100,56,180,14,"Primary Constraints",.pkchbx CheckBox 100,84,170,14,"Foreign Constraints",.fkchbx PushButton 90,119,90,21,"Preview",.Preview End Dialog Dim dlg As UserDialog dlg.delimiter = ";" If Dialog(dlg) = -1 Then filepath = dlg.path pkchbx = dlg.pkchbx fkchbx = dlg.fkchbx delimiter = dlg.delimiter Open filepath For Output As #1 Print #1, genPKFKDDL Close #1 End If End Sub Function genPKFKDDL () As String Dim pkey As String Dim constraint As String Dim columnstring As String Dim idxcol As IndexColumn Dim i As Integer Dim idx As Index fileoutput = "" If pkchbx = 1 Then fileoutput = vbCrLf & "--" & vbCrLf & "--" & vbCrLf & "-- ********* Primary Key Definitions *********" & vbCrLf & "--" & vbCrLf & "--" & vbCrLf & vbCrLf For Each so In submdl.SelectedObjects If so.Type = 1 Then Set ent = mdl.Entities.Item(so.ID) columnstring = PKcolumns (ent) For Each idx In ent.Indexes If idx.IsPK = True Then Exit For End If Next If columnstring <> "" And idx.IsPK = True Then If ent.Owner <> "" Then constraint = "ALTER TABLE " & ent.Owner & "." & ent.TableName & vbCrLf Else constraint = "ALTER TABLE " & ent.TableName & vbCrLf End If constraint = constraint & " " & "ADD CONSTRAINT " & idx.Name & vbCrLf constraint = constraint & " " & "PRIMARY KEY (" & columnstring & ")" & vbCrLf constraint = constraint & delimiter & vbCrLf & vbCrLf Debug.Print constraint fileoutput = fileoutput & constraint End If End If Next End If If fkchbx = 1 Then fileoutput = fileoutput & vbCrLf & "--" & vbCrLf & "--" & vbCrLf & "-- ********* Foreign Key Definitions *********" & vbCrLf & "--" & vbCrLf & "--" & vbCrLf & vbCrLf For Each so In submdl.SelectedObjects If so.Type = 1 Then colunnstring = "" Set ent = mdl.Entities.Item(so.ID) If ent.ChildRelationships.Count <> 0 Then For Each rel In ent.ChildRelationships If ent.Owner <> "" Then constraint = "ALTER TABLE " & ent.Owner & "." & ent.TableName & vbCrLf Else constraint = "ALTER TABLE " & ent.TableName & vbCrLf End If constraint = constraint & " ADD CONSTRAINT " & rel.Name & vbCrLf constraint = constraint & " FOREIGN KEY (" & FKchildcolumns(rel, ent.Attributes.Count) & ")" & vbCrLf If ent.Owner <> "" Then constraint = constraint & " REFERENCES " & ent.Owner & "." & rel.ParentEntity.TableName & " (" & FKparentcolumns(rel, ent.Attributes.Count) & ")" & vbCrLf Else constraint = constraint & " REFERENCES " & rel.ParentEntity.TableName & " (" & FKparentcolumns(rel, ent.Attributes.Count) & ")" & vbCrLf End If constraint = constraint & delimiter & vbCrLf & vbCrLf fileoutput = fileoutput & constraint Next End If End If Next End If genPKFKDDL = fileoutput End Function Function PKcolumns ( e As Entity ) As String Dim colstr As String Dim i, count As Integer count = e.Attributes.Count ReDim colarr(1 To count) As String Dim a As AttributeObj i = 1 For Each a In e.Attributes If a.PrimaryKey = True Then colarr(a.SequenceNumber) = a.ColumnName End If Next For i = 1 To e.Attributes.Count If colarr(i) <> "" Then colstr = colstr & colarr(i) & "," End If Next If Len(colstr) > 0 Then colstr = Left(colstr, Len(colstr) - 1) PKcolumns = colstr Else PKcolumns = "" End If End Function Function FKchildcolumns ( r As Relationship, count As Integer ) As String Dim colstr As String Dim i As Integer ReDim colarr(1 To count) As String Dim fkpair As FKColumnPair For Each fkpair In r.FKColumnPairs colarr(fkpair.SequenceNo) = fkpair.ChildAttribute.ColumnName Next For i = 1 To count If colarr(i) <> "" Then colstr = colstr & colarr(i) & "," End If Next colstr = Left(colstr, Len(colstr) - 1) FKchildcolumns = colstr End Function Function FKparentcolumns ( r As Relationship, count As Integer ) As String Dim colstr As String Dim i As Integer ReDim colarr(1 To count) As String Dim fkpair As FKColumnPair For Each fkpair In r.FKColumnPairs colarr(fkpair.SequenceNo) = fkpair.ParentAttribute.ColumnName Next For i = 1 To count If colarr(i) <> "" Then colstr = colstr & colarr(i) & "," End If Next colstr = Left(colstr, Len(colstr) - 1) FKparentcolumns = colstr End Function
Rem See DialogFunc help topic for more information. Private Function DialogFunc(DlgItem$, Action%, SuppValue&) As Boolean Select Case Action% Case 1 ' Dialog box initialization Case 2 ' Value changing or button pressed If DlgItem = "Preview" Then pkchbx = DlgValue("pkchbx") fkchbx = DlgValue("fkchbx") delimiter = DlgText("delimiter") Begin Dialog UserDialog 750,413,"DDL" ' %GRID:10,7,1,1 TextBox 30,21,690,343,.code,1 OKButton 620,378,90,21 End Dialog Dim dlg As UserDialog dlg.code = genPKFKDDL Dialog dlg DialogFunc = True ElseIf DlgItem = "Browse" Then 'browse to excel file if used pushes browse button. Put path in text box. DlgText "path", GetFilePath(,"txt","C:\","Specify File Name",3) DialogFunc = True ElseIf DlgItem = "OK" And DlgText("path") = "" Then 'don't exit dialog if a path is not specified MsgBox("Please enter a valid path.",,"Error!") DialogFunc = True End If Rem DialogFunc = True ' Prevent button press from closing the dialog box Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem DialogFunc = True ' Continue getting idle actions Case 6 ' Function key End Select End Function