Results 1 to 4 of 4

Thread: Drawing Customised Rectangle

  1. #1
    Active Member
    Join Date
    2008-07
    Posts
    78
    Login to Give a bone
    0

    Default Drawing Customised Rectangle

    Hello all,

    I am after some help with creating a vba macro to create a rectangle with some additional adjustable lines. I have attached a drawing showing what I need to achieve.

    Basically I need to be able to click any point as a start point and then any other point as an end point to create the rectangle. The width is constant, any arbitary value will do, but the length will be dependant on the start and end points. Dimension 'A' will also be an arbitary value from the center of the line.

    If anyone can help me out with the easiest way to achive this, I would be very greatful.

    Thanks
    Attached Files Attached Files

  2. #2
    AUGI Addict fixo's Avatar
    Join Date
    2005-05
    Location
    Pietari, Venäjä
    Posts
    1,269
    Login to Give a bone
    0

    Default Re: Drawing Customised Rectangle

    I have the similar one on what you need
    Just had a slightly edited to your suit
    Change the layer name for detail and for dimensions
    See comments inside the code

    Code:
    Option Explicit
    
    Const dblWidth As Double = 141.42 '<--change the constant width of roll here
    Const pi As Double = 3.14159265358979
    
    Sub DrawDetail()
    
    Dim pt1 As Variant, pt2 As Variant
    Dim pt3 As Variant, pt4 As Variant
    Dim pt5 As Variant, pt6 As Variant
    Dim pt7 As Variant, pt8 As Variant
    Dim lpt1 As Variant, lpt2 As Variant
    Dim lpt3 As Variant, lpt4 As Variant
    Dim dp1 As Variant, dp2 As Variant
    Dim dp3 As Variant, dp4 As Variant
    
    Dim ang As Double
    Dim dblGap As Double
    Dim oLine  As AcadLine
    Dim oDim As AcadDimAligned
    
    Dim strColor As String
    Dim intOsm As Integer
    Dim strLayer As String
    
    With ThisDrawing
    
    intOsm = .GetVariable("OSMODE")
    strColor = .GetVariable("CECOLOR")
    strLayer = .GetVariable("CLAYER")
    
    .SetVariable "OSMODE", 0
    .SetVariable "CLAYER", "ANNO-DETAIL" '<--change the layer name for detail here
    .SetVariable "CECOLOR", "256"
    
    pt1 = .Utility.GetPoint(, vbCr & " >> Pick first point: ")
    pt2 = .Utility.GetPoint(pt1, vbCr & " >> Pick second point: ")
    
    dblGap = CDbl(InputBox(vbCr & "Enter offset distance (shown as " & """A""" & "):", "Custom Rectang", "25"))
    
    ang = .Utility.AngleFromXAxis(pt1, pt2)
    pt3 = .Utility.PolarPoint(pt1, ang + (pi / 2), dblWidth / 2)
    pt4 = .Utility.PolarPoint(pt2, ang + (pi / 2), dblWidth / 2)
    pt5 = .Utility.PolarPoint(pt1, ang - (pi / 2), dblWidth / 2)
    pt6 = .Utility.PolarPoint(pt2, ang - (pi / 2), dblWidth / 2)
    
    lpt1 = .Utility.PolarPoint(pt1, ang + (pi / 2), dblGap)
    lpt2 = .Utility.PolarPoint(pt2, ang + (pi / 2), dblGap)
    lpt3 = .Utility.PolarPoint(pt1, ang - (pi / 2), dblGap)
    lpt4 = .Utility.PolarPoint(pt2, ang - (pi / 2), dblGap)
    
    dp1 = .Utility.PolarPoint(pt3, ang + (pi / 2), dblGap)
    dp2 = .Utility.PolarPoint(pt4, ang + (pi / 2), dblGap)
    dp3 = .Utility.PolarPoint(pt3, ang + pi, dblGap)
    dp4 = .Utility.PolarPoint(pt2, ang, dblGap)
    
    With .ModelSpace
    Set oLine = .AddLine(pt3, pt4)
    Set oLine = .AddLine(pt5, pt6)
    Set oLine = .AddLine(pt3, pt5)
    Set oLine = .AddLine(pt4, pt6)
    Set oLine = .AddLine(lpt1, lpt2)
    Set oLine = .AddLine(lpt3, lpt4)
    End With
    
    .SetVariable "CLAYER", "ANNO-DIM" '<--change the layer name for dimensions here
    
    With .ModelSpace
    Set oDim = .AddDimAligned(pt3, pt4, dp1)
    Set oDim = .AddDimAligned(pt3, pt5, dp3)
    Set oDim = .AddDimAligned(pt2, lpt2, dp4)
    Set oDim = .AddDimAligned(pt2, lpt4, dp4)
    End With
    
    .SetVariable "OSMODE", intOsm
    .SetVariable "CLAYER", strLayer
    .SetVariable "CECOLOR", strColor
    
    End With
    
    End Sub

    ~'J'~

  3. #3
    Active Member
    Join Date
    2008-07
    Posts
    78
    Login to Give a bone
    0

    Smile Re: Drawing Customised Rectangle

    Well Fixo, what can I say?

    This is brilliant...thank you very much.

    Your help is very much appreciated.

  4. #4
    AUGI Addict fixo's Avatar
    Join Date
    2005-05
    Location
    Pietari, Venäjä
    Posts
    1,269
    Login to Give a bone
    0

    Default Re: Drawing Customised Rectangle

    Glad if that helps
    Cheers

    ~'J'~

Similar Threads

  1. Replies: 6
    Last Post: 2011-04-25, 07:55 PM
  2. Replies: 3
    Last Post: 2009-04-15, 07:30 PM
  3. Drawing hatched rectangle
    By mathias2014 in forum AutoLISP
    Replies: 10
    Last Post: 2007-09-12, 03:59 PM
  4. rotate when drawing a rectangle
    By GuyR in forum Revit Architecture - Wish List
    Replies: 6
    Last Post: 2005-08-16, 06:33 AM
  5. CUSTOMISED TOOLBAR & SETTINGS
    By huuthu_nguyen82544 in forum AutoCAD LT - General
    Replies: 1
    Last Post: 2005-05-23, 01:08 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •