OberonPlace.com Forums  

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

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 05-04-2007, 00:06
JudyHNM
Guest
 
Posts: n/a
Red face CorelDRAW X3 VBA Code - Shape & Color LIster

I am not new to programming, but I am painfully new to CorelDRAW VBA. I have written two very simple routines previously and would like to get some feedback on this third routine and accompanying function. It is meant to loop through all the pages, layers, and shapes in the active document and write each of the shapes, descriptions, fill colors, and outline colors to a text file. It is working.

I don't have any bells and whistles -- no prompting for filenames, checking for existence of file, etc. I am trying to get the basics and some feedback first.

Based on the preview of my email, I also don't understand the instructions for formatting the code properly; so, I would appreciate help on that also.

Code:
Sub ShapesColorCount()
'===================================================================================
' This routine loops through all the pages and layers of the active document and
' writes a description of each shape, along with the uniform fill and outline color
'===================================================================================

Dim myDoc As Document
Dim myPages As Page
Dim intI As Integer
Dim intJ As Integer
Dim intK As Integer
Dim intShapeCt As Integer
Dim intShapeType As Integer
Dim intButton As Integer
Dim intResponse As Integer
Dim strTitle As String
Dim strMessage As String
Dim strShapeName As String
Dim strText As String

'===================================================================================
' Open output file
'===================================================================================

Open "C:\Testfile.txt" For Output As #1

'===================================================================================
' Declare variables
'===================================================================================
intShapeCt = ActiveLayer.Shapes.Count
strTitle = "Color Lister"

'===================================================================================
' If there's no shape on the page, issue error and exit routine
'===================================================================================
If intShapeCt = 0 Then
strMessage = "There are no shapes"
intButton = vbOKOnly + vbExclamation
intResponse = MsgBox(strMessage, intButton, strTitle)
GoTo ExitRoutine
End If

'===================================================================================
' Set Environment
'===================================================================================
Set myDoc = ActiveDocument

'===================================================================================
'Main Process
' Loop through shapes on each layer on each page and write the shape name, fill
' color and outline color to a text file.
'===================================================================================
For intJ = 1 To myDoc.Pages.Count
For intK = 1 To myDoc.Pages(intJ).Layers.Count
For intI = 1 To intShapeCt
With ActiveLayer.Shapes(intI).Fill.UniformColor
intShapeType = .Type

'Call Function and pass shape number - function returns name
Call ShapeName(intShapeType, strShapeName)

strText = "Shape # " & intI & " " & strShapeName
Print #1, strText
strText = "Fill Color = " & .Name
Print #1, Tab(15); strText
strText = "Components = " & .Name(True)
Print #1, Tab(15); strText
End With
If ActiveLayer.Shapes(intI).Outline.Width = 0 Then
strText = "No outline"
Print #1, Tab(15); strText
Else
strText = "Outline Width = " & _
ActiveLayer.Shapes(intI).Outline.Width
Print #1, Tab(15); strText
strText = "Outline Color = " & _
ActiveLayer.Shapes(intI).Outline.Color.Name
Print #1, Tab(15); strText
End If
Next intI
Next intK
Next intJ

ExitRoutine:
Close #1

strMessage = "Process Complete"
intButton = vbOKOnly + vbInformation
intResponse = MsgBox(strMessage, intButton, strTitle)

End Sub

Sub ShapesColorCount()
'===================================================================================
' This routine loops through all the pages and layers of the active document and
' writes a description of each shape, along with the uniform fill and outline color
'===================================================================================

Dim myDoc As Document
Dim myPages As Page
Dim intI As Integer
Dim intJ As Integer
Dim intK As Integer
Dim intShapeCt As Integer
Dim intShapeType As Integer
Dim intButton As Integer
Dim intResponse As Integer
Dim strTitle As String
Dim strMessage As String
Dim strShapeName As String
Dim strText As String

'===================================================================================
' Open output file
'===================================================================================

Open "C:\Testfile.txt" For Output As #1

'===================================================================================
' Declare variables
'===================================================================================
intShapeCt = ActiveLayer.Shapes.Count
strTitle = "Color Lister"

'===================================================================================
' If there's no shape on the page, issue error and exit routine
'===================================================================================
If intShapeCt = 0 Then
strMessage = "There are no shapes"
intButton = vbOKOnly + vbExclamation
intResponse = MsgBox(strMessage, intButton, strTitle)
GoTo ExitRoutine
End If

'===================================================================================
' Set Environment
'===================================================================================
Set myDoc = ActiveDocument

'===================================================================================
'Main Process
' Loop through shapes on each layer on each page and write the shape name, fill
' color and outline color to a text file.
'===================================================================================
For intJ = 1 To myDoc.Pages.Count
For intK = 1 To myDoc.Pages(intJ).Layers.Count
For intI = 1 To intShapeCt
With ActiveLayer.Shapes(intI).Fill.UniformColor
intShapeType = .Type

'Call Function and pass shape number - function returns name
Call ShapeName(intShapeType, strShapeName)

strText = "Shape # " & intI & " " & strShapeName
Print #1, strText
strText = "Fill Color = " & .Name
Print #1, Tab(15); strText
strText = "Components = " & .Name(True)
Print #1, Tab(15); strText
End With
If ActiveLayer.Shapes(intI).Outline.Width = 0 Then
strText = "No outline"
Print #1, Tab(15); strText
Else
strText = "Outline Width = " & _
ActiveLayer.Shapes(intI).Outline.Width
Print #1, Tab(15); strText
strText = "Outline Color = " & _
ActiveLayer.Shapes(intI).Outline.Color.Name
Print #1, Tab(15); strText
End If
Next intI
Next intK
Next intJ

ExitRoutine:
Close #1

strMessage = "Process Complete"
intButton = vbOKOnly + vbInformation
intResponse = MsgBox(strMessage, intButton, strTitle)

End Sub


Thanks, Judy
Reply With Quote
  #2  
Old 05-04-2007, 01:45
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

Use 'code' button when posting to open a code block, then paste your code after the '[code]' tag that appears in message body, then immediately press the 'code' button again - this will insert '[/code]' - mandatory closing tag. Thus your formatting will be retained.

I recommend using 'For each myShape in ActivePage.FindShapes' instead of looping in cycle and accessing shapes by indexes. Also indexes should be described as long - who knows maybe your artwork will contain more than an integer type value can encompass (32767)?

In CorelDRAW v11 and above it is possible to iterate through all the shapes on the page without enumerating layers - Page.FindShapes method produces ShapeRange object that can be iterated using "For Each" loop. The default behaviour of .FindShapes is to return all shapes in plain unidimensional list even those shapes that are inside groups - so no ungrouping needed. The only exclusion is that since v12 VBA doesn't return shapes from inside powerclips - if any are used you should code an easy self-recursive function

I think that it is more convenient and more clear to write messagebox calls with the values right in the function call statement without prior assigning them to intermediate values - you know, it's not assembler :-) where you should explicitly load registers with values. The same goes for 'Print' statement - it is easier to read when you place text right in the statement

Of course, I will add again about Goto statement - the necessity of it is 1%, try not to use it

I think that for multilayer documents your assignment of shapes count before the loop will be inaccurate if there are layers with differing number of shapes, so it's better to analyze total number of shapes after the processing is done - moreover there could be pages with no shapes and other pages with shapes, so you can't decide beforehand if there are no shapes. Also this solves the problem of double messageboxes - one for "No shapes" and the other immediately after that - "Processing complete"

You can rely on new VBA engine (since v11) - it is VERY fast and quite powerful - I suggest that you peruse the forums, especially looking for Alex's messages with his code examples (diamonds however small they may be) - the true source of style and features of VBA object model and common understanding of processing organization. You can use either 'search forum' function or directly browsing messages in 'user profile'

I've restyled A LITTLE the first SUB.
Code:
Sub ShapesColorCount()
   '===================================================================================
   ' This routine loops through all the pages and layers of the active document and
   ' writes a description of each shape, along with the uniform fill and outline color
   '===================================================================================
   
   Dim myDoc As Document
   Dim myPages As Page
   Dim sh As Shape
   Dim pg As Page
   Dim intI As Long
   Dim intShapeCt As Integer
   Dim intShapeType As Integer
   Dim intButton As Integer
   Dim intResponse As Integer
   Dim strTitle As String
   Dim strMessage As String
   Dim strShapeName As String
   Dim strText As String
   
   '===================================================================================
   ' Open output file
   '===================================================================================
   
   Open "C:\Testfile.txt" For Output As #1
   
   '===================================================================================
   ' Declare variables
   '===================================================================================
   strTitle = "Color Lister"
   intShapeCt = 0 ' counter for total number of shapes on all pages
   
   '===================================================================================
   'Main Process
   ' Loop through shapes on each layer on each page and write the shape name, fill
   ' color and outline color to a text file.
   '===================================================================================
   
   
   For Each pg In ActiveDocument.Pages
      Print #1, "Page # " & CStr(pg.Index) & " " & pg.Name
      
      intI = 0 ' intial zeroing of each page's number of shapes processed
      For Each sh In pg.FindShapes
         intI = intI + 1
         With sh.Fill.UniformColor
            intShapeType = .Type
            
            'Call Function and pass shape number - function returns name
            Call ShapeName(intShapeType, strShapeName)
            
            Print #1, "Shape # " & intI & " " & strShapeName
            Print #1, Tab(15); "Fill Color = " & .Name
            Print #1, Tab(15); "Components = " & .Name(True)
         End With
         If sh.Outline.Width = 0 Then
            Print #1, Tab(15); "No outline"
         Else
            Print #1, Tab(15); "Outline Width = " & CStr(sh.Outline.Width)
            Print #1, Tab(15); "Outline Color = " & sh.Outline.Color.Name
         End If
      Next sh
      Print #1, 'newline
      intShapeCt = intShapeCt + intI 'update the total counter
   Next pg
   
'ExitRoutine
   
   Close #1
   
   '===================================================================================
   ' If there's no shape on the page, issue error - else show Process Complete
   '===================================================================================
   If intShapeCt = 0 Then
      MsgBox "There are no shapes", vbOKOnly + vbExclamation, strTitle
   Else
      MsgBox "Process Complete", vbOKOnly + vbInformation, strTitle
   End If
   
End Sub
Reply With Quote
  #3  
Old 05-04-2007, 15:02
JudyHNM
Guest
 
Posts: n/a
Default Thanks you

Thanks so much for the feedback -- I really appreciate it!
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
Where to begin with CorelDRAW and VBA shelbym CorelDRAW/Corel DESIGNER VBA 2 03-04-2007 10:15
Any idea what's wrong with this shape? jemmyell CorelDRAW/Corel DESIGNER VBA 4 08-05-2006 19:15
Howto uniquely identify a shape in VBA code jemmyell CorelDRAW/Corel DESIGNER VBA 9 11-02-2005 22:05
Text ENCODE Craig Tucker CorelDRAW/Corel DESIGNER VBA 10 26-01-2005 14:59
activeselection cloning s_federici CorelDRAW/Corel DESIGNER VBA 2 05-11-2004 10:59


All times are GMT -5. The time now is 11:52.


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