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