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

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 