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 11-05-2008, 04:50
vindaa
Guest
 
Posts: n/a
Default Actual Replace

I have a drawing with approximately 3 thousand circles in red and black and I have realized the circles in red are distorted.

I would like to replace all the selected red circles (which I can easily select using 'select objects with same fill' macro) with a new circle.

The new circle should be aligned to the center of old distorted circle.

I have tried the below code by WoXXom but hear the new circle takes dimensions of the old circle so it does not solve my purpose.
I think a little change in this macro can solve my problem.

Thanx in advance
--------------
Sub scatter()
Dim sh As Shape, sr As ShapeRange, x#, y#, w#, h#, i&
Dim AgentSmith As Shape, VSR As ShapeRange

If ActiveDocument Is Nothing Then Exit Sub
Set sr = ActiveSelection.Shapes.FindShapes()
If sr.Count = 0 Then
MsgBox "Select target objects, invoke the macro, click Agent Smith shape"
Exit Sub
End If
If ActiveDocument.GetUserClick(x, y, i, -1, Snap:=false, CursorShape:=313) Then _
Exit Sub

With ActivePage.SelectShapesAtPoint(x, y, SelectUnfilled:=True)
If .Shapes.Count = 0 Then Beep: Exit Sub
Set AgentSmith = .Shapes(.Shapes.Count)
End With

Set VSR = New ShapeRange
ActiveDocument.ReferencePoint = cdrCenter
For Each sh In sr
sh.GetBoundingBox x, y, w, h
With AgentSmith.TreeNode.GetCopy
.VirtualShape.SetBoundingBox x, y, w, h, KeepAspect:=True
.LinkAsChildOf sh.Layer.TreeNode
VSR.Add .VirtualShape
End With
Next

ActiveDocument.LogCreateShapeRange VSR
sr.delete ' evaporate originally selected shapes
End Sub
----------
Reply With Quote
  #2  
Old 11-05-2008, 14:11
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,770
Blog Entries: 10
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 ClearTransformations

Instead of making new circles, you might want to just clear the transformations. This will clear rotation, skew and stretch.
Code:
Sub ClearMyTransformations()
    Dim s As Shape
    Dim sr As ShapeRange
    
    Set sr = ActiveSelection.Shapes.FindShapes()
    
    For Each s In sr
        s.ClearTransformations
    Next s
End Sub
Guess you do not need a script for this, I tried selecting all the shapes and then Pressing Arrange| Clear Transformations and it will do all the objects at once also.

Why type of distortion does your shapes have???

-Shelby

Last edited by shelbym; 11-05-2008 at 14:20.
Reply With Quote
  #3  
Old 11-05-2008, 19:34
vindaa
Guest
 
Posts: n/a
Default Hi somehow it does not apply in this case

Well you are right but in this case it does not work, the probabilities are
1. I might have originally drawn an incorrect ellipse (0.0605 mm X 0.060 mm) so the clear transformation would not work, or else
2. In the process of drawing at some stage I might have welded the circles and then broken them apart.
3. Also it might be because I had used bled tool to place several group of circles on different paths and then separated them. (which automatically converts the ellipse into curves)

So I think only replacing the object with a new one will work. ( also some of this circles are rotated along center point of another object.)

Thanx
Reply With Quote
  #4  
Old 13-05-2008, 12:37
dungbtl
Guest
 
Posts: n/a
Default

w0x's code above is wickedly fast.

It would be cool to be able to input a desired size for the selected objects intended.

Is that possible?
Reply With Quote
  #5  
Old 13-05-2008, 15:11
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,770
Blog Entries: 10
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 What size??

Quote:
Originally Posted by vindaa View Post
Well you are right but in this case it does not work, the probabilities are
1. I might have originally drawn an incorrect ellipse (0.0605 mm X 0.060 mm) so the clear transformation would not work, or else
Thanx
So when the new ellipse is create what size is it suppose to be, the larger or smaller??

-Shelby
Reply With Quote
  #6  
Old 13-05-2008, 23:57
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,770
Blog Entries: 10
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 Another thought...

Quote:
So I think only replacing the object with a new one will work. ( also some of this circles are rotated along center point of another object.)
Thanx
Why not draw a circle as you object. Then select it. All your selected object are then replaced with a perfect circle. Unless I missed something.

-Shelby
Reply With Quote
  #7  
Old 14-05-2008, 19:52
vindaa
Guest
 
Posts: n/a
Default Replacing circles

The new circle would have 0.03 mm as its Radius.
Reply With Quote
  #8  
Old 14-05-2008, 21:06
vindaa
Guest
 
Posts: n/a
Default I think I am almost their

I just made some guess work and change few lines in WoXXom's code. I am almost getting what I want.
But the only problem is that the new circle is not placed at the center on old object but to the bottom left corner of the old circle.

What can I do to have new circle to the center of old circle
-------------------------------------
Sub scatter()
Dim sh As Shape, sr As ShapeRange, x#, y#, w#, h#, i&
Dim AgentSmith As Shape, VSR As ShapeRange

If ActiveDocument Is Nothing Then Exit Sub
Set sr = ActiveSelection.Shapes.FindShapes()
If sr.Count = 0 Then
MsgBox "Select target objects, invoke the macro, click Agent Smith shape"
Exit Sub
End If
If ActiveDocument.GetUserClick(x, y, i, -1, Snap:=False, CursorShape:=313) Then _
Exit Sub

With ActivePage.SelectShapesAtPoint(x, y, SelectUnfilled:=True)
If .Shapes.Count = 0 Then Beep: Exit Sub
Set AgentSmith = .Shapes(.Shapes.Count)
End With

Set VSR = New ShapeRange
ActiveDocument.ReferencePoint = cdrCenter
For Each sh In sr
sh.GetBoundingBox x, y, 0.00236, 0.00236
With AgentSmith.TreeNode.GetCopy
.VirtualShape.RotationAngle = sh.RotationAngle
.VirtualShape.SetBoundingBox x, y, 0.00236, 0.00236, KeepAspect:=True
.LinkAsChildOf sh.Layer.TreeNode
VSR.Add .VirtualShape
End With
Next

ActiveDocument.LogCreateShapeRange VSR
sr.Delete ' evaporate originally selected shapes
End Sub
Reply With Quote
  #9  
Old 18-05-2008, 12:50
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,770
Blog Entries: 10
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 Replace Ellipses

I know this code is not as cool as that of the great Os, but it might do the trick for you. Basically it finds all the Ellipses and creates new ones.
Code:
Sub replaceEllipses()
    Dim srEllipses As ShapeRange
    Dim x As Double, y As Double
    Dim hRad As Double, vRad As Double
    Dim srNewEllipses As New ShapeRange
    Dim s As Shape
    
    Set srEllipses = ActivePage.FindShapes(Type:=cdrEllipseShape)
    
    For Each s In srEllipses
        s.Ellipse.GetCenterPosition x, y 'Get the center of the Ellipse
        s.Ellipse.GetRadius hRad, vRad 'Get the Radius of the current Ellipse
        srNewEllipses.Add ActiveLayer.CreateEllipse2(x, y, hRad) 'Create the Ellipse and add it to our ShapeRange
    Next s
    
    srEllipses.Delete 'Delete
End Sub
I hope it helps, let me know if you have any problems. I have only test this under X4.

-Shelby
Reply With Quote
  #10  
Old 19-05-2008, 19:18
vindaa
Guest
 
Posts: n/a
Default Thanks but it does not work for me

Well as I have said that the ellipse are no longer ellipse, they are now circles, that is, they have been converted to curves. So corel draw no longer identifies them as ellipse.

What can I do ?

Thanx
Reply With Quote
Reply


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
Is there a way to replace Corel draw defalt photo editor Rakeshspatial CorelDRAW/Corel DESIGNER VBA 26 15-11-2008 20:02
Replace color admold CorelDRAW/Corel DESIGNER VBA 4 18-08-2008 18:04
How to import values from a file, replace text,save file for each value with new name amaart CorelDRAW/Corel DESIGNER VBA 1 28-09-2007 12:41
Help with Replace Macro Pumpkin_Masher Macros/Add-ons 1 21-09-2005 14:41
Find and Replace Text with Form RVogel CorelDRAW/Corel DESIGNER VBA 1 24-03-2005 09:37


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


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