In this post, I’ll share a script which lets you add shortcuts to macros that you may want to quickly access from various places in ER/Studio Data Architect.
Usually, you would access the macros from the Macro tab of the Data Model Explorer:
Macro tab of the Data Model Explorer
Nevertheless, ER/Studio Data Architect can be configured with a quick access to your preferred macros through a right-click context menu on your objects of your models.
Normally, you would use the Add/Remove Macros dialog box to configure it:
Add/Remove Macros dialog box
However, the script below will allow you to quickly manage your macro shortcuts and associate them with any existing macros, including those in any subfolders beneath your Macros Directory.
Here are the various places within ER/Studio Data Architect where you can find the macro shortcuts:
- Macro tab (Ribbon)
- Diagram (Context menu)
- Entity (Context menu)
- Relationship (Context menu)
- Shape (Context menu)
- Business Data Object (Context menu)
- View (Context menu)
|
Examples:
|
|
 Ribbon |
 Context menu |
When the macro to create these shortcuts is run, its interface will display the following:
- on the left (Selected macros) is the list of macros that are made available to the context menu
- on the right (Available macros) are the available macros from your Macros Directory
wMacro Shortcuts UI
Script
Below is the sample macro script:
'#Language "WWB-COM" ''MACRO TITLE: Macro Shortcuts ' MACRO VERSION: 1.1 'This macro allows to select the Macro Shortcuts you want to use ' by object type ' https://docwiki.embarcadero.com/ERStudioDA/en/Adding_Macros_to_GUI_Modeling_Menus ' ' Release notes ' 1.1 Buttons to move the shortcuts added ' Select current macro (show this file in the macro UI) ' 1.0 Initial version '--------------------------------------------------------------------------- Option Explicit Const TITLE$ = "wMacro Shortcuts" Const NONE$ = "<None>" ' Label for empty values Dim laFolders$() Dim laFiles$() Dim laMacros$() Dim laMenuKey$() Dim laMenuLabel$() Dim sMacrosDirectory$ Sub Main Dim iLoop% Debug.Clear ReDim laMenuKey(6) ReDim laMenuLabel(6) laMenuKey (0) = "DiagramMenuMacros" laMenuLabel(0) = "Diagram Menu" laMenuKey (1) = "EntityMenuMacros" laMenuLabel(1) = "Entity Menu" laMenuKey (2) = "MainMenuMacros" laMenuLabel(2) = "Main Menu" laMenuKey (3) = "RelMenuMacros" laMenuLabel(3) = "Relationship Menu" laMenuKey (4) = "ShapeMenuMacros" laMenuLabel(4) = "Shape Menu" laMenuKey (5) = "SubjectAreaMenuMacros" laMenuLabel(5) = "Business Data Object Menu" laMenuKey (6) = "ViewMenuMacros" laMenuLabel(6) = "View Menu" ' Get the selected macros sMacrosDirectory = GetMacrosDirectory() ReDim laMacros(0 To 9) iLoop = 0 ReDim laFolders(0 To 99) laFolders(0) = "\" ' Get the different folders AddSubFolders(sMacrosDirectory, iLoop) ReDim Preserve laFolders(0 To iLoop) For iLoop = 1 To UBound(laFolders) laFolders(iLoop) = Replace(laFolders(iLoop), sMacrosDirectory, "",,1) Next iLoop Begin Dialog UserDialog 970,315,TITLE,.DialogFunc ' %GRID:10,7,1,1 GroupBox 10,7,500,273,"Selected macros",.gbSelectedMacros Text 20,28,90,14,"Object type:",.tObjectType DropListBox 20,42,480,70,laMenuLabel(),.dlbMenu Text 20,63,90,14,"Macros:",.tMacros ListBox 20,77,480,126,laMacros(),.lbMacros Text 20,210,480,14,"",.tMacro,1 PushButton 20,224,480,21,"Delete current shortcut",.pbDelete PushButton 20,252,230,21,"Move up",.pbMoveUp PushButton 270,252,230,21,"Move down",.pbMoveDown GroupBox 530,7,430,273,"Available macros",.gbAvailableMacros Text 540,28,90,14,"Folders:",.tFolders DropListBox 540,42,410,70,laFolders(),.dlbFolder,2 Text 540,63,90,14,"Files:",.tFiles ListBox 540,77,410,140,laFiles(),.lbFiles,1 PushButton 540,224,410,21,"Add current macro to selected shortcut",.pbAdd PushButton 540,252,410,21,"Select current macro",.pbCurrentMacro OKButton 450,287,90,21 End Dialog Dim dlg As UserDialog dlg.dlbMenu = 5 If Dialog(dlg) = -1 Then If (dlg.dlbFolder <> -1) And (dlg.lbFiles <> -1) Then Debug.Print "file: " & sMacrosDirectory & laFolders(dlg.dlbFolder) & IIf(dlg.dlbFolder > 0, "\", "") & laFiles(dlg.lbFiles) Else Debug.Print "No file selected" End If End If End Sub Rem See DialogFunc help topic for more information. Private Function DialogFunc(DlgItem As String, Action As Integer, SuppValue As PortInt) As Boolean Dim iLoop% Select Case Action Case 1 ' Dialog box initialization DlgEnable "pbAdd", False DlgEnable "pbDelete", False DlgEnable "pbMoveUp", False DlgEnable "pbMoveDown", False DlgEnable "pbCurrentMacro", Left(CurrentMacro, Len(sMacrosDirectory)) = sMacrosDirectory RefreshMacros RefreshFiles ' DlgEnable "OK", (UBound(laFiles) <> -1) Case 2 ' Value changing or button pressed Rem DialogFunc = True ' Prevent button press from closing the dialog box Select Case DlgItem Case "dlbFolder" RefreshFiles RefreshAddButton DialogFunc = True Case "dlbMenu" RefreshMacros DialogFunc = True Case "lbFiles" RefreshAddButton Debug.Print DlgValue("lbFiles") & "--> " & sMacrosDirectory & laFolders(DlgValue "dlbFolder") & IIf((DlgValue "dlbFolder") > 0, "\", "") & laFiles(DlgValue "lbFiles") DialogFunc = True Case "lbMacros" RefreshAddButton RefreshShortcutsButtons SelectMacro DlgText("tMacro", laMacros(DlgValue "lbMacros")) Debug.Print DlgValue("lbMacros") & "--> " & laMacros(DlgValue "lbMacros") DialogFunc = True Case "pbAdd" UpdateMacroShortcut(DlgValue("lbMacros"), sMacrosDirectory & laFolders(DlgValue "dlbFolder") & IIf((DlgValue "dlbFolder") > 0, "\", "") & laFiles(DlgValue "lbFiles")) Debug.Print sMacrosDirectory & laFolders(DlgValue "dlbFolder") & IIf((DlgValue "dlbFolder") > 0, "\", "") & laFiles(DlgValue "lbFiles") & "--> " & DlgValue "lbMacros" DialogFunc = True Case "pbDelete" DeleteMacroShortcut(DlgValue("lbMacros")) Debug.Print "--> " & DlgValue "lbMacros" DialogFunc = True Case "pbMoveUp" MoveShortcut(DlgValue("lbMacros"), True) Debug.Print "Move up: " & DlgValue "lbMacros" DialogFunc = True Case "pbMoveDown" MoveShortcut(DlgValue("lbMacros"), False) Debug.Print "Move down: " & DlgValue "lbMacros" DialogFunc = True Case "pbCurrentMacro" SelectMacro(CurrentMacro) Debug.Print "Selecting current macro: " & TITLE DialogFunc = True End Select Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem Wait .1 : DialogFunc = True ' Continue getting idle actions Case 6 ' Function key End Select End Function Private Function GetMacrosDirectory As String GetMacrosDirectory = CreateObject("WScript.Shell").RegRead(DiagramManager.GetRegistryKey & "\Application\MacroDirectory") End Function Private Sub AddSubFolders(sRoot$, ByRef index%) Dim F$ Dim iFrom%, iTo%, iLoop% iFrom = index + 1 ' Add the "root folders" F$ = Dir$(sRoot & "\*.", vbDirectory) While (F$ <> "") And (index < UBound(laFolders)) If (F$ <> ".") And (F$ <> "..") Then index = index + 1 laFolders(index) = sRoot & "\" & F$ Debug.Print F$ End If F$ = Dir$() Wend iTo = index For iLoop = iFrom To iTo AddSubFolders(laFolders(iLoop), index) Next iLoop End Sub Private Sub LoadFiles(sFolder$) Dim F$, index% index = 0 ReDim laFiles(0 To 99) ' Add the macro files F$ = Dir$(sFolder & "\*.bas") While (F$ <> "") If (F$ <> ".") And (F$ <> "..") Then laFiles(index) = F$ index = index + 1 Debug.Print Chr(9) & F$ End If F$ = Dir$() Wend ReDim Preserve laFiles(0 To (index - 1)) End Sub Private Sub RefreshFiles() LoadFiles(sMacrosDirectory & laFolders(DlgValue "dlbFolder")) DlgListBoxArray("lbFiles", laFiles) End Sub Private Sub RefreshMacros() Dim sh Dim iLoop% Dim sMacro$, sRK$, sKey$ If DlgValue("dlbMenu") <> -1 Then Set sh = CreateObject("WScript.Shell") sRK = DiagramManager.GetRegistryKey & "\" & laMenuKey(DlgValue("dlbMenu")) & "\" For iLoop = 1 To 10 On Error GoTo Errors_Handler sKey = sRK & "Macro" & iLoop sMacro = sh.RegRead(sKey) If sMacro <> "" Then laMacros(iLoop - 1) = Replace(sMacro, sMacrosDirectory, "",,1) Else laMacros(iLoop - 1) = NONE End If Next iLoop DlgListBoxArray("lbMacros", laMacros) RefreshAddButton End If Exit Sub Errors_Handler: If Err.Number = -2147024894 Then If WriteMacroShortcut(sKey, "") Then sMacro = NONE Err.Clear Resume Next Else Debug.Print "Can't access the usual registry key!" Exit All End If End If End Sub Private Function WriteMacroShortcut(sKey$, sMacro$) As Boolean Dim sh Set sh = CreateObject("WScript.Shell") On Error GoTo Errors_Handler sh.RegWrite(sKey, sMacro) WriteMacroShortcut = True Exit Function Errors_Handler: WriteMacroShortcut = False Resume Next End Function Private Sub RefreshAddButton() DlgEnable "pbAdd", (DlgValue("lbMacros") <> -1) And (DlgValue("lbFiles") <> -1) DlgText("tMacro", "") End Sub Private Sub RefreshShortcutsButtons() On Error GoTo Errors_Handler Dim bState As Boolean bState = (DlgValue("lbMacros") <> -1) DlgEnable "pbDelete", bState And (laMacros(DlgValue("lbMacros")) <> NONE) DlgEnable "pbMoveUp", (DlgValue("lbMacros") > 0) DlgEnable "pbMoveDown", bState And (DlgValue("lbMacros") < 9) Errors_Handler: Debug.Print DlgValue("lbMacros") Resume Next End Sub Private Function UpdateMacroShortcut(iMacroIndex%, sMacro$) As Boolean UpdateMacroShortcut = WriteMacroShortcut(DiagramManager.GetRegistryKey & "\" & laMenuKey(DlgValue("dlbMenu")) & "\Macro" & (iMacroIndex + 1), sMacro) laMacros(iMacroIndex) = IIf(sMacro = "", NONE, Replace(sMacro, sMacrosDirectory, "",,1)) DlgListBoxArray("lbMacros", laMacros) DlgValue "lbMacros", iMacroIndex Debug.Print "Macro Shortcut " & (iMacroIndex + 1) & " has been " & IIf(sMacro = "", "dele", "upda") & "ted!" RefreshAddButton RefreshShortcutsButtons End Function Private Function DeleteMacroShortcut(iMacroIndex%) As Boolean DeleteMacroShortcut = WriteMacroShortcut(DiagramManager.GetRegistryKey & "\" & laMenuKey(DlgValue("dlbMenu")) & "\Macro" & (iMacroIndex + 1), "") laMacros(iMacroIndex) = NONE DlgListBoxArray("lbMacros", laMacros) DlgValue "lbMacros", iMacroIndex Debug.Print "Macro Shortcut " & (iMacroIndex + 1) & " has been deleted!" RefreshAddButton DlgEnable "pbDelete", False End Function Private Sub SelectMacro(Optional sMacro$ = "") Dim sPath$ Dim iIndex%, iLoop% If sMacro = "" Then sMacro = laMacros(DlgValue "lbMacros") Else sMacro = Replace(sMacro, sMacrosDirectory, "",, 1) End If Debug.Print "Current macro: " & sMacro If sMacro <> NONE Then iIndex = InStrRev(sMacro, "\") If iIndex > 0 Then sPath = Left(sMacro, iIndex - 1) sMacro = Replace(sMacro, sPath & "\", "",, 1) Debug.Print "Path: " & sPath Debug.Print "Macro: " & sMacro For iIndex = LBound(laFolders) To UBound(laFolders) If LCase(laFolders(iIndex)) = LCase(sPath) Then DlgValue("dlbFolder", iIndex) RefreshFiles For iLoop = LBound(laFiles) To UBound(laFiles) If LCase(laFiles(iLoop)) = LCase(sMacro) Then DlgValue("lbFiles", iLoop) Exit For End If Next iLoop Exit For End If Next iIndex End If End If RefreshAddButton End Sub Private Sub MoveShortcut(iIndex%, bMoveUp As Boolean) Dim sValue$, iSibling% If (iIndex >= 0) Or (iIndex <= 9) Then ' Up & 1st row If bMoveUp And (iIndex = 0) Then Exit Sub End If ' Down & last row If (Not bMoveUp) And (iIndex = 9) Then Exit Sub End If ' The index of the shortcut to switch iSibling = IIf(bMoveUp, iIndex - 1, iIndex + 1) ' Value of the current shortcut sValue = laMacros(iIndex) ' Switch shortcuts laMacros(iIndex) = laMacros(iSibling) laMacros(iSibling) = sValue ' Update the Windows Registry If laMacros(iIndex) <> NONE Then UpdateMacroShortcut(iIndex, IIf(Left(laMacros(iIndex), 1) = "\", sMacrosDirectory, "") & laMacros(iIndex)) Else WriteMacroShortcut(DiagramManager.GetRegistryKey & "\" & laMenuKey(DlgValue("dlbMenu")) & "\Macro" & (iIndex + 1), "") End If If laMacros(iSibling) <> NONE Then UpdateMacroShortcut(iSibling, IIf(Left(laMacros(iSibling), 1) = "\", sMacrosDirectory, "") & laMacros(iSibling)) Else WriteMacroShortcut(DiagramManager.GetRegistryKey & "\" & laMenuKey(DlgValue("dlbMenu")) & "\Macro" & (iSibling + 1), "") End If DlgListBoxArray("lbMacros", laMacros) DlgValue "lbMacros", iSibling Debug.Print "Shortcut moved from " & iIndex & " to " & iSibling RefreshShortcutsButtons End If End Sub Private Function CurrentMacro$ Dim sCurrentMacro$ sCurrentMacro = Mid(CallersLine, 2, InStr(CallersLine, "|") - 2) If Dir$(sCurrentMacro) <> "" Then CurrentMacro = sCurrentMacro Else CurrentMacro = "" End If End Function
Summary
In this post, we have supplied the above macro which helps to create right-click context menu shortcuts for your macros.
Programmatically, this script does the following
- gets files from your hard drive
- updates the Windows registry
- uses different macro UI components
Bonus
A short video which shows how to create a macro from a script in ER/Studio Data Architect: