'TITLE: IMPORT RELATIONSHIP NAMES FROM EXCEL 'DESCRIPTION: This macro is used to import index names from ' Microsoft Excel. A sample spreadsheet can be printed when ' executing the macro. Read the below ReadMe for the valid values ' of each column in the spreadsheet. 'AUTHOR: Jason Tiret 'CONTACT: http://support.embarcadero.com/ 'LAST MODIFY DATE: 1/29/2003 'README: This defines datatypes and constraints on each column of ' the speadsheet. The first row of the spread sheet is reserved for ' column headers. Values in the first row will be ignored. ' The specified column order is required for proper import. All ' columns are required in the spreadsheet, but some may have null ' values. 'FORMAT OF SPREAD SHEET: '(Column Order Number) Column Name - Datatype - Description ' (1) Parent Relationship FK Name - String - This is required in the ' spread sheet. The name of the relationshipis used to match ' the model relationship with the entry in the spreadsheet. ' Unmatched entries in the spreadsheet will be logged to ' C:\Rel_import.txt. ' (2) Parent Table Name - String - This is the name of the parent of ' the relationship. It is not needed to import information into ' the model. ' (3) Child Table Name - String - This is the name of the child of ' the relationship. It is not needed to import the information ' the model. ' (4) Parent Migrated Column Name - String - This is the name of the ' migrated column in the child table. This is not needed to ' import the information into the model. ' (5) New Parent Relationship FK Name - String - This is the new name ' of the relationship. The relationship specified in column ' one will be updated with this name Dim diag As Diagram Dim mdl As Model Dim errorlog As String Sub Main Dim refval As ReferenceValue Dim excel As Object Debug.Clear Set diag = DiagramManager.ActiveDiagram Set mdl = diag.ActiveModel Debug.Clear 'Debug.Print diag.ActiveModel.Name Begin Dialog UserDialog 510,210,"Import Relationship Names From Excel",.DialogFunc ' %GRID:10,7,1,1 Text 40,14,170,14,"Path to XLS spreadsheet:",.Text1 TextBox 70,35,340,21,.path OKButton 200,168,110,21 CancelButton 350,168,110,21 PushButton 430,35,60,21,"Browse",.Browse Text 50,112,400,35,"Note: Relationship info must be in Sheet 1. See ReadMe for the format of the sheet. Double-click on macro to view ReadMe.",.Text2 PushButton 60,70,150,28,"Get Sample Sheet",.SampleSheet End Dialog Dim dlg As UserDialog start_dialog: 'start dialog If Dialog(dlg) = -1 Then 'initialize excel object and make visible Set excel = CreateObject("Excel.Application") 'excel.Visible = True 'this Error Is For an errant file path, Dialog will be restarted 'On Error GoTo Error_handle excel.workbooks.open dlg.path,,True 'readonly:=True ImportRels(excel) excel.Workbooks.Close 'excel.visible = False MsgBox("Import Complete!",,"ER/Studio") Exit Sub Error_handle: MsgBox("Please enter a valid path.",,"Error!") GoTo start_dialog End If End Sub Function ImportRels(ex As Variant) Dim sheet As Object Dim range As Object Dim RelCount As Integer Dim rel As Relationship Dim currentRel As String Dim lastRel As String Dim rel_name As String Dim new_rel_name As String Set sheet = ex.worksheets(1) Set range = sheet.usedrange range.select RelCount = range.rows.Count If RelCount >= 2 Then errorlog = "Unmatched Entries in SpreadSheet::" & vbCrLf & vbCrLf For i = 2 To RelCount new_rel_name = Trim(range.cells(i,5).Value) rel_name = Trim(range.cells(i,1).Value) If rel_name <> "" Then Set rel = mdl.Relationships.Item(rel_name) If rel Is Nothing Then 'write relationship to error log errorlog = errorlog & "Relationship: " & Trim(range.cells(i,1).Value) & vbCrLf errorlog = errorlog & vbTab & "Parent: " & Trim(range.cells(i,2).Value) & vbCrLf errorlog = errorlog & vbTab & "Child: " & Trim(range.cells(i,3).Value) & vbCrLf & vbCrLf Else 'update model with Relationship name If new_rel_name <> "" Then rel.Name = new_rel_name End If End If End If Next Open "C:\Rel_import.txt" For Output As #1 Print #1, errorlog Close #1 End If End Function Sub PrintSampleSheet() Dim ex As Object Dim wb, ws As Variant Set ex = CreateObject("excel.application") ex.visible = True Set wb = ex.workbooks.Add Set ws = wb.activesheet ws.cells(1,1).Value = "Parent Relationship FK Name" ws.cells(1,2).Value = "Parent Table Name" ws.cells(1,3).Value = "Child Table Name" ws.cells(1,4).Value = "Parent Migrated Column" ws.cells(1,5).Value = "New Parent Relationship FK Name" ws.cells(2,1).Value = "Number - required" ws.cells(2,2).Value = "string - optional" ws.cells(2,3).Value = "string - optional" ws.cells(2,4).Value = "string - optional" ws.cells(2,5).Value = "string - optional" With ws.range(ws.cells(1,1),ws.cells(1,6)) .font.Size = 10 .font.Bold = True .columnwidth = 30 End With End Sub
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 = "Browse" Then 'browse to excel file if used pushes browse button. Put path in text box. DlgText "path", GetFilePath(,"xls",,"Open SpreadSheet") DialogFunc = True ElseIf DlgItem = "SampleSheet" Then PrintSampleSheet 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