OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > Code Critique

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 12-04-2007, 00:40
JudyHNM
Guest
 
Posts: n/a
Default 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?

Code:
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
Reply With Quote
  #2  
Old 12-04-2007, 09:34
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

Judy,

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

Code:
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:

Code:
colDupe.CopyAssign colColor
This will eliminate the need for that dummy shape in the document.
Reply With Quote
  #3  
Old 12-04-2007, 12:23
JudyHNM
Guest
 
Posts: n/a
Default Thank you

Thanks, Alex. I appreciate the feedback. I made the changes, and it worked great.
Reply With Quote
  #4  
Old 15-08-2007, 22:16
Malik641
Guest
 
Posts: n/a
Default

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.

Quote:
Originally Posted by JudyHNM View Post
Code:
'====================================================================================
' 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:
Code:
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
Quote:
Originally Posted by JudyHNM View Post
Code:
        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:

Code:
' 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.

Quote:
Originally Posted by JudyHNM View Post
Code:
'====================================================================================
' 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 :-) :
Code:
XLSheet.Range("A:B,D:D,F:F").EntireColumn.AutoFit
XLSheet.Range("C:C,E:E").EntireColumn.ColumnWidth = 5
Quote:
Originally Posted by JudyHNM View Post
Code:
'====================================================================================
' Save Spreadsheet
'====================================================================================

    XLSheet.SaveAs "C:\pantone.xls"

    MsgBox "Found " & lngCount & " colors"
    
End Sub
Thanks, Judy
What happened to:
Code:
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.
Reply With Quote
  #5  
Old 16-08-2007, 08:42
JudyHNM
Guest
 
Posts: n/a
Default Thank you

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
Reply With Quote
  #6  
Old 16-08-2007, 09:57
Malik641
Guest
 
Posts: n/a
Default

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).
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Cannot use Curveworks macros in a user witten macro??? jon46089 CurveWorks 2 02-03-2006 14:18
Help with Replace Macro Pumpkin_Masher Macros/Add-ons 1 21-09-2005 14:41
An Idea for a handy and easy to make macro vallentin Macros/Add-ons 2 16-03-2004 11:35
New macro to clip curves w.r.t. a border Gerard Hermans Macros/Add-ons 0 09-06-2003 07:50
Speeding up a macro Rick Randall CorelDRAW/Corel DESIGNER VBA 2 12-12-2002 10:51


All times are GMT -5. The time now is 22:51.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2021, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com