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 05-02-2008, 14:47
WernerHo
Guest
 
Posts: n/a
Default Create Rectangle-Shape with positioning

Hi Everybody
I'm looking for a solution for the following Problem:
I have documents with different kinds of rectangles and text. What I want to do is to get the position and the size of each of these rectangles and create a new Rectangle with exact the same position and size but with other line properties and then delete the first rectangle.
What I have is:
Code:
Sub typ()
Dim shp As Shape
Dim shpneu As Shape
Dim pos As String
Dim styp As Byte
Dim sel As ShapeRange
Dim hoch As Double, breit As Double, posh As Double, posl As Double
For Each shp In ActivePage.Shapes
If shp.Type = 3 Then
hoch = shp.SizeHeight
breit = shp.SizeWidth
posh = shp.PositionX
posl = shp.PositionY
Set shp = ActiveLayer.CreateRectangle(posl, posh, (posl + breit), (posh + hoch))
shp.Outline.SetProperties 0.003
End If
Next shp
End Sub
This creates a new Rectangle with the right size but the Position is different and I don't understand why?
Anybody out there who has an Idea??
Greetings
Werner
Reply With Quote
  #2  
Old 06-02-2008, 03:34
Gadget
Guest
 
Posts: n/a
Default

If you are deleting the origional, why not just set it's outline?
Code:
Sub typ()
Dim shp As Shape
For Each shp In ActivePage.Shapes
   If shp.Type = 1 Then shp.Outline.SetProperties 0.003
Next shp
End Sub
(Btw rectangle is type 1)

Alternitivly you could try this:

Code:
Sub typ()
    Dim shp As Shape
    Dim shpneu As Shape
    Dim DblL, DblR, DblT, DblB As Double
    For Each shp In ActivePage.Shapes
        If shp.Type = cdrRectangleShape Then
            DblT = shp.TopY
            DblB = shp.BottomY
            DblR = shp.RightX
            DblL = shp.LeftX
            Set shpneu = ActiveLayer.CreateRectangle(DblL, DblT, DblR, DblB)
            shpneu.Outline.SetProperties 0.003
            shp.Delete
        End If
    Next shp
End Sub

Last edited by Gadget; 06-02-2008 at 03:37.
Reply With Quote
  #3  
Old 06-02-2008, 03:40
WernerHo
Guest
 
Posts: n/a
Default

Hi Everybody
no need anymore to think about. I got it.
Code:
Sub typ()
Dim shp As Shape
Dim gr As ShapeRange
Dim shpneu As Shape
Dim pos As String
Dim styp As Byte
Dim sel As ShapeRange
Dim hoch As Double, breit As Double, posh As Double, posl As Double
Dim OrigSelection As ShapeRange
ActiveLayer.Paste
    Set OrigSelection = ActiveSelectionRange
    Dim grp1 As ShapeRange
    ActiveSelection.Ungroup
For Each shp In ActivePage.Shapes
If shp.Type = 3 Then
hoch = shp.SizeHeight
breit = shp.SizeWidth
posh = shp.PositionX
posl = shp.PositionY
Set shpneu = ActiveLayer.CreateRectangle(posl, posh, (posl + breit - 0.006), (posh + hoch - 0.006))
shpneu.PositionX = posh
shpneu.PositionY = posl
With shpneu.Outline
        .Type = cdrOutline
        .Width = 0.003
        .Color.CMYKAssign 0, 100, 100, 0
        .NibStretch = 100
        .NibAngle = 0#
        .BehindFill = False
        .ScaleWithShape = False
        .LineCaps = 0
        .LineJoin = 0
    End With
shp.Delete
End If
Next shp
End Sub
Thank you all for reading the thread.
Greetings
Werner
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
[DrawX3] RectangleFixer not working!!! wOxxOm Macros/Add-ons 6 12-11-2007 12:41
Checking If Artistic Text is on a rectangle shape knowbodynow CorelDRAW/Corel DESIGNER VBA 2 16-04-2007 17:47
CorelDRAW X3 VBA Code - Shape & Color LIster JudyHNM Code Critique 2 05-04-2007 14:02
Any idea what's wrong with this shape? jemmyell CorelDRAW/Corel DESIGNER VBA 4 08-05-2006 18:15
activeselection cloning s_federici CorelDRAW/Corel DESIGNER VBA 2 05-11-2004 09:59


All times are GMT -5. The time now is 23:46.


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