Cómo extraer el color de relleno de una entidad en Excel con un script de VB

Hola a todos,

Tengo un script de vb que recorre todos los modelos de datos lógicos abiertos y extrae los datos del modelo en una hoja de cálculo de Excel, como modelo, entidad, atributo, comentarios, atributo(s) extendido(s), etc. Lo que me está resultando difícil es extraer el color de relleno de la entidad, que es necesario para el análisis. A continuación se muestra mi script completo. ¿Alguien podría ayudar? Gracias de antemano.
----------------------------------
Option Explicit
Dim nb
Dim HaveExcel
Dim x1
Dim mdl ' el modelo actual
Dim models ' la colección de modelos

HaveExcel= False
Dim RQ
RQ = MsgBox ("¿Excel está instalado en su máquina?", vbYesNo + vbInformation,"Confirmación")
if RQ= VbYes then
HaveExcel= True
Set x1 = CreateObject("Excel.Application")
x1.Visible = True
x1.Workbooks.Add
x1.Range("A1").Value = "Nombre del Modelo"
x1.Range("B1").Value = "Nombre de la Clase"
x1.Range("C1").Value = "Nombre del Objeto"
x1.Range("D1").Value = "Código del Objeto"
x1.Range("E1").Value = "Comentarios del Objeto"
x1.Range("F1").Value = "Nombre del Atributo"
x1.Range("G1").Value = "Atributo ExtendidoX"
end If

Set models = Application.Models
if models.Count = 0 then
MsgBox ("No hay modelos en el espacio de trabajo actual.")
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 = "Nombre del Modelo"
x1.Range("B1").Value = "Nombre de la Clase"
x1.Range("C1").Value = "Nombre del Objeto"
x1.Range("D1").Value = "Código del Objeto"
x1.Range("E1").Value = "Comentarios del Objeto"
x1.Range("F1").Value = "Nombre del 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 en ejecución
For Each obj In fldr.Children
DescribeObject obj
Next

Dim f ' carpeta en ejecución
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 información al documento de Excel
If CurrentObject.ClassName = "Entidad" 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