OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   CorelDRAW/Corel DESIGNER VBA (http://forum.oberonplace.com/forumdisplay.php?f=16)
-   -   Swap the colors of shapes (http://forum.oberonplace.com/showthread.php?t=24585)

nic 02-01-2013 05:47

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


FaneDuru 02-01-2013 10:30

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...

nic 03-01-2013 06:58

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


shelbym 03-01-2013 10:38

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

nic 03-01-2013 12:01

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

shelbym 03-01-2013 12:11

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.

nic 03-01-2013 13:56

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

nic 03-01-2013 15:02

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


shelbym 03-01-2013 15:16

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

nic 04-01-2013 04:39

Thanks Shelby - very neat.


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

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