OberonPlace.com Forums  

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

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 30-06-2009, 06:44
beczukdavid
Guest
 
Posts: n/a
Question Please revise my code

Is it to messy?

Code:
Global box_x As Double
Global box_y As Double
Global Shape_rx As Double
Global x As Double
Global y As Double
Global x1 As Double
Global in_x As Double

Sub Bound_box()
Dim i
Dim Layer_PB As Boolean

ActivePage.Shapes().All.CreateSelection

i = 0

Do While i < ActivePage.Layers.Count
       i = i + 1
       ActivePage.Layers(i).Activate
       If ActiveLayer.Name = "PB" Then
       Layer_PB = True
       End If
Loop

If Layer_PB = True Then
    Create_bx2              ' if active layer name is "PB" then we create only boxes
    Else
    Create_bx               ' if active layer name is not "PB" then we create layer
    End If

End Sub

' Create Layer PB

Function Create_bx()
    ActivePage.CreateLayer "PB"
    Create_bx2
End Function

' Activate Layer and make boxes

Function Create_bx2()
            
    in_x = 10
          
    Shape_rx = ActiveSelection.RightX
    ActiveDocument.Unit = cdrMillimeter
    ActiveDocument.ActivePage.GetSize box_x, box_y
    ActivePage.Layers("PB").Activate
    RL = Shape_rx
    x = Shape_rx + in_x
    y = box_y - in_x
    x1 = box_y
    
    ActiveLayer.CreateRectangle RL, x1, x, y, 0, 0, 0, 0
    ActiveLayer.CreateRectangle 0, 0, in_x, in_x, 0, 0, 0, 0
    ActiveLayer.Shapes.All.ApplyUniformFill CreateCMYKColor(0, 0, 0, 100)
    ActiveLayer.Shapes.All.SetOutlineProperties (0)
    ActiveLayer.Shapes.All.Group
End Function
Reply With Quote
  #2  
Old 30-06-2009, 07:02
beczukdavid
Guest
 
Posts: n/a
Question

I have a problem with Shape_rx variable

Why dose it keep the same value even if i don't have any objects on the page?
Reply With Quote
  #3  
Old 01-07-2009, 17:34
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
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 Slightly Differnt

Here is my slightly different version. As you will see I use a Function to look for the layer and if it can't find it creates it.
Code:
Sub Bound_box()
    Const in_x As Double = 10
    Dim srAll As ShapeRange, srBoxes As New ShapeRange
    Dim lr As Layer, doc As Document
    Dim box_x As Double, box_y As Double, Shape_rx As Double
    Dim x As Double, x1 As Double, y As Double
        
    Set doc = ActiveDocument
    Set srAll = doc.ActivePage.Shapes.All
    doc.Unit = cdrMillimeter
    doc.ActivePage.GetSize box_x, box_y
    Shape_rx = srAll.RightX
    
    x = Shape_rx + in_x
    y = box_y - in_x
    x1 = box_y
 
    Set lr = FindLayer(ActivePage, "PB")
    lr.Activate
    
    srBoxes.Add lr.CreateRectangle(Shape_rx, x1, x, y)
    srBoxes.Add lr.CreateRectangle(0, 0, in_x, in_x)
    
    srBoxes.ApplyUniformFill CreateCMYKColor(0, 0, 0, 100)
    srBoxes.SetOutlineProperties 0
    srBoxes.Group
End Sub

Function FindLayer(ByVal pg As Page, ByVal Name As String) As Layer
    Dim LayerFound As Layer
    Dim lr As Layer
    
    Set LayerFound = Nothing
    
    For Each lr In pg.Layers
        If lr.Name = Name Then
            Set LayerFound = lr
            Exit For
        End If
    Next lr
    
    If LayerFound Is Nothing Then
        Set LayerFound = ActivePage.CreateLayer(Name)
    End If
    
    Set FindLayer = LayerFound
End Function
Best of luck,

-Shelby
Reply With Quote
  #4  
Old 02-07-2009, 00:15
beczukdavid
Guest
 
Posts: n/a
Smile

Thank you for your time

Yours its much more cleaner
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
Installation code for lumiere! snobber General 0 25-09-2008 10:22
[useful code] wOxxOm CorelDRAW/Corel DESIGNER VBA 0 19-12-2007 15:00
[useful code] sortDelimitedText wOxxOm CorelDRAW/Corel DESIGNER VBA 0 19-12-2007 14:51
v11 code in v13 diwin CorelDRAW/Corel DESIGNER VBA 5 26-06-2007 18:43
Why does this code run so slow? Webster CorelDRAW/Corel DESIGNER VBA 3 20-03-2007 05:18


All times are GMT -5. The time now is 19:51.


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