CD X3 Macro Writing to Excel Spreadsheet

I am running CD X3, MS Excel 2003, XP, SP2

I have created the macro and it runs successfully. It reads the Pantone Corel 8 palette and writes all the Pantone names and numbers, along with the CYMK and RGB equivalents into the Excel spreadsheet. I have some questions and would also appreciate comments on the code.

1. The only way I could get this to work was to have a CD document with one shape on it when I started the macro. Is there an option?

2. It seems like it runs slowly -- is that my code?

3. PANTONE Trans. White CV shows up multiple times in the list -- it always has an index number of 952, but the CYMK and RGB equivalents are different each time. Any idea what's going on?

4. There are gaps in the Pantone index numbers. Is that an issue?

Sub ListColorInfo()

'====================================================================================
' Date: 04/11/07
' Author: Judy Hudgins
' Purpose:  This procedure reads the Pantone Corel 8 palette and creates an Excel
'           spreadsheet with the index value, the Pantone color, the CYMK value,
'           and the RGB value
'====================================================================================

    Dim XLSheet     As Object
    Dim XLApp       As Object
    Dim colColor    As Color
    Dim colDupe     As New Color
    Dim palPalette  As Palette
    Dim lngCount    As Long
    Dim strPantone  As String
    Dim strCYMK     As String
    Dim strRGB      As String
    Dim strTitle    As String
    
'====================================================================================
' Delete existing spreadsheet
'   err.number 53 will occur if the file does not already exist
'   err.number 70 will occur if the file is open in Excel
'====================================================================================

    strTitle = "Pantone, CMYK, RGB List"
    
    On Error Resume Next
        Kill "c:\pantone.xls"
        If Err.Number = 53 Then
            'continue process
        ElseIf Err.Number = 70 Then
            MsgBox "Excel file is open" & vbCrLf & "Process Cancelled", vbOKOnly + vbExclamation, strTitle
            Exit Sub
        End If

'====================================================================================
' Set Environment and variables
'====================================================================================
    Set XLSheet = CreateObject("Excel.sheet")
    Set XLApp = XLSheet.Application

    lngCount = 0
    
'====================================================================================
' Write Spreadsheet Headings
'====================================================================================

    With XLApp.activesheet.pagesetup
        .printtitlerows = "$1:$2"
        .CenterHeader = "&""Arial,bold""&Pantone Corel 8, CYMK, RGB"
        .RightHeader = "Revised: &D"
        .LeftFooter = "&T"
        .RightFooter = "Page &P of &N"
        .Orientation = 2
        .LeftMargin = XLApp.InchesToPoints(0)
        .RightMargin = XLApp.InchesToPoints(0)
    End With
    
    With XLApp.Range("C:C")
        .HorizontalAlignment = -4131
        .VerticalAlignment = -4107
    End With

'====================================================================================
' Write Column Headings
'====================================================================================

    XLApp.Range("a1").Select
    XLApp.ActiveCell.formular1c1 = "Index"
    XLApp.Selection.Font.FontStyle = "Bold"
    
    XLApp.Range("b1").Select
    XLApp.ActiveCell.formular1c1 = "Pantone"
    XLApp.Selection.Font.FontStyle = "Bold"
    
    XLApp.Range("d1").Select
    XLApp.ActiveCell.formular1c1 = "CYMK"
    XLApp.Selection.Font.FontStyle = "Bold"
    
    XLApp.Range("f1").Select
    XLApp.ActiveCell.formular1c1 = "RGB"
    XLApp.Selection.Font.FontStyle = "Bold"
    
'==================================================================================
' Check to see if Pantone Corel 8 palette is open.  If not, open it
'==================================================================================
    
    For Each palPalette In Palettes
        If palPalette.Type = cdrFixedPalette Then
            If palPalette.PaletteID = cdrPANTONECorel8 Then
                Exit For
            End If
        End If
    Next palPalette
    
    If palPalette Is Nothing Then
        Set palPalette = Palettes.OpenFixed(cdrPANTONECorel8)
    End If
    
'==================================================================================
' Loop through Pantone Color 8 palette and print color name, CYMK and RGB
' equivalent
'==================================================================================
    
    For Each colColor In palPalette.Colors
             
        ActiveShape.Fill.UniformColor = colColor
        
        'Convert to CYMK
        colDupe.CopyAssign ActiveShape.Fill.UniformColor
        colDupe.ConvertToCMYK
        
        strCYMK = colDupe.Name(True)
        
        'Convert to RGB
        
        colDupe.CopyAssign ActiveShape.Fill.UniformColor
        colDupe.ConvertToRGB
        
        strRGB = colDupe.Name(True)
        
        lngCount = lngCount + 1
     
        ' Write to spreadsheet
       
        XLApp.ActiveCell.Offset(rowoffset:=1, columnOffset:=-5).Activate
        XLApp.ActiveCell.formular1c1 = colColor.PaletteIndex
        XLApp.ActiveCell.Offset(rowoffset:=0, columnOffset:=1).Activate
        XLApp.ActiveCell.formular1c1 = colColor.Name
        XLApp.ActiveCell.Offset(rowoffset:=0, columnOffset:=2).Activate
        XLApp.ActiveCell.formular1c1 = strCYMK
        XLApp.ActiveCell.Offset(rowoffset:=0, columnOffset:=2).Activate
        XLApp.ActiveCell.formular1c1 = strRGB
        
        XLApp.ActiveCell.Offset(rowoffset:=1, columnOffset:=-5).Activate
                
    Next colColor

'====================================================================================
' Format Columns
'====================================================================================
    
    XLApp.Range("A:A").Select
    XLApp.Selection.EntireColumn.AutoFit
    
    XLApp.Range("B:B").Select
    XLApp.Selection.EntireColumn.AutoFit
    
    XLApp.Range("C:C").Select
    XLApp.Selection.EntireColumn.ColumnWidth = 5
    
    XLApp.Range("D:D").Select
    XLApp.Selection.EntireColumn.AutoFit
    
    XLApp.Range("E:E").Select
    XLApp.Selection.EntireColumn.ColumnWidth = 5
    
    XLApp.Range("F:F").Select
    XLApp.Selection.EntireColumn.AutoFit

'====================================================================================
' Save Spreadsheet
'====================================================================================

    XLSheet.SaveAs "C:\pantone.xls"

    MsgBox "Found " & lngCount & " colors"
    
End Sub

Thanks, Judy

[Alex]

Judy,

First, you are using a shape to convert the pantone color to CMYK and RGB:

ActiveShape.Fill.UniformColor = colColor
colDupe.CopyAssign ActiveShape.Fill.UniformColor

There is no need for that. You can just create a copy of the palette color and convert it, without applying it to a shape first:

colDupe.CopyAssign colColor

This will eliminate the need for that dummy shape in the document.

Thanks, Alex. I appreciate the feedback. I made the changes, and it worked great.

Hi Judy,

To answer #2, I say it is most likely your code that is making things a little slow. For example, using .Select and .Activate for Excel VBA slow down code pretty well. Also using a lot of OLE references (the dot between the words in code) will slow you down some as well. If you can use With --- End With statements I would recommend doing so. There's a very nice article about how to optimize Excel VBA code here if you would like to have a look.

Originally Posted by JudyHNM

'====================================================================================
' Write Column Headings
'====================================================================================

    XLApp.Range("a1").Select
    XLApp.ActiveCell.formular1c1 = "Index"
    XLApp.Selection.Font.FontStyle = "Bold"
    
    XLApp.Range("b1").Select
    XLApp.ActiveCell.formular1c1 = "Pantone"
    XLApp.Selection.Font.FontStyle = "Bold"
    
    XLApp.Range("d1").Select
    XLApp.ActiveCell.formular1c1 = "CYMK"
    XLApp.Selection.Font.FontStyle = "Bold"
    
    XLApp.Range("f1").Select
    XLApp.ActiveCell.formular1c1 = "RGB"
    XLApp.Selection.Font.FontStyle = "Bold"

You don't need to use .Select and .FormulaR1C1 for what you're doing. You are simply adding values to the spreadsheet. Also, you should use XLSheet rather than XLApp when working with the Sheet object. Using XLApp should (I believe) default to the "ActiveSheet", leaving you less control of what happens to your Excel Application instance. So a simpler (and faster) way to go would be:

With XLSheet
.Range("A1").Value = "Index"
.Range("B1").Value = "Pantone"
.Range("D1").Value = "CYMK"
.Range("F1").Value = "RGB"
.Range("A:B,D:D,F:F").Font.FontStyle = "Bold"
End WIth

Originally Posted by JudyHNM

        lngCount = lngCount + 1
     
        ' Write to spreadsheet
       
        XLApp.ActiveCell.Offset(rowoffset:=1, columnOffset:=-5).Activate
        XLApp.ActiveCell.formular1c1 = colColor.PaletteIndex
        XLApp.ActiveCell.Offset(rowoffset:=0, columnOffset:=1).Activate
        XLApp.ActiveCell.formular1c1 = colColor.Name
        XLApp.ActiveCell.Offset(rowoffset:=0, columnOffset:=2).Activate
        XLApp.ActiveCell.formular1c1 = strCYMK
        XLApp.ActiveCell.Offset(rowoffset:=0, columnOffset:=2).Activate
        XLApp.ActiveCell.formular1c1 = strRGB
        
        XLApp.ActiveCell.Offset(rowoffset:=1, columnOffset:=-5).Activate

The last line in this statement confuses me. You should get an error if you were to find more than one Color because when you first start this procedure, you select F1 last before getting to this block of code. When you get here, you Activate A2, then move to B2, D2, F2, then A3 before looping. So when the next loop occurs, you will try to move down one row, and 5 cells to the left, which is impossible at this point. Looking at your code again, you never reset the Err object like "On Error Goto 0", so any errors that you would run into are ignored. So when the loop goes around again, it will ignore the first offset(1,-5) piece of code. It works and all, but it's not a good practice. And to me, using offset and Activate creates too much overhead and is confusing. You should try using the Cells() property instead. Like so:

' Write to spreadsheet
lngCount = lngCount + 1
' If you used my code above, you will still be in cell "A1"
' Using Cells(Row,Column) will be very useful using the lngCount
' that you have here.
With XLSheet
    .Cells(lngCount + 1, "A").Value = colColor.PaletteIndex
    .Cells(lngCount + 1, "B").Value = colColor.Name
    .Cells(lngCount + 1, "D").Value = strCYMK
    .Cells(lngCount + 1, "F").Value = strRGB
End With

So the lngCount takes care of the amount of colors you have and which row you are currently working with in the loop.

Originally Posted by JudyHNM

'====================================================================================
' Format Columns
'====================================================================================
    
    XLApp.Range("A:A").Select
    XLApp.Selection.EntireColumn.AutoFit
    
    XLApp.Range("B:B").Select
    XLApp.Selection.EntireColumn.AutoFit
    
    XLApp.Range("C:C").Select
    XLApp.Selection.EntireColumn.ColumnWidth = 5
    
    XLApp.Range("D:D").Select
    XLApp.Selection.EntireColumn.AutoFit
    
    XLApp.Range("E:E").Select
    XLApp.Selection.EntireColumn.ColumnWidth = 5
    
    XLApp.Range("F:F").Select
    XLApp.Selection.EntireColumn.AutoFit

This can be broken down into 2 lines of code :-) :

XLSheet.Range("A:B,D:D,F:F").EntireColumn.AutoFit
XLSheet.Range("C:C,E:E").EntireColumn.ColumnWidth = 5

Originally Posted by JudyHNM

'====================================================================================
' Save Spreadsheet
'====================================================================================

    XLSheet.SaveAs "C:\pantone.xls"

    MsgBox "Found " & lngCount & " colors"
    
End Sub

Thanks, Judy

What happened to:

XLApp.Quit
Set XLSheet = Nothing
Set XLApp = Nothing

??? You should definitely close it (.Quit) because otherwise it remains in memory, eating up your resources. The "Set ... = Nothing" is arguable that you don't have to do that since VBA has a method of keeping track of Object references and frees the memory once they leave scope and there are no more references to that particular address in memory.

I hope this will help you. I know it's been a while since there has been a post here, but this will surely make your code run faster.

Thank you so much for the very useful feedback. That's exactly the type of information that I am looking for. I appreciate your time.

Judy

I'm just glad you checked it!

And I'm glad you find it useful. If you have any more questions regarding Excel VBA, I'm more than happy to help (I do a lot more Excel VBA than CorelDraw VBA, fyi).