ExcelToPMLColours/code.txt at master · land297/ExcelToPMLColours · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
Sub WriteDesCol()
    Dim fso As New FileSystemObject
    Dim stream As TextStream
    Set stream = fso.CreateTextFile(Application.ActiveWorkbook.Path & "\des-col.pmldat", True)

    Dim rgbDictionary As Dictionary
    Set rgbDictionary = CreateObject("Scripting.Dictionary")

    ceColour = ThisWorkbook.Worksheets(1).Cells(1, 2).Value
    activeColour = ThisWorkbook.Worksheets(1).Cells(2, 2).Value
    aidsColour = ThisWorkbook.Worksheets(1).Cells(3, 2).Value
    visibleColour = ThisWorkbook.Worksheets(1).Cells(4, 2).Value
    highlightColour = ThisWorkbook.Worksheets(1).Cells(5, 2).Value

    lastRow = ThisWorkbook.Worksheets(1).UsedRange.Rows.Count

    For i = 11 To lastRow
        r = ThisWorkbook.Worksheets(1).Cells(i, 8).Value
        g = ThisWorkbook.Worksheets(1).Cells(i, 9).Value
        b = ThisWorkbook.Worksheets(1).Cells(i, 10).Value

        If Len(r) > 0 And Len(g) > 0 And Len(b) > 0 Then
            rgbKey = r & "," & g & "," & b
            ' dictionary will make sure we do not store the same value several times
            ' https://excelmacromastery.com/vba-dictionary/
            rgbDictionary(rgbKey) = "RGB" & rgbKey
        End If
    Next i

    ' global array to store which colours have been loaded
    stream.WriteLine "!!excelLoadedColours = object array()"
    colourStartIndex = 80

    Dim Key As Variant
    ' will not change the first 100 default Aveva colours
    colourIndex = 100
    For Each Key In rgbDictionary.Keys()
        rgbValue = rgbDictionary(Key)
        'SET COLOUR 120 RBG224,225,120
        stream.WriteLine "SET COLOUR " & colourIndex & " " & rgbValue
        stream.WriteLine "!!excelLoadedColours.Append(|" & colourIndex & ";" & rgbValue & "|)"
        rgbDictionary(Key) = rgbValue & ";" & colourIndex
        colourIndex = colourIndex + 1
    Next Key

    stream.WriteLine ""
    stream.WriteLine "!!tmpGphColOpt.ce.colour(|" & ceColour & "|)"
    stream.WriteLine "!!tmpGphColOpt.active.colour(|" & activeColour & "|)"
    stream.WriteLine "!!tmpGphColOpt.aids.colour(|" & aidsColour & "|)"
    stream.WriteLine "!!tmpGphColOpt.visible.colour(|" & visibleColour & "|)"
    stream.WriteLine "!!tmpGphColOpt.highlight.colour(|" & highlightColour & "|)"
    stream.WriteLine ""
    stream.WriteLine "!tempArray = Array()"
    stream.WriteLine ""

    For i = 11 To lastRow
        ruleName = ThisWorkbook.Worksheets(1).Cells(i, 1).Value
        transpareny = ThisWorkbook.Worksheets(1).Cells(i, 5).Value
        edgeOn = ThisWorkbook.Worksheets(1).Cells(i, 6).Value
        colour = ThisWorkbook.Worksheets(1).Cells(i, 7).Value

        If colour = "" Then
            r = ThisWorkbook.Worksheets(1).Cells(i, 8).Value
            g = ThisWorkbook.Worksheets(1).Cells(i, 9).Value
            b = ThisWorkbook.Worksheets(1).Cells(i, 10).Value

            If Len(r) > 0 And Len(g) > 0 And Len(b) > 0 Then
                rgbKey = r & "," & g & "," & b
                Value = rgbDictionary(rgbKey)
                Data = Split(Value, ";")
                'Data(1) the number assigned to the rgb colour
                colour = Data(1)
            Else
                GoTo SkipRow:
            End If
        End If

        If ruleName = "" Then
            GoTo SkipRow:
        End If

        stream.WriteLine "!gphAutoColourRul = |" & ruleName & "|"
        stream.WriteLine "!gphAutoColTnslVal = " & transpareny
        stream.WriteLine "!gphAutoColEdgeOn = " & edgeOn
        stream.WriteLine "!gphAutoColourCol = object COLOUR(|" & colour & "|)"
        stream.WriteLine "!gphAutoColour    = object GPHAUTOCOLOUR(!gphAutoColourRul, !gphAutoColourCol, !gphAutoColTnslVal, !gphAutoColEdgeOn)"
        stream.WriteLine "!tempArray.Append(!gphAutoColour)"
        stream.WriteLine ""

SkipRow:

    Next i

    stream.WriteLine "!!tmpGphColOpt.autoColourRules = !tempArray"
    stream.WriteLine "!!tmpGphColOpt.autoColour = TRUE"
    stream.WriteLine "!!tmpGphColOpt.dynamicAutoColour = TRUE"

    stream.Close

End Sub

Sub WriteDesElementRules()
    Dim fso As New FileSystemObject
    Dim stream As TextStream
    Set stream = fso.CreateTextFile(Application.ActiveWorkbook.Path & "\des-element-rules.pmldat", True)

    lastRow = ThisWorkbook.Worksheets(1).UsedRange.Rows.Count

    For i = 11 To lastRow
        ruleName = ThisWorkbook.Worksheets(1).Cells(i, 1).Value
        ruleRule = ThisWorkbook.Worksheets(1).Cells(i, 2).Value
        ruleType = ThisWorkbook.Worksheets(1).Cells(i, 3).Value
        ruleDesc = ThisWorkbook.Worksheets(1).Cells(i, 4).Value

        If ruleName = "" Then
            GoTo SkipRow:
        End If


        stream.WriteLine "!rule             = object RULE()"
        stream.WriteLine "!rule.name        = |" & ruleName & "|"
        stream.WriteLine "!rule.rule        = |" & ruleRule & "|"
        stream.WriteLine "!rule.types       = |" & ruleType & "|"
        stream.WriteLine "!rule.description = |" & ruleDesc & "|"
        stream.WriteLine "!!tmpRuleArray.append(!rule)"
        stream.WriteLine ""
SkipRow:
    Next i

    stream.Close

End Sub


Sub RunAll()
    Call WriteDesCol
    Call WriteDesElementRules
End Sub

' <
' https://stackoverflow.com/questions/33179452/change-a-cells-background-color-dynamically-according-to-a-rgb-value-stored-in
' Tim Williams
'

Function myRGB(r, g, b)

    Dim clr As Long, src As Range, sht As String, f, v

    If IsEmpty(r) Or IsEmpty(g) Or IsEmpty(b) Then
        clr = vbWhite
    Else
        clr = RGB(r, g, b)
    End If

    Set src = Application.ThisCell
    sht = src.Parent.Name

    f = "Changeit(""" & sht & """,""" & _
                  src.Address(False, False) & """," & clr & ")"
    src.Parent.Evaluate f
    myRGB = ""
End Function

Sub ChangeIt(sht, c, clr As Long)
    ThisWorkbook.Sheets(sht).Range(c).Interior.Color = clr
End Sub

' />