#1




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 
#2




Firstly, in order to generate random numbers between 1 and 'tot' you must use the next line:
Code:
R = Int((tot) * Rnd + 1) '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 
#3




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 
#4




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 
#5




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 
#6




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.

#7




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 
#8




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; 04012013 at 04:35. Reason: question posed not useful 
#9




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 
#10




Thanks Shelby  very neat.
Last edited by nic; 05112013 at 19:33. Reason: I reread it sometime later and couldnt understand what i meant when i wrote it 
Tags 
color shape swap 
Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)  
Thread Tools  Search this Thread 
Display Modes  


Similar Threads  
Thread  Thread Starter  Forum  Replies  Last Post 
macro to swap paint & fill colors  Jeff Harrison  Corel PhotoPaint VBA  1  10022010 00:51 
256 colors  Nico  General  0  26042007 03:10 
Change colors  cmjmmrp  General  0  02042007 08:17 
Spot Colors  shelbym  CorelDRAW/Corel DESIGNER VBA  0  01102005 20:58 
CDR12 ?Bug?: HSB Colors  zlatev  CorelDRAW/Corel DESIGNER VBA  2  22022005 14:21 