Home > Resource Center > Shortcuts: a macro to rule them all

Shortcuts: a macro to rule them all

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:

Aligning complex data environments with business goals for over 30 years.
Copyright © 2024 Idera, Inc.