OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > Code Critique

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 15-11-2004, 20:33
Anonymous
Guest
 
Posts: n/a
Default Rotate around a centre

This little application will rotate objects around a preset center or circles center. I wrote it in response to needing to accurately reproduce the Rotary Logo one day.

It determins the angle of rotation by dividing 360 degrees by the number of "notches" or objects required.

Note that the code that joins the curve at the end has been lifted from Alex's excellent Curve Effects application.

Enjoy, and comment!

This is the main code....
Code:
Option Explicit
Public CntrX As Double
Public CntrY As Double
Public st As Shape
Public s As Shape
Public sa As Shape
Public Ang As Double
Public Ang1 As Double
Public a As Long
Public SR As Shape
Public sc As Shape
Public e As Double, r As Double, nr As Double
Public sp As SubPath
Public sn As Node, en As Node, n1 As Node, n2 As Node
Public b As Boolean, maxsize As Double
Public sra As ShapeRange
Public ObId As Long
Public NumToRot As Long
Public CentObj As String
Public JoinObj As String
Public IDCurve As Shape
Public Shp2 As Shape
Public SR1 As New ShapeRange
Public num As Long
Public ObjNm As String

Sub OpenMainForm()
ActiveDocument.Unit = cdrMillimeter
FrmSetUp.Show vbModeless
End Sub

Sub DoItRoutine()

If CentObj = "True" Then
Unload GetCenter
End If

Ang1 = 360 / NumToRot
Ang = Ang1

Set sa = ActiveSelection.Shapes(1)
num = 1
ObjNm = "name" & num
ActiveShape.Name = (ObjNm)
For a = 1 To NumToRot - 1
    num = num + 1
        sa.Duplicate.Rotate (Ang)
        Ang = Ang + Ang1
    ObjNm = "name" & num
    ActiveShape.Name = (ObjNm)
Next a

If JoinObj = "True" Then
num = 0
Set Shp2 = ActiveLayer.FindShape(Name:=ObjNm)
SR1.Add Shp2

For a = 1 To NumToRot - 1
    num = num + 1
    ObjNm = "name" & num
       Set Shp2 = ActiveLayer.FindShape(Name:=ObjNm)
    SR1.Add Shp2
Next a
SR1.Combine.Name = (ObjNm)

' Closes an open multi-path curve by connecting closest open nodes of the subpaths. Next bit of code by Alex Valkulenko
    
    Set s = ActiveLayer.FindShape(Name:=ObjNm)
    If s.Type <> cdrCurveShape Then
        MsgBox "Curve must be selected"
        End
    End If
    ' E is autojoin limit beyond which the nodes are joined rather than connected
    ' Here assumed to be 1% of an average object size
    maxsize = s.SizeHeight
    If maxsize < s.SizeWidth Then maxsize = s.SizeWidth
    e = s.SizeHeight * s.SizeWidth / 10000
    Do
        Set sn = Nothing
        Set en = Nothing
        Set n1 = Nothing
        Set n2 = Nothing
        b = False
        For Each sp In s.Curve.Subpaths
            If Not sp.Closed Then
                Set n1 = sp.StartNode
                Set n2 = sp.EndNode
                nr = n1.GetDistanceFrom(n2)
                If nr < e And sp.Nodes.Count > 2 Then
                    n1.JoinWith n2
                    b = True
                Else
                    If sn Is Nothing Then
                        Set sn = n1
                        Set en = n2
                        If sp.Nodes.Count > 2 Then
                            r = nr
                        Else
                            r = maxsize
                        End If
                    Else
                        nr = sn.GetDistanceFrom(n1)
                        If nr < r Then
                            Set en = n1
                            r = nr
                        End If
                        nr = sn.GetDistanceFrom(n2)
                        If nr < r Then
                            Set en = n2
                            r = nr
                        End If
                    End If
                End If
            End If
            If b Then Exit For
        Next sp
        If Not b And Not sn Is Nothing Then
            If r < e Then sn.JoinWith en Else sn.ConnectWith en
            b = True
        End If
    Loop While b
End If
End Sub


This is the code associated with the forms....
Code:
Private Sub CommandButton10_Click()

Set s = ActiveShape
    If s Is Nothing Then
        MsgBox "Nothing Selected, select curve first"
        Exit Sub
    End If

Set IDCurve = ActiveShape
    
CentObj = FrmSetUp.ChkGetCent
JoinObj = FrmSetUp.ChkClsCrv
NumToRot = FrmSetUp.TxtNumRot

If CentObj = "True" Then
GetCenter.Show vbModeless
Else:
DoItRoutine
End If

End Sub

Select relationship to circle form "Select Ellipse".......
Code:
Private Sub CommandButton1_Click()

 Set st = ActiveShape
    If st.Type <> cdrEllipseShape Then
        MsgBox "Object must be an ellipse"
     Exit Sub
    End If
 
st.Ellipse.GetCenterPosition CntrX, CntrY

IDCurve.Selected = True
 
ActiveShape.SetRotationCenter CntrX, CntrY

DoItRoutine

End Sub
Attached Images
   
Reply With Quote
  #2  
Old 20-11-2004, 00:18
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default Re: Rotate around a centre

Very interesting, thanks for sharing.

However there is one thing I would change. Instead of using object name to go back to the shapes you generate and combine them I'd just simply set them into a range as I create them:

Code:
Set s = ActiveShape
SR1.Add s
For a = 1 To NumToRot - 1
    Set s = s.Duplicate
    s.Rotate Ang
    SR1.Add s
Next a
If JoinObj Then
    Set s = SR1.Combine

    If maxsize < s.SizeWidth Then maxsize = s.SizeWidth 
    e = s.SizeHeight * s.SizeWidth / 10000 
    ....
And another thing, why do you store Boolean values in Strings? Just curious...
Reply With Quote
  #3  
Old 23-11-2004, 17:02
Webster
Guest
 
Posts: n/a
Default

Thanks Alex.

I'll impliment that add to Shape Range method.

Mmmm, Boolean as string

Pasted the wrong bit of code. I'm a bit of a lazy, hack of a "programmer" and sometimes get values via message boxes to tweak development. Forgot to change from string to boolean in an early version.

Love the site, love the way everyone is so helpful and willing share. I've said it before - Alex you are providing a valuable service. A truely selfless act.

On behalf of everyone, Thank You!
Reply With Quote
  #4  
Old 14-01-2005, 17:07
Mark
Guest
 
Posts: n/a
Default Possibilites

One of my biggest beefs with CorelDraw has always been text having the same transformation matrix as the curve you fit it to. I have always had a need to scale text taller and arch it over a circle. I'm far from a good vba programmer & definitely out math-wise. How hard would it be to take a string of text, separate each character out, convert it to a curve, and then correctly position it to be arched over the circle with the each subsequent character. I may be asking for the impossible, but if you can figure that out, I think you'll be a CorelDraw hero for all users, especially if there's any way to leave the text string intact.
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
Special Rotate ddonnahoe CorelDRAW/Corel DESIGNER VBA 7 26-04-2004 12:20
Layer rotate without anti aliasing (PP11) joexx Corel Photo-Paint VBA 2 19-03-2004 01:08


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


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