Como extrair a cor de preenchimento de uma entidade no Excel com um script de VB

Olá a todos,

Tenho um script de vb que percorre todos os modelos de dados lógicos abertos e extrai os dados do modelo em uma planilha do Excel, como modelo, entidade, atributo, comentários, atributo(s) estendido(s), etc. O que está sendo difícil para mim é extrair a cor de preenchimento da entidade, que é necessária para a análise. Abaixo está o meu script completo. Alguém poderia ajudar? Obrigado antecipadamente.
----------------------------------
Option Explicit
Dim nb
Dim HaveExcel
Dim x1
Dim mdl ' o modelo atual
Dim models ' a coleção de modelos

HaveExcel= False
Dim RQ
RQ = MsgBox ("O Excel está instalado na sua máquina?", vbYesNo + vbInformation,"Confirmação")
if RQ= VbYes then
HaveExcel= True
Set x1 = CreateObject("Excel.Application")
x1.Visible = True
x1.Workbooks.Add
x1.Range("A1").Value = "Nome do Modelo"
x1.Range("B1").Value = "Nome da Classe"
x1.Range("C1").Value = "Nome do Objeto"
x1.Range("D1").Value = "Código do Objeto"
x1.Range("E1").Value = "Comentários do Objeto"
x1.Range("F1").Value = "Nome do Atributo"
x1.Range("G1").Value = "Atributo ExtendidoX"
end If

Set models = Application.Models
if models.Count = 0 then
MsgBox ("Não há modelos no espaço de trabalho atual.")
end if

Dim sheetIndex
sheetIndex = 1
For Each mdl In models
nb = 2
If sheetIndex > 1 Then
x1.Worksheets.Add , x1.Worksheets(sheetIndex - 1)
End If
x1.Worksheets(sheetIndex).Name = "LDM_" & sheetIndex

With x1.Worksheets(sheetIndex)
x1.Range("A1").Value = "Nome do Modelo"
x1.Range("B1").Value = "Nome da Classe"
x1.Range("C1").Value = "Nome do Objeto"
x1.Range("D1").Value = "Código do Objeto"
x1.Range("E1").Value = "Comentários do Objeto"
x1.Range("F1").Value = "Nome do Atributo"
x1.Range("G1").Value = "Atributo ExtendidoX"
End With

ListObjects(mdl)

if HaveExcel= True Then
x1.Worksheets(sheetIndex).Columns("A:G").EntireColumn.AutoFit
end if
sheetIndex = sheetIndex + 1
Next

Sub ListObjects(fldr)
Dim obj ' objeto em execução
For Each obj In fldr.Children
DescribeObject obj
Next

Dim f ' pasta em execução
For Each f In fldr.Packages
ListObjects f
Next
End Sub

Sub DescribeObject(CurrentObject)
if CurrentObject.ClassName ="Vínculo de Clase de Asociación" then exit sub
if HaveExcel= True Then 'Exportar informação para o documento do Excel
If CurrentObject.ClassName = "Entidade" Then
Dim attr
Dim hasAttributes
hasAttributes = (CurrentObject.Attributes.Count > 0)

If hasAttributes Then
For Each attr In CurrentObject.Attributes
WriteToExcel CurrentObject, attr
Next
Else
WriteToExcel CurrentObject, Nothing
End If
Else
WriteToExcel CurrentObject, Nothing
End If
End If
End Sub

Sub WriteToExcel(obj, attr)
x1.Range("A" & Cstr(nb)).Value = mdl.Name
x1.Range("B" & Cstr(nb)).Value = obj.ClassName
x1.Range("C" & Cstr(nb)).Value = obj.Name
x1.Range("D" & Cstr(nb)).Value = obj.Code
x1.Range("E" & Cstr(nb)).Value = obj.Comment
If Not attr is Nothing Then
x1.Range("F" & Cstr(nb)).Value = attr.Name
Else
x1.Range("F" & Cstr(nb)).Value = ""
End If

Dim extAttribute
extAttribute = ""
If obj.HasExtendedAttribute("Atributo ExtendidoX") Then
extAttribute = obj.GetExtendedAttribute("Atributo ExtendidoX")
End If