Macros – Colorize specific attributes

Introduction

Using the data modeling features of ER/Studio Data Architect we can create automatic and customized data model diagrams. ER/Studio Data Architect provides functionality such as automatic layouts, custom colors and fonts for our objects, and relationship line control.

To make our model more attractive and easier to read, we can change the background, outline, and font colors along with the font type entities/tables, attributes/columns, views, and relationships in our data model. We can use specific colors and/or fonts to help us organize our data model.

In this blog post, I’ll share a macro which shows how to manage the colors from a script. With this macro, we can search for a string and colorize the attributes and columns which match the string.

wColorize

If we want to search in other properties or objects, it would be quite easy to update the script to get exactly what we need.

Steps

First, we’ll need to create the macro within our ER/Studio Data Architect. If we’re unsure how to do this, a tutorial video is provided at the end of this post, demonstrating the process.

Then, we select the model which contains the Attributes and/or Columns we want to change their colors.

Finally we run the macro and we use the provided UI:

wColorize

Script

'#Language "WWB-COM"
''MACRO TITLE: wColorize
' MACRO VERSION: 1.0
'
'This macro looks for a string within Attributes and Columns Names and
'	colorizes the matching ones with the chosen color
'
' Release notes
' 1.0 Initial version
'---------------------------------------------------------------------------

Option Explicit

Const TITLE$ = "wColorize"

Dim bmpFile$	' Image used to display the color

Dim laLogs$()	' Array of strings for the logs
Dim laColors$()	' Array of strings for the different colors

Dim sParent$, sChild$	' Strings for logs

' ERObjects
Dim MyDiagram As Diagram
Dim MyModel As Model
Dim bLogical As Boolean
Dim MySubModel As SubModel

Sub Main
	
	Dim iLoop%

	bmpFile = MacroDir & "\wColoredPixel.bmp"

	Set MyDiagram = DiagramManager.ActiveDiagram

	If MyDiagram Is Nothing Then
	
		MsgBox "A project should be opened!", vbExclamation, TITLE

		Exit Sub

	End If

	Set MyModel = MyDiagram.ActiveModel
	bLogical = MyModel.Logical

	Set MySubModel = MyModel.ActiveSubModel

	ReDim laLogs(2)
	laLogs(1) = "Project: " & MyDiagram.ProjectName
	laLogs(2) = "Current submodel: " & MySubModel.Name

	laColors = Split(",Black,Blue,Green,Cyan,Red,Magenta,Yellow,White,Gray,Light Blue,Light Green,Light Cyan,Light Red,Light Magenta,Light Yellow,Bright White", ",")

	Begin Dialog UserDialog 650,308,TITLE,.dfColor ' %GRID:10,7,1,1
		GroupBox 10,7,340,154,"Search",.gbSearch
		Text 20,23,110,14,"String to search:",.tSearch,1
		TextBox 140,21,200,21,.tbSearch
		CheckBox 30,49,130,14,"Partial match",.cbSearchSub
		CheckBox 180,49,150,14,"Case sensitive",.cbCaseSensitive
		GroupBox 20,70,320,56,"Scope",.gbScope
		OptionGroup .gScope
			OptionButton 30,84,130,14,"Current submodel",.obCurrent
			OptionButton 190,84,140,14,"Current model",.obModel
			OptionButton 30,105,130,14,"All models",.obAll
		PushButton 20,133,320,21,"Search and colorize",.pbSearchColorSet
		GroupBox 10,161,630,112,"Results",.gbResults
		MultiListBox 20,175,610,91,laLogs(),.mlbLogs,1
		GroupBox 360,7,290,126,"Color",.gbColor
		Text 370,23,40,14,"Red:",.tRed,1
		TextBox 420,21,90,21,.tbR
		Text 370,49,40,14,"Green:",.tGreen,1
		TextBox 420,49,90,21,.tbG
		Text 370,79,40,14,"Blue:",.tBlue,1
		TextBox 420,77,90,21,.tbB
		Picture 530,21,110,49,"",0,.pColor
		TextBox 530,77,110,21,.tbHexa
		DropListBox 420,105,220,70,laColors(),.dlbColor
		OKButton 280,280,90,21
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

	' Remove the generated image to display the color
	If Dir(bmpFile) <> "" Then
	
		Kill(bmpFile)

	End If

End Sub

Private Function dfColor(DlgItem As String, Action As Integer, SuppValue As PortInt) As Boolean
	
	Dim s$, l&
	Dim selectedAttributes%(), iLoop%

	Select Case Action
	Case 1 ' Dialog box initialization
		
		DlgValue("dlbColor", 1)
'		DlgValue("cbSearchSub", True)
'		DlgValue("cbCaseSensitive", True)

		DlgText("tbR", "0")
		DlgText("tbG", "0")
		DlgText("tbB", "0")

		DlgText("tbHexa", "000000")

		UpdateColorPreview()

		DlgEnable("pbSearchColorSet", False)

	Case 2 ' Value changing or button pressed
		
		If DlgItem = "dlbColor" Then
			
			DlgText("tbHexa", GetHexValueFromDefaultColor(DlgValue("dlbColor") - 1))
			SetColorsFromHexField()
			UpdateColorPreview()
			dfColor = True	' Prevent button press from closing the dialog box

		ElseIf DlgItem = "mlbAttributes" Then

			selectedAttributes = DlgValue "mlbAttributes"

			DlgEnable("pbColorSet", UBound(selectedAttributes) <> -1)

		ElseIf DlgItem = "pbSearchColorSet" Then
			
			SearchAndColorize(DlgText("tbSearch"), DlgValue("gScope"), DlgValue("cbSearchSub"), DlgValue("cbCaseSensitive"))

			' Prevent button press from closing the dialog box
			dfColor = True

		End If

	Case 3 ' TextBox or ComboBox text changed
		
		CheckValues()
		Select Case DlgItem
			Case "tbR", "tbG", "tbB"
				' Convert Bytes to Hexa
				DlgText("tbHexa", GetHexValue("tbR") & GetHexValue("tbG") & GetHexValue("tbB"))
			Case "tbHexa"
				SetColorsFromHexField()
			Case "tbSearch"
				DlgEnable("pbSearchColorSet", Trim(DlgText("tbSearch")) <> "")
		End Select
		Select Case DlgItem
			Case "tbR", "tbG", "tbB", "tbHexa"
				' Custom color
				DlgValue("dlbColor", 0)
				' Show the color
				UpdateColorPreview()
		End Select

	Case 4 ' Focus changed
	Case 5 ' Idle
		Rem Wait .1 : dfColor = True ' Continue getting idle actions
	Case 6 ' Function key
	End Select
End Function

Private Sub SearchAndColorize(ByVal search$, ByVal scope%, ByVal PartialMatch As Boolean, ByVal CaseSensitive As Boolean)

	Dim MyEntity As Entity
	Dim MyEntityDisplay As EntityDisplay
	Dim iLog%, iNbFound%

	iLog = UBound(laLogs) + 1

	ReDim Preserve laLogs(iLog + 4)
	laLogs(iLog) = " "
	laLogs(iLog + 1) = "String to search: " & search
	laLogs(iLog + 2) = "Scope: " & IIf(scope = 1, "Current model", IIf(scope = 2, "All models", "Current submodel"))
	laLogs(iLog + 3) = "Partial match: " & PartialMatch
	laLogs(iLog + 4) = "Case sensitive: " & CaseSensitive

	' Update the display
	DlgListBoxArray("mlbLogs", laLogs)

	Set MyModel = MyDiagram.ActiveModel
	bLogical = MyModel.Logical

	If bLogical Then
		
		sParent = "Entity"
		sChild = "Attribute"

	Else
		
		sParent = "Table"
		sChild = "Column"

	End If

	Set MySubModel = MyModel.ActiveSubModel

	iNbFound = 0

	Select Case scope
	Case 1 ' Current model
		For Each MyEntity In MyModel.Entities
			
			iNbFound = iNbFound + CheckEntity(MyEntity, search$, PartialMatch , CaseSensitive)

		Next MyEntity
	Case 2 ' All models
		For Each MyModel In MyDiagram.Models
			
			bLogical = MyModel.Logical
		
			If bLogical Then
				
				sParent = "Entity"
				sChild = "Attribute"
		
			Else
				
				sParent = "Table"
				sChild = "Column"
		
			End If

			For Each MyEntity In MyModel.Entities

				iNbFound = iNbFound + CheckEntity(MyEntity, search$, PartialMatch , CaseSensitive)

			Next MyEntity

		Next MyModel
	Case Else ' Current submodel
		For Each MyEntityDisplay In MySubModel.EntityDisplays

			Set MyEntity = MyEntityDisplay.ParentEntity

			iNbFound = iNbFound + CheckEntity(MyEntity, search$, PartialMatch , CaseSensitive)

		Next MyEntityDisplay
	End Select

	iLog = UBound(laLogs) + 1

	ReDim Preserve laLogs(iLog + 1)
	laLogs(iLog) = " "
	laLogs(iLog + 1) = "Colorized " & IIf(scope = 2, "Attributes and Column", sChild) & "s: " & iNbFound

	' Update the display
	DlgListBoxArray("mlbLogs", laLogs)

End Sub

Private Function IsMatch(ByVal source$, ByVal search$, ByVal PartialMatch As Boolean, ByVal CaseSensitive As Boolean) As Boolean

	Dim res As Boolean

	If Not CaseSensitive Then
		
		source = UCase(source)
		search = UCase(search)

	End If

	If PartialMatch Then

		res = InStr(source, search) <> 0

	Else
		
		res = (source = search)

	End If

	IsMatch = res

End Function

Private Function CheckEntity(ByRef MyEntity As Entity, ByVal search$, ByVal PartialMatch As Boolean, ByVal CaseSensitive As Boolean) As Integer

	Dim MyAttribute As AttributeObj
	Dim iNbFound%

	iNbFound = 0

	' Check Attributes
	For Each MyAttribute In MyEntity.Attributes

		If IsMatch(MyAttribute.AttributeName, search, PartialMatch, CaseSensitive) Or IsMatch(MyAttribute.ColumnName, search, PartialMatch, CaseSensitive) Then
			
			MyAttribute.Color = RGB(CByte(DlgText("tbR")), CByte(DlgText("tbG")), CByte(DlgText("tbB")))
			ReDim Preserve laLogs(UBound(laLogs) + 1)
			laLogs(UBound(laLogs)) = sChild & " " & IIf(bLogical, MyAttribute.AttributeName, MyAttribute.ColumnName) & " in "  & sParent & " " & IIf(bLogical, MyEntity.EntityName, MyEntity.TableName)
			iNbFound = iNbFound + 1

			' Update the display
			DlgListBoxArray("mlbLogs", laLogs)

		End If

	Next MyAttribute

	CheckEntity = iNbFound

End Function

Private Sub UpdateColorPreview()
	
	CreateColoredPixelBitmap(CByte(DlgText("tbR")), CByte(DlgText("tbG")), CByte(DlgText("tbB")))
	DlgSetPicture("pColor", bmpFile, 0)

End Sub

Private Sub SetColorsFromHexField()

	Dim s$, l&

	' Convert Hexa to bytes/colors
	s = DlgText("tbHexa")
	l = Val("&H" & Mid(s, 1, 2))
	DlgText("tbR", "" & l)
	l = Val("&H" & Mid(s, 3, 2))
	DlgText("tbG", "" & l)
	l = Val("&H" & Mid(s, 5, 2))
	DlgText("tbB", "" & l)

End Sub

Private Function BGR2RGB(bgr$) As String

	Dim res$

	res = bgr

	While Len(res) < 6
		res = "0" & res
	Wend

	res = Mid(res, 5, 2) & Mid(res, 3, 2) & Mid(res, 1, 2)

	BGR2RGB = res

End Function

Private Function GetHexValueFromDefaultColor(colorIndex%) As String

	GetHexValueFromDefaultColor = BGR2RGB(Hex(QBColor(colorIndex)))

End Function

Private Function GetHexValue(tbSource$) As String
	
	Dim res$

	res = Hex$(DlgText(tbSource))
	If Len(res) = 1 Then
		res = "0" & res
	End If

	GetHexValue = res

End Function

Private Sub CheckValues()
	
	Const tbSources = Array("tbR", "tbG", "tbB")

	Dim s$, i%, l&

	On Error GoTo e

	For Each s In tbSources

		DlgText(s, CStr(CInt(DlgText(s))))

		i% = CInt(DlgText(s))

		If i < 0 Or i > 255 Then
			
			DlgText(s, "128")

		End If

	Next

	On Error GoTo eh
	s = DlgText("tbHexa")
	If (Left(s, 1) = "#") And (Len(s) > 1) Then
		s = Right(s, Len(s) - 1)
	End If
	If Len(s) = 3 Then
		s = Left(s, 1) & Left(s, 1) & Mid(s, 2, 1) & Mid(s, 2, 1) & Right(s, 1) & Right(s, 1)
	End If
	If Len(s) > 6 Then
		s = Left(s, 6)
	End If
	l = Val("&H" & s)
	s = Hex(l)
	While Len(s) < 6
		s = "0" & s
	Wend
	DlgText("tbHexa", s)

	Exit Sub

	e:
		DlgText(s, "0")
		Err.Clear
		Resume Next

	eh:
		DlgText("tbHexa", GetHexValue("tbR") & GetHexValue("tbG") & GetHexValue("tbB"))
		Err.Clear
		Resume Next

End Sub

Private Sub CreateColoredPixelBitmap(r As Byte, g As Byte, b As Byte)

	' Create a BMP of 1 pixel with a specific color
	Dim fileNum As Integer
	Dim v%, l&, by As Byte	' 2|4|1 bits

	On Error Resume Next
	If Dir(bmpFile) <> "" Then
	
		Kill(bmpFile)

	End If

	fileNum = FreeFile()
	Open bmpFile For Binary As #fileNum

	l = 3820866
	Put #fileNum, , l

	l = 268435456
	l = 0
	Put #fileNum, , l

	l = 3538944
	Put #fileNum, , l

	l = 2621440
	Put #fileNum, , l

	l = 65536
	Put #fileNum, , l
	Put #fileNum, , l
	Put #fileNum, , l

	l = 24
	Put #fileNum, , l

	l = 262144
	Put #fileNum, , l

	l = 0
	Put #fileNum, , l
	Put #fileNum, , l
	Put #fileNum, , l
	Put #fileNum, , l
	v = 0
	Put #fileNum, , v

	Put #fileNum, , b
	Put #fileNum, , g
	Put #fileNum, , r

	by = 0
	Put #fileNum, , by

	Close #fileNum

End Sub

As usual, feel free to modify the script so that it perfectly meets your expectations, or just copy the parts of this one to your own macros.

Bonus

A short video which shows how to create a macro from a script in ER/Studio Data Architect: