Introduction
This post follows the previous one, Macros – Add custom properties to specific objects, where we shared scripts to automatically bind Attachments to ER Objects.
In this one, we will share new versions of the different scripts that allow using shared Attachments for various types of ER Objects (instead of duplicating them for each ER Object), and also support Relationships and Views.
wGenerate Attachments to Excel
We can still use Attachment Types for a dedicated type of ER Object, but we can also specify several by separating them with pipes: |
You can edit the script wBindAttachmentsToERObjects.bas to use another delimiter (Line 21).
For example: With an Attachment Type named Entities|Attributes|Views, all its Attachments will be bound to the three types of ER Objects.
And without further ado, the new versions of the various scripts are provided below.
Scripts
- wBindAttachmentsToERObjects.bas (the following four scripts all use this one)
- wGenerate Attachments to Excel.bas
- wRead Attachments from Excel with UI.bas
- wReadAttachmentsFromExcel.bas
- ERSBasicHandlers.bas
wBindAttachmentsToERObjects.bas
'#Language "WWB-COM" ''MACRO TITLE: wBind Attachments to ER Objects ' MACRO VERSION: 2.0 'This macro binds the Attachments for Entities, Tables, Attributes, ' Columns, Relationships & Views ' ' Release notes ' 2.0: ToImportExport & IsMatching functions added ' 1.0: Initial version '--------------------------------------------------------------------------- Option Explicit Public Const ENTITIES$ = "Entities" Public Const TABLES$ = "Tables" Public Const ATTRIBUTES$ = "Attributes" Public Const COLUMNS$ = "Columns" Public Const RELATIONSHIPS$ = "Relationships" Public Const VIEWS$ = "Views" Public Const DELIMITER$ = "|" ' Datatypes constants Public Const BOOLEAN_TYPE% = 1 Public Const DATE_TYPE% = 2 Public Const EXTERNAL_FILE_PATH_TYPE% = 3 Public Const NUMERIC_TYPE% = 4 Public Const TEXT_TYPE% = 5 Public Const TEXT_LIST_TYPE% = 6 Public Const TIME_TYPE% = 7 ' Excel constants Public Const xlCenter% = -4108 Public Const xlBottom% = -4107 Public Const xlTop% = -4160 Public Const xlLeft% = -4131 Public Const xlRight% = -4152 Public Const xlCalculationAutomatic& = -4105 Public Const xlCalculationManual& = -4135 Public Const xlCalculationSemiautomatic& = 2 Sub main On Error GoTo ErrorEnd DiagramManager.EnableScreenUpdateEx(False, False) Debug.Clear BindAttachments(False) ErrorEnd: DiagramManager.EnableScreenUpdateEx(True, True) End Sub Public Sub BindAttachments(currentModelOnly As Boolean) Dim MyDictionary As Dictionary Dim MyDiagram As Diagram Dim MyModel As Model Set MyDiagram = DiagramManager.ActiveDiagram If Not MyDiagram Is Nothing Then Set MyDictionary = MyDiagram.Dictionary ' Update this line to use an Enterprise Data Dictionary ' Set MyDictionary = MyDiagram.EnterpriseDataDictionaries.Item("My Enterprise DD") If Not MyDictionary Is Nothing Then Debug.Print If currentModelOnly Then Set MyModel = MyDiagram.ActiveModel Debug.Print "Model: " & vbTab & MyModel.Name BindModelAttachment(MyDictionary, MyModel) Else For Each MyModel In MyDiagram.Models Debug.Print "Model: " & vbTab & MyModel.Name BindModelAttachment(MyDictionary, MyModel) Next End If End If End If End Sub Private Sub BindModelAttachment(MyDictionary As Dictionary, MyModel As Model) Dim MyEntity As Entity Dim MyAttribute As AttributeObj Dim MyRelationship As Relationship Dim MyView As View Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment ' Bind Entities' Attachments For Each MyEntity In MyModel.Entities Debug.Print IIf(MyModel.Logical, "Entity:" & vbTab & MyEntity.EntityName, "Table:" & vbTab & MyEntity.TableName) For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, IIf(MyModel.Logical, ENTITIES, TABLES)) Then For Each MyAttachment In MyAttachmentType.Attachments MyEntity.BoundAttachments.Add(MyAttachment.ID) Next End If Next ' Bind Attributes' Attachments For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, IIf(MyModel.Logical, ATTRIBUTES, COLUMNS)) Then For Each MyAttribute In MyEntity.Attributes Debug.Print "[" & MyAttachmentType.Name & "]" & vbTab & IIf(MyModel.Logical, "Attribute:" & vbTab & MyAttribute.AttributeName, "Column:" & vbTab & MyAttribute.ColumnName) For Each MyAttachment In MyAttachmentType.Attachments MyAttribute.BoundAttachments.Add(MyAttachment.ID) Next Next End If Next Next ' Bind Relationships' Attachments For Each MyRelationship In MyModel.Relationships Debug.Print "Relationship:" & vbTab & MyRelationship.Name For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, RELATIONSHIPS) Then For Each MyAttachment In MyAttachmentType.Attachments MyRelationship.BoundAttachments.Add(MyAttachment.ID) Next End If Next Next ' Bind Views' Attachments For Each MyView In MyModel.Views Debug.Print "View:" & vbTab & MyView.Name For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, VIEWS) Then For Each MyAttachment In MyAttachmentType.Attachments MyView.BoundAttachments.Add(MyAttachment.ID) Next End If Next Next Debug.Print End Sub Public Function IsMatching(theAttachmentType$, theObjectType$) As Boolean Dim rc As Boolean, i% Dim names$() rc = UCase(theObjectType) = UCase(theAttachmentType) If Not rc Then names = Split(theAttachmentType, DELIMITER) For i = LBound(names) To UBound(names) rc = (UCase(names(i)) = UCase(theObjectType)) If rc Then Exit For End If Next i End If IsMatching = rc End Function Public Function ToImportExport(name$) As Boolean Dim rc As Boolean, i% Dim names$() rc = InStr(DELIMITER & UCase(ENTITIES) & DELIMITER & UCase(TABLES) & DELIMITER & UCase(ATTRIBUTES) & DELIMITER & UCase(COLUMNS) & DELIMITER & UCase(RELATIONSHIPS) & DELIMITER & UCase(VIEWS) & DELIMITER, DELIMITER & UCase(name) & DELIMITER) > 0 If Not rc Then names = Split(name, DELIMITER) For i = LBound(names) To UBound(names) rc = (UCase(names(i)) = UCase(ENTITIES)) Or (UCase(names(i)) = UCase(TABLES)) Or (UCase(names(i)) = UCase(ATTRIBUTES)) Or (UCase(names(i)) = UCase(COLUMNS)) Or (UCase(names(i)) = UCase(RELATIONSHIPS)) Or (UCase(names(i)) = UCase(VIEWS)) If rc Then Exit For End If Next i End If ToImportExport = rc End Function
wGenerate Attachments to Excel.bas
'#Language "WWB-COM" ''MACRO TITLE: wGenerate Attachments to Excel ' MACRO VERSION: 2.0 'This macro exports specific Attachments for Entities, Tables, Attributes, ' Columns, Relationships & Views ' ' Dependencies: ' wBindAttachmentstoERObjects.bas ' Excel ' ' Release notes ' 2.0: Export specific Attachments Types ' 1.0: Initial version '--------------------------------------------------------------------------- '#Uses "wBindAttachmentsToERObjects.bas" Option Explicit Private Const TITLE$ = "wGenerate Attachments to Excel" Private Const TIMESTAMPED As Boolean = True Sub Main Dim MyDiagram As Diagram Dim MyDictionary As Dictionary Dim dictionary_list$() Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment ' Excel variables Dim wb As Object Dim sheet As Object Dim excel As Object Dim MyListMember As ListMember Dim sList$ Dim curRow% Debug.Clear 'Get the current diagram. Set MyDiagram = DiagramManager.ActiveDiagram If Not MyDiagram Is Nothing Then ' Excel Set excel = CreateObject("excel.application") PrintHeader(excel, wb, sheet) ' Excel optimization excel.Application.ScreenUpdating = False excel.Application.EnableAnimations = False excel.Application.Calculation = xlCalculationManual sheet.DisplayPageBreaks = False curRow = 2 If init_dictionary_list(MyDiagram, MyDictionary, dictionary_list) Then Set MyDictionary = MyDiagram.Dictionary Else Begin Dialog UserDialog 550,130,TITLE ' %GRID:10,7,1,1 Text 30,21,120,14,"Select Dictionary: ",.Text3,1 DropListBox 170,18,360,112,dictionary_list(),.dictionary_select OKButton 20,105,110,21 CancelButton 420,105,110,21 End Dialog Dim dlg As UserDialog If Dialog(dlg) = -1 Then If dictionary_list(dlg.dictionary_select) = "Local" Then Set MyDictionary = MyDiagram.Dictionary Else Set MyDictionary = MyDiagram.EnterpriseDataDictionaries.Item(dictionary_list(dlg.dictionary_select)) End If Else Exit Sub End If End If If Not MyDictionary Is Nothing Then LogIt "Dictionary: " & MyDictionary.Name ' Get all attachments For Each MyAttachmentType In MyDictionary.AttachmentTypes ' Export only the needed attachments If ToImportExport(MyAttachmentType.Name) Then For Each MyAttachment In MyAttachmentType.Attachments ' LogIt MyAttachmentType.Name & " / " & MyAttachment.Name sheet.Cells(curRow, 1).Value = MyAttachmentType.Name sheet.Cells(curRow, 2).Value = MyAttachment.Name sheet.Cells(curRow, 3).Value = MyAttachment.Description sheet.Cells(curRow, 4).Value = MyAttachment.Datatype sheet.Cells(curRow, 5).Value = MyAttachment.ValueDefault Select Case MyAttachment.Datatype Case TEXT_LIST_TYPE sList = "" For Each MyListMember In MyAttachment.TextList sList += MyListMember.Text & "," Next MyListMember If Right(sList, 1) = "," Then sList = Left(sList, Len(sList) - 1) End If sheet.Cells(curRow, 6).Value = sList End Select ' XLColumns4Attachments(MyAttachmentType.Name & "\" & MyAttachment.Name) = curCol LogIt MyAttachmentType.Name & "\" & MyAttachment.Name curRow += 1 Next MyAttachment Else LogIt "SKIPPED:" & vbTab & MyAttachmentType.Name End If Next MyAttachmentType Comments_AutoSize(sheet) Debug.Print LogIt "Export completed" excel.Visible = True excel.Application.ScreenUpdating = True excel.Application.EnableAnimations = True excel.Application.Calculation = xlCalculationAutomatic ' sheet.DisplayPageBreaks = True AutofitAllUsed(excel) sheet.Rows("1:1").RowHeight = 14.4 '.EntireRow.AutoFit MsgBox "Export completed !", vbInformation, TITLE End If Else MsgBox "No project opened!", vbExclamation, TITLE End If End Sub Private Function PrefixDT(txt As String) As String If TIMESTAMPED Then PrefixDT = CStr(Now) & Chr(9) & txt Else PrefixDT = txt End If End Function Private Sub LogIt(ByVal txt As String) Debug.Print PrefixDT(txt) End Sub Private Sub PrintHeader(ByRef excel As Object, ByRef wb As Object, ByRef sheet As Object) Set wb = excel.workbooks.Add Set sheet = wb.activesheet sheet.Name = "Attachments" With sheet.range("A1:F1") .interior.colorindex = 15 .font.Size = 9 .font.Bold = True .horizontalalignment = xlCenter End With With excel With .ActiveWindow .SplitColumn = 1 .SplitRow = 1 End With .ActiveWindow.FreezePanes = True End With sheet.cells(1,1).Value = "Attachment Type" sheet.cells(1,2).Value = "Name" sheet.cells(1,3).Value = "Description" sheet.cells(1,4).Value = "Data Type" sheet.cells(1,5).Value = "Default value" sheet.cells(1,6).Value = "Text list values" With sheet.cells(1,4) .AddComment .Comment.Visible = False .Comment.Text Text:= "1 = Boolean" & vbCrLf & "2 = Date" & vbCrLf & "3 = ExternalFilePath" & vbCrLf & "4 = Numeric" & vbCrLf & "5 = Text" & vbCrLf & "6 = TextList" & vbCrLf & "7 = Time" End With With sheet.range("A:A") .interior.colorindex = 15 .verticalalignment = xlBottom .horizontalalignment = xlLeft .font.Bold = True .font.Size = 9 End With End Sub Private Sub AutofitAllUsed(excel As Object) Dim x As Long For x = 1 To excel.ActiveSheet.UsedRange.Columns.Count excel.ActiveSheet.UsedRange.Columns(x).EntireColumn.AutoFit Next x End Sub ' Initialize the dictionary drop down list Function init_dictionary_list(ByRef MyDiagram As Diagram, ByRef MyDictionary As Dictionary, ByRef dictionary_list$()) As Boolean Dim i% ReDim dictionary_list$(0 To MyDiagram.EnterpriseDataDictionaries.Count) dictionary_list (0) = "Local" i = 1 For Each MyDictionary In MyDiagram.EnterpriseDataDictionaries dictionary_list (i) = MyDictionary.Name i = i + 1 Next init_dictionary_list = MyDiagram.EnterpriseDataDictionaries.Count = 0 End Function Sub Comments_AutoSize(s As Object) ' https://www.contextures.com/xlcomments03.html Dim MyComments As Object Dim lArea As Long Dim lMult As Double Dim MaxW As Long Dim NewW As Long 'Height adjustment factor 'of 1.1 seems to work ok. lMult = 1.1 MaxW = 300 NewW = 200 For Each MyComments In s.Comments With MyComments .Shape.TextFrame.AutoSize = True If .Shape.Width > MaxW Then lArea = .Shape.Width * .Shape.Height .Shape.Width = NewW .Shape.Height = (lArea / NewW) * lMult End If End With Next ' comment End Sub
wRead Attachments from Excel with UI.bas
'#Language "WWB-COM" ''MACRO TITLE: wRead Attachments from Excel with UI ' MACRO VERSION: 2.0 'This macro imports specific Attachments for Entities, Tables, Attributes, ' Columns, Relationships & Views ' ' Dependencies: ' wBindAttachmentstoERObjects.bas ' Excel ' ' Release notes ' 2.0: Import specific Attachments Types ' 1.0: Initial version '--------------------------------------------------------------------------- '#Uses "wBindAttachmentsToERObjects.bas" Option Explicit Private Const TITLE$ = "wRead Attachments from Excel" Dim XLfile$ Dim lCurRow% Sub Main Dim excel As Object Dim MyDiagram As Diagram Dim MyDictionary As Dictionary Dim lNbManaged& Dim dictionary_list$() Debug.Clear Set MyDiagram = DiagramManager.ActiveDiagram If Not MyDiagram Is Nothing Then Begin Dialog UserDialog 550,217,TITLE,.DialogFunc ' %GRID:10,7,1,1 Text 30,21,120,14,"Select Dictionary: ",.Text3,1 DropListBox 170,18,360,112,dictionary_list(),.dictionary_select GroupBox 20,56,510,98,"Excel spreadsheet",.gbPath Text 30,84,50,14,"Path: ",.Text1,1 TextBox 90,83,360,21,.Path PushButton 460,84,60,21,"Browse",.Browse PushButton 350,119,170,28,"Generate a Sample Sheet",.SampleSheet CheckBox 30,161,490,14,"Bind attachments to ER Objects",.cbBind OKButton 20,189,110,21 CancelButton 420,189,110,21 End Dialog Dim dlg As UserDialog init_dictionary_list(MyDiagram, dictionary_list) start_dialog: 'dlg.Path = "C:\Users\William\Documents\ERStudio Data Architect 19.3\tests\GIM_Attachments.xlsx" 'start dialog If Dialog(dlg) = -1 Then If dictionary_list(dlg.dictionary_select) = "Local" Then Set MyDictionary = MyDiagram.Dictionary Else Set MyDictionary = MyDiagram.EnterpriseDataDictionaries.Item(dictionary_list(dlg.dictionary_select)) End If 'initialize excel object and make visible Set excel = CreateObject("Excel.Application") 'this Error Is For an errant file path, Dialog will be restarted On Error GoTo Error_open XLfile = dlg.Path excel.workbooks.Open XLfile On Error GoTo Error_unknown DiagramManager.EnableScreenUpdateEx(False, False) lNbManaged = ImportAttachments(excel, MyDictionary) If (lNbManaged > 0) And dlg.cbBind Then BindAttachments(False) End If DiagramManager.EnableScreenUpdateEx(True, True) excel.Quit() MsgBox ("ERObjects Attachments imported" & vbCrLf & vbCrLf & lNbManaged & " attachment" & If(lNbManaged > 1, "s", "") & " managed", vbInformation, TITLE) Debug.Print Debug.Print lNbManaged & " attachment" & If(lNbManaged > 1, "s", "") & " managed" Exit Sub Error_open: MsgBox("Please enter a valid path.", vbExclamation, TITLE) GoTo start_dialog Error_unknown: MsgBox(Err.Description & If(lCurRow > 1, vbCrLf & vbCrLf & "Last Excel row used: " & lCurRow, ""), vbExclamation, TITLE) If Not excel Is Nothing Then excel.Quit() End If DiagramManager.EnableScreenUpdateEx(True, True) End If Else MsgBox "No project opened!", vbExclamation, TITLE End If End Sub 'initialize the dictionary drop down list Sub init_dictionary_list(ByRef MyDiagram As Diagram, ByRef dictionary_list$()) Dim i% Dim MyDictionary As Dictionary ReDim dictionary_list$(0 To MyDiagram.EnterpriseDataDictionaries.Count) dictionary_list (0) = "Local" i = 1 For Each MyDictionary In MyDiagram.EnterpriseDataDictionaries dictionary_list (i) = MyDictionary.Name i = i + 1 Next End Sub Private Function ImportAttachments(ByRef ex As Variant, ByRef MyDictionary As Dictionary) As Integer Dim sheet As Object Dim range As Object Dim sValue$, iValue%, sDefault$ Dim lNbAttachments&, lNbAttachmentsManaged& Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment Dim sLastAttachmentType$ Dim sDescription$, dt As Date, splitted$() Set sheet = ex.worksheets(1) Set range = sheet.usedrange range.Select sLastAttachmentType = "" ImportAttachments = 0 lNbAttachments = range.Rows.Count Debug.Print "Number of attachments: " & (lNbAttachments - 1) lNbAttachmentsManaged = 0 ReDim MyAttachments(lNbAttachments) For lCurRow = 2 To lNbAttachments sValue = Trim(CStr(range.Cells(lCurRow, 1).Value)) If (sValue <> "") And ToImportExport(sValue) Then If (sValue <> sLastAttachmentType) Then Set MyAttachmentType = MyDictionary.AttachmentTypes(sValue) ' Check if AttachmentType exists If MyAttachmentType Is Nothing Then ' Attachment type not found, we create it Set MyAttachmentType = MyDictionary.AttachmentTypes.Add(sValue, "Imported from file: " & XLfile) End If sLastAttachmentType = sValue End If sValue = Trim(CStr(range.Cells(lCurRow, 2).Value)) If (sValue <> "") Then Set MyAttachment = MyAttachmentType.Attachments(sValue) ' Check if Attachment exists If MyAttachment Is Nothing Then ' Attachment not found, we create it Set MyAttachment = MyAttachmentType.Attachments.Add(sValue, "Imported from file: " & XLfile, "", TEXT_TYPE) Debug.Print "Attachment created: " & MyAttachmentType.Name & " \ " & MyAttachment.Name Else Debug.Print "Attachment found: " & MyAttachmentType.Name & " \ " & MyAttachment.Name End If lNbAttachmentsManaged += 1 sDescription = Trim(CStr(range.Cells(lCurRow, 3).Value)) If sDescription <> "" Then MyAttachment.Description = sDescription End If iValue = CInt(Trim(range.Cells(lCurRow, 4).Value)) MyAttachment.Datatype = iValue sValue = Trim(CStr(range.Cells(lCurRow, 6).Value)) If sValue <> "" Then splitted = Split(sValue, ",") For Each sValue In splitted MyAttachment.TextList.Add(sValue) Next sValue End If sDefault = Trim(CStr(range.Cells(lCurRow, 5).Value)) If (sDefault <> "") Then ' Convert/Format the value to a string Select Case iValue Case NUMERIC_TYPE sDefault = CStr(CInt(sDefault)) Case DATE_TYPE dt = CStr(CDate(sDefault)) sDefault = Format(dt, "MM/DD/YYYY") Case TIME_TYPE dt = CStr(CDate(sDefault)) ' Type checking through casting sDefault = Format(dt, "hh:nn:ssAMPM") ' Expected ER/Studio format Case BOOLEAN_TYPE sDefault = CStr(CBool(sDefault)) End Select MyAttachment.ValueDefault = sDefault End If End If End If Next lCurRow ImportAttachments = lNbAttachmentsManaged End Function Sub PrintSampleSheet() Dim sample As Object Dim wb, ws As Variant Set sample = CreateObject("excel.application") sample.visible = True Set wb = sample.workbooks.Add Set ws = wb.activesheet PrintHeader(sample, ws) ws.Cells(2, 1).Value = "Tables" ws.Cells(2, 2).Value = "Attachment 1" ws.Cells(2, 3).Value = "A description" ws.Cells(2, 4).Value = TEXT_TYPE ws.Cells(2, 5).Value = "Default value" ws.Cells(3, 1).Value = "Tables" ws.Cells(3, 2).Value = "Attachment 2" ws.Cells(3, 3).Value = "Another description" ws.Cells(3, 4).Value = TEXT_LIST_TYPE ws.Cells(3, 5).Value = "Second item" ws.Cells(3, 6).Value = "First item,Second item,Third item" ws.Cells(4, 1).Value = "Entities" ws.Cells(4, 2).Value = "Attachment 1" ws.Cells(4, 3).Value = "My entity property description" ws.Cells(4, 4).Value = TEXT_TYPE ws.Cells(5, 1).Value = "Attributes" ws.Cells(5, 2).Value = "Attachment 1" ws.Cells(5, 3).Value = "My Attribute property description" ws.Cells(5, 4).Value = TEXT_TYPE ws.Cells(6, 1).Value = "Columns" ws.Cells(6, 2).Value = "Attachment 1" ws.Cells(6, 3).Value = "My Column property description" ws.Cells(6, 4).Value = TEXT_TYPE ws.Cells(7, 1).Value = "..." ws.Cells(7, 2).Value = "..." ws.Cells(7, 3).Value = "..." ws.Cells(7, 4).Value = "..." ws.Cells(7, 5).Value = "..." ws.Cells(7, 6).Value = "..." AutofitAllUsed(sample) Comments_AutoSize(ws) Debug.Print "Sample generated" MsgBox "Sample generated", vbInformation, TITLE End Sub Private Function DialogFunc(DlgItem$, Action%, SuppValue&) As Boolean Select Case Action% Case 1 ' Dialog box initialization DlgValue("cbBind", True) 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(,"All Excel Files (*.xlsx;*.xls;*.xlsm)|*.xlsx;*.xls;*.xlsm|Excel Workbook (*.xlsx)|*.xlsx|Excel Macro-enabled Workbook (*.xslm)|*.xslm|Excel 97-2003 Workbook (*.xls)|*.xls|All Files (*.*)|*.*",,"Open SpreadSheet", 0) 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.", vbExclamation, TITLE) 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 Private Sub AutofitAllUsed(excelObj) Dim x As Long For x = 1 To excelObj.ActiveSheet.UsedRange.Columns.Count excelObj.ActiveSheet.UsedRange.Columns(x).EntireColumn.AutoFit Next x End Sub Private Sub PrintHeader(excel As Object,sheet As Variant) sheet.Name = "Attachments" With sheet.range("A1:F1") .interior.colorindex = 15 .font.Size = 9 .font.Bold = True .horizontalalignment = xlCenter End With With excel With .ActiveWindow .SplitColumn = 1 .SplitRow = 1 End With .ActiveWindow.FreezePanes = True End With sheet.cells(1,1).Value = "Attachment Type" sheet.cells(1,2).Value = "Name" sheet.cells(1,3).Value = "Description" sheet.cells(1,4).Value = "Data Type" sheet.cells(1,5).Value = "Default value" sheet.cells(1,6).Value = "Text list values" With sheet.cells(1,4) .AddComment .Comment.Visible = False .Comment.Text Text:= "1 = Boolean" & vbCrLf & "2 = Date" & vbCrLf & "3 = ExternalFilePath" & vbCrLf & "4 = Numeric" & vbCrLf & "5 = Text" & vbCrLf & "6 = TextList" & vbCrLf & "7 = Time" End With With sheet.range("A:A") .interior.colorindex = 15 .verticalalignment = xlBottom .horizontalalignment = xlLeft .font.Bold = True .font.Size = 9 End With End Sub Sub Comments_AutoSize(s As Object) ' https://www.contextures.com/xlcomments03.html Dim MyComments As Object Dim lArea As Long Dim lMult As Double Dim MaxW As Long Dim NewW As Long 'Height adjustment factor 'of 1.1 seems to work ok. lMult = 1.1 MaxW = 300 NewW = 200 For Each MyComments In s.Comments With MyComments .Shape.TextFrame.AutoSize = True If .Shape.Width > MaxW Then lArea = .Shape.Width * .Shape.Height .Shape.Width = NewW .Shape.Height = (lArea / NewW) * lMult End If End With Next ' comment End Sub
wReadAttachmentsFromExcel.bas
⚠️ You need to update the path to the Excel workbook (Line 22).
'#Language "WWB-COM" ''MACRO TITLE: wRead Attachments from Excel ' MACRO VERSION: 2.0 'This macro imports specific Attachments for Entities, Tables, Attributes, ' Columns, Relationships & Views ' ' Dependencies: ' wBindAttachmentstoERObjects.bas ' Excel ' ' Release notes ' 2.0: Import specific Attachments Types ' 1.0: Initial version '--------------------------------------------------------------------------- '#Uses "wBindAttachmentsToERObjects.bas" Option Explicit Private Const TITLE$ = "wRead Attachments from Excel" Private Const DICTIONARY_NAME$ = "" ' Empty = Local Data Dictionary; Name of the Enterprise Data Dictionary Private Const EXCEL_FILE$ = "C:\Users\William\Documents\ERStudio Data Architect 20.1\Tests\default_attachments_V2.xlsx" ' Path to the workbook with the attachments list Private Const BIND_ATTACHMENTS_TO_EROBJECTS = True Dim lCurRow% Sub Main Dim excel As Object Dim lNbManaged& Dim MyDiagram As Diagram Dim MyDictionary As Dictionary Debug.Clear Set MyDiagram = DiagramManager.ActiveDiagram If Not MyDiagram Is Nothing Then start_dialog: If DICTIONARY_NAME = "" Then Set MyDictionary = MyDiagram.Dictionary Else Set MyDictionary = MyDiagram.EnterpriseDataDictionaries.Item(DICTIONARY_NAME) End If If Not MyDictionary Is Nothing Then 'initialize excel object and make visible Set excel = CreateObject("Excel.Application") 'this Error Is For an errant file path, Dialog will be restarted On Error GoTo Error_open excel.workbooks.Open EXCEL_FILE On Error GoTo Error_unknown DiagramManager.EnableScreenUpdateEx(False, False) lNbManaged = ImportAttachments(excel, MyDictionary) If (lNbManaged > 0) And BIND_ATTACHMENTS_TO_EROBJECTS Then BindAttachments(False) End If DiagramManager.EnableScreenUpdateEx(True, True) excel.Quit() MsgBox ("ERObjects Attachments imported" & vbCrLf & vbCrLf & lNbManaged & " attachment" & If(lNbManaged > 1, "s", "") & " managed", vbInformation, TITLE) Debug.Print Debug.Print lNbManaged & " attachment" & If(lNbManaged > 1, "s", "") & " managed" Else MsgBox "Data dictionary not available!", vbExclamation, TITLE End If Else MsgBox "No project opened!", vbExclamation, TITLE End If Exit Sub Error_open: MsgBox("Excel file path is not valid.", vbExclamation, TITLE) GoTo start_dialog Error_unknown: MsgBox(Err.Description & If(lCurRow > 1, vbCrLf & vbCrLf & "Last Excel row used: " & lCurRow, ""), vbExclamation, TITLE) If Not excel Is Nothing Then excel.Quit() End If DiagramManager.EnableScreenUpdateEx(True, True) End Sub Private Function ImportAttachments(ByRef ex As Variant, ByRef dict As Dictionary) As Integer Dim sheet As Object Dim range As Object Dim sValue$, iValue%, sDefault$ Dim lNbAttachments&, lNbAttachmentsManaged& Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment Dim sLastAttachmentType$ Dim sDescription$, dt As Date, splitted Set sheet = ex.worksheets(1) Set range = sheet.usedrange range.Select sLastAttachmentType = "" ImportAttachments = 0 lNbAttachments = range.Rows.Count Debug.Print "Number of attachments: " & (lNbAttachments - 1) lNbAttachmentsManaged = 0 For lCurRow = 2 To lNbAttachments sValue = Trim(CStr(range.Cells(lCurRow, 1).Value)) If (sValue <> "") And ToImportExport(sValue) Then If (sValue <> sLastAttachmentType) Then Set MyAttachmentType = dict.AttachmentTypes(sValue) ' Check if AttachmentType exists If MyAttachmentType Is Nothing Then ' Attachment type not found, we create it Set MyAttachmentType = dict.AttachmentTypes.Add(sValue, "Imported from file: " & EXCEL_FILE) End If sLastAttachmentType = sValue End If sValue = Trim(CStr(range.Cells(lCurRow, 2).Value)) If (sValue <> "") Then Set MyAttachment = MyAttachmentType.Attachments(sValue) ' Check if Attachment exists If MyAttachment Is Nothing Then ' Attachment not found, we create it Set MyAttachment = MyAttachmentType.Attachments.Add(sValue, "Imported from file: " & EXCEL_FILE, "", TEXT_TYPE) Debug.Print "Attachment created: " & MyAttachmentType.Name & " \ " & MyAttachment.Name Else Debug.Print "Attachment found: " & MyAttachmentType.Name & " \ " & MyAttachment.Name End If lNbAttachmentsManaged += 1 sDescription = Trim(CStr(range.Cells(lCurRow, 3).Value)) If sDescription <> "" Then MyAttachment.Description = sDescription End If iValue = CInt(Trim(range.Cells(lCurRow, 4).Value)) MyAttachment.Datatype = iValue sValue = Trim(CStr(range.Cells(lCurRow, 6).Value)) If sValue <> "" Then splitted = Split(sValue, ",") For Each sValue In splitted MyAttachment.TextList.Add(sValue) Next sValue End If sDefault = Trim(CStr(range.Cells(lCurRow, 5).Value)) If (sDefault <> "") Then ' Convert/Format the value to a string Select Case iValue Case NUMERIC_TYPE sDefault = CStr(CInt(sDefault)) Case DATE_TYPE dt = CStr(CDate(sDefault)) sDefault = Format(dt, "MM/DD/YYYY") Case TIME_TYPE dt = CStr(CDate(sDefault)) ' Type checking through casting sDefault = Format(dt, "hh:nn:ssAMPM") ' Expected ER/Studio format Case BOOLEAN_TYPE sDefault = CStr(CBool(sDefault)) End Select MyAttachment.ValueDefault = sDefault End If End If End If Next lCurRow ImportAttachments = lNbAttachmentsManaged End Function
ERSBasicHandlers.bas
Some different examples using the Attachments created and utilized by the previous macros.
⚠️ You need to update the paths to the macros in the following script (Lines 15 & 175):
''MACRO TITLE: ERSBasicHandlers ' MACRO VERSION: 2.0 'This macro imports specific Attachments for Entities, Tables, Attributes, ' Columns, Relationships & Views and binds them to specific ER Objects ' ' Dependencies: ' wBindAttachmentstoERObjects.bas ' Excel ' ' Release notes ' 2.0: Relationships & Views added ' Attachments supported across multiple ER Objects ' 1.0: Initial version '--------------------------------------------------------------------------- '#Uses "C:\ProgramData\Idera\ERStudioDA_20.1\Macros\w\Bound attachments V2\wBindAttachmentsToERObjects.bas" Sub CreateEntityHandler(CurEntity As Object, CurDiagram As Object) BindAttachments(True) ' Lazy method: the function is looping over all supported objects = not optimized End Sub ' Bind Attributes & Columns Sub CreateAttributeHandler(CurAttribute As Object, CurDiagram As Object) Dim MyDiagram As Diagram Dim MyDictionary As Dictionary Dim MyModel As Model Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment Dim MyAttribute As AttributeObj Set MyDiagram = CurDiagram Set MyAttribute = CurAttribute Set MyDictionary = MyDiagram.Dictionary ' Update this line to use an Enterprise Data Dictionary Set MyModel = MyDiagram.ActiveModel For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, IIf(MyModel.Logical, ATTRIBUTES, COLUMNS)) Then For Each MyAttachment In MyAttachmentType.Attachments MyAttribute.BoundAttachments.Add(MyAttachment.ID) Next End If Next MyAttachmentType End Sub Sub CreateRelationshipHandler(CurRelationship As Object, CurDiagram As Object) Dim MyDiagram As Diagram Dim MyDictionary As Dictionary Dim MyModel As Model Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment Dim MyRelationship As Relationship Set MyDiagram = CurDiagram Set MyRelationship = CurRelationship Set MyDictionary = MyDiagram.Dictionary ' Update this line to use an Enterprise Data Dictionary Set MyModel = MyDiagram.ActiveModel For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, RELATIONSHIPS) Then For Each MyAttachment In MyAttachmentType.Attachments MyRelationship.BoundAttachments.Add(MyAttachment.ID) Next End If Next End Sub Sub CreateIndexHandler(CurIndex As Object, CurDiagram As Object) End Sub Sub CreateModelHandler(CurModel As Object, CurDiagram As Object) End Sub Sub CreateSubModelHandler(CurSubModel As Object, CurDiagram As Object) End Sub Sub CreateDomainHandler(CurDomain As Object, CurDiagram As Object) End Sub Sub CreateDefaultHandler(CurDefault As Object, CurDiagram As Object) End Sub Sub CreateUserDatatypeHandler(CurUserDatatype As Object, CurDiagram As Object) End Sub Sub CreateRuleHandler(CurRule As Object, CurDiagram As Object) End Sub Sub CreateViewHandler(CurView As Object, CurDiagram As Object) Dim MyDiagram As Diagram Dim MyDictionary As Dictionary Dim MyModel As Model Dim MyAttachmentType As AttachmentType Dim MyAttachment As Attachment Dim MyView As View Set MyDiagram = CurDiagram Set MyView = CurView Set MyDictionary = MyDiagram.Dictionary ' Update this line to use an Enterprise Data Dictionary Set MyModel = MyDiagram.ActiveModel For Each MyAttachmentType In MyDictionary.AttachmentTypes If IsMatching(MyAttachmentType.Name, VIEWS) Then For Each MyAttachment In MyAttachmentType.Attachments MyView.BoundAttachments.Add(MyAttachment.ID) Next End If Next End Sub Sub CreateTriggerHandler(CurTrigger As Object, CurDiagram As Object) End Sub Sub CreateProcedureHandler(CurProcedure As Object, CurDiagram As Object) End Sub Sub CreateViewRelationshipHandler(CurViewRelationship As Object, CurDiagram As Object) End Sub Sub CreateDiagramHandler(CurDiagram As Object) ' Load Attachments MacroRun "C:\ProgramData\Idera\ERStudioDA_20.1\Macros\w\Bound attachments V2\wReadAttachmentsFromExcel.bas" End Sub Sub CreateEntityDisplayHandler(CurEntityDisplay As Object, CurDiagram As Object) End Sub Sub CreateRelationshipDisplayHandler(CurRelationshipDisplay As Object, CurDiagram As Object) End Sub Sub CreateViewDisplayHandler(CurViewDisplay As Object, CurDiagram As Object) End Sub Sub CreateViewRelationshipDisplayHandler(CurViewRelationshipDisplay As Object, CurDiagram As Object) End Sub Sub CreateViewFieldHandler(CurViewField As Object, CurDiagram As Object) End Sub Sub CreateFKColumnPairHandler(CurFKColumnPair As Object, CurDiagram As Object) End Sub Sub CreateIndexColumnHandler(CurIndexColumn As Object, CurDiagram As Object) End Sub Sub CreateSubTypeHandler(CurSubType As Object, CurDiagram As Object) End Sub Sub CreateSubTypeClusterHandler(CurSubTypeCluster As Object, CurDiagram As Object) End Sub
Summary
It now supports Entities, Tables, Attributes, Columns, Relationships & Views, but it can be easily extended to also support other objects (Shapes, etc.).
So, as usual, feel free to modify the scripts so that they perfectly meet your expectations, or simply copy parts of these scripts into your own macros.
Moreover, I still strongly suggest using an Enterprise Data Dictionary to store your attachments, allowing you to directly share them through the Repository.