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:
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:
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:
| Examples: | |
When the macro to create these shortcuts is run, its interface will display the following:
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
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
A short video which shows how to create a macro from a script in ER/Studio Data Architect:
