OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 02-01-2013, 05:47
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default Swap the colors of shapes

Hi
Im trying to randomly swap the colours of shapes in a document.
The code below is intended to loop through all the shapes and swap colour with a random shape but it fails with "Object variable or with block variable not set" at the line

c = sr(n).Fill.UniformColor '

Any help appreciated.

Thanks
Nic


Code:
Sub swapcolours()

Dim s As Shape
Dim sr As ShapeRange

Dim n As Double    ' loop counter

Dim R As Single    ' random shape
Dim tot As Single  ' total number of shapes

Dim c As Color     ' looping shapes original color
Dim d As Color     ' random shapes original color

Optimization = True
tot = ActivePage.Shapes.Count
Set sr = ActiveLayer.Shapes.All

For n = 1 To tot      ' loop thru all the shapes in order

    R = Int(Rnd(tot)) ' select a random shape

c = sr(n).Fill.UniformColor ' looping shapes color
d = sr(R).Fill.UniformColor ' random shapes color

sr(n).Fill.ApplyUniformFill d
sr(R).Fill.ApplyUniformFill c

Next n

Optimization = False
End Sub
Reply With Quote
  #2  
Old 02-01-2013, 10:30
FaneDuru FaneDuru is offline
Member
 
Join Date: May 2012
Posts: 35
Default

Firstly, in order to generate random numbers between 1 and 'tot' you must use the next line:
Code:
R = Int((tot) * Rnd + 1)
Rnd returns a value less than 1 but greater than or equal to zero.
'To produce random integers in a given range, use this formula:
Int((upperbound - lowerbound + 1) * Rnd + lowerbound) - where, upperbound is the highest number in the range, and lowerbound is the lowest number in the range.'

Secondly, 'Color' is a class - an object and must be referenced using 'Set'. To nominate a shape inside a shapeRange you must use 'sr.Shapes(n)'... The line for color definition must be:
Code:
Set c = sr.Shapes(n).Fill.UniformColor ' looping shapes color
Set d = sr.Shapes(R).Fill.UniformColor ' random shapes color
I hope this helps...
Reply With Quote
  #3  
Old 03-01-2013, 06:58
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default

Thanks for your help FaneDuru, it gave me enough to make it work. It's rather inelegant but this worked

Code:
Sub swapcolors()

Dim sr As ShapeRange

Dim r As Single, g As Single, b As Single    'rgb values of shapes
Dim r2 As Single, g2 As Single, b2 As Single

Dim n As Double    ' loop counter
Dim rn As Single   ' random shape number
Dim tot As Single  ' total number of shapes

Set sr = ActiveLayer.Shapes.All
tot = sr.Count

Optimization = True

For n = 1 To tot              ' loop thru all the shapes in order
    rn = Int(Rnd * (tot)) + 1 ' select a random shape

'get the rgb values of both shapes

With sr.Shapes(n).Fill.UniformColor
        If .Type = cdrColorRGB Then
            r = .RGBRed
            g = .RGBGreen
            b = .RGBBlue
        End If
    End With
    
With sr.Shapes(rn).Fill.UniformColor
        If .Type = cdrColorRGB Then
            r2 = .RGBRed
            g2 = .RGBGreen
            b2 = .RGBBlue
        End If
    End With
    
'swap their colours
    
sr.Shapes(n).Fill.UniformColor.RGBAssign r2, g2, b2
sr.Shapes(rn).Fill.UniformColor.RGBAssign r, g, b

Next n

Optimization = False
ActiveWindow.Refresh
End Sub
Reply With Quote
  #4  
Old 03-01-2013, 10:38
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,788
Blog Entries: 12
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Swap the Colors of Shapes

You could modify this a bit to support all filltypes:
Code:
Sub swapcolors()
    Dim sr As ShapeRange
    
    Dim f As Fill 'Temp copy of fill
    
    Dim n As Long    ' loop counter
    Dim rn As Long   ' random shape number
    Dim tot As Long  ' total number of shapes
    
    Set sr = ActiveLayer.Shapes.All
    tot = sr.Count
    
    Optimization = True
        
        For n = 1 To tot              ' loop thru all the shapes in order
            rn = Int(Rnd * (tot)) + 1 ' select a random shape
            
            Set f = sr(n).Fill 'Save a copy of the fill
            sr(n).Fill.CopyAssign sr(rn).Fill 'Copy the fill from the randon shape
            sr(rn).Fill.CopyAssign f 'Apply the saved fill from the first shape
        Next n
    
    Optimization = False
    ActiveWindow.Refresh
End Sub
-Shelby
Reply With Quote
  #5  
Old 03-01-2013, 12:01
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default

Hi Shelby
thanks - but I think there's a mistake in the code - if I run the macro in X6 a few times then I can see that the colour swap is not working right in that it ends up with one (random) colour being spread to many shapes.

Ive had a look and think it might be to do with the .fill giving the type of fill rather than the colour but I have been unable to get it to work - (no surprise there).

Thanks again
nic
Reply With Quote
  #6  
Old 03-01-2013, 12:11
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,788
Blog Entries: 12
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Random

Remember that you are picking a random shape, so if your sample is small the chance of the same shape being selected multiple times it high. A better way to approach this would be to remove the shapes from a shape range if they have already been swapped. This way you would not get duplicates, and it would also run faster, as you are only looping remaining shapes.
Reply With Quote
  #7  
Old 03-01-2013, 13:56
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default

Hi Shelby
Swapping each time you do do twice as many swaps as needed but you should end up with all the same colors just on different objects. I think what seems to be happening is because the color is not copied over in one of the swaps but the fill type. Ill get back once Ive had another look.
Best wishes
nic
Reply With Quote
  #8  
Old 03-01-2013, 15:02
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default Better - uniform fill

Hi

this seems to work - the loop is a hash from an older thread re:copying colours to/from outlines/fills.

Im hoping the temp object will not interfere with the process because it is created after the tot variable is set and should therefore never be selected either as (n) or (r n) ?

Code:
Sub swapcolors3()
    Dim sr As ShapeRange
    
    Dim n As Long    ' loop counter
    Dim rn As Long   ' random shape number
    Dim tot As Long  ' total number of shapes
    Dim t As Shape   ' temp shape to hold colour
    
    Set sr = ActiveLayer.Shapes.All
    tot = sr.Count
    
    Optimization = True
    'create temp shape
    Set t = ActiveLayer.CreateEllipse2(0, 0, 1)
      
    For n = 1 To tot               ' loop thru all the shapes in order
    rn = Int(Rnd * (tot)) + 1      ' select a random shape
    
    'Swap shape(n) and (rn) colours
    'COPY _ to - - - - - - - - - - from
    t.Fill.ApplyUniformFill sr.Shapes(rn).Fill.UniformColor
    sr.Shapes(rn).Fill.ApplyUniformFill sr.Shapes(n).Fill.UniformColor
    sr.Shapes(n).Fill.ApplyUniformFill t.Fill.UniformColor
    
    Next n
     
    'delete temp shape
    t.Delete
    
    Optimization = False
    ActiveWindow.Refresh
End Sub

Last edited by nic; 04-01-2013 at 03:35. Reason: question posed not useful
Reply With Quote
  #9  
Old 03-01-2013, 15:16
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,788
Blog Entries: 12
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Swap the colors of shapes

You don't need to create a shape, you can just store the color:
Code:
Sub swapcolors3()
    Dim sr As ShapeRange
    
    Dim n As Long    ' loop counter
    Dim rn As Long   ' random shape number
    Dim tot As Long  ' total number of shapes
    Dim c As New Color   ' temp shape to hold colour
    
    Set sr = ActiveLayer.Shapes.All
    tot = sr.Count
    
    Optimization = True
      
        For n = 1 To tot               ' loop thru all the shapes in order
        rn = Int(Rnd * (tot)) + 1      ' select a random shape

        c.CopyAssign sr.Shapes(rn).Fill.UniformColor
        sr.Shapes(rn).Fill.ApplyUniformFill sr.Shapes(n).Fill.UniformColor
        sr.Shapes(n).Fill.ApplyUniformFill c
        
        Next n
    
    Optimization = False
    ActiveWindow.Refresh
End Sub
-Shelby
Reply With Quote
  #10  
Old 04-01-2013, 04:39
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default

Thanks Shelby - very neat.

Last edited by nic; 05-11-2013 at 18:33. Reason: I reread it sometime later and couldnt understand what i meant when i wrote it
Reply With Quote
Reply

Tags
color shape swap


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
macro to swap paint & fill colors Jeff Harrison Corel Photo-Paint VBA 1 09-02-2010 23:51
256 colors Nico General 0 26-04-2007 02:10
Change colors cmjmmrp General 0 02-04-2007 07:17
Spot Colors shelbym CorelDRAW/Corel DESIGNER VBA 0 01-10-2005 19:58
CDR12 ?Bug?: HSB Colors zlatev CorelDRAW/Corel DESIGNER VBA 2 22-02-2005 13:21


All times are GMT -5. The time now is 23:18.


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