Auto Dimension to selected rectangles

Hi Friends,

i have several rectangles. i need auto dimension upon selected rectangles as shown in sample drawing format. please help by lisp routine.

condition is 1)if my drawing in inches text height should be 4"

2) if my drawing in meters, text height should be 0.1

Thanks.

for rectangle dimension.dwg

Hi friends,

i got this code from google.

(defun C:demo (/ centpt coords elist en hgt p1 p2 p3 ss)

(command "_.zoom" "_e")
 (if (zerop (getvar "dimtxt"))
        (setq hgt 2.5)
        (setq hgt (getvar "dimtxt")))
 (if
(setq ss (ssget  (list (cons 0  "LWPOLYLINE")(cons 70  1)(cons 90  4))))

(while
 (setq en (ssname ss 0))
 (setq elist (entget en))
 (setq coords (vl-remove-if (function not)(mapcar (function (lambda(x)(if (= 10 (car x))(cdr x))))elist)))
 (setq CentPt (mapcar (function (lambda(a b)(/ (+ a b )2)))(car coords )(caddr coords))
   )
(setq coords (vl-sort Coords (function (lambda(a b)(> (angle CentPt a)(angle CentPt b))))))
 (setq p1 (cadr coords)p2(caddr coords) p3(last coords))
(command "._dimlinear" "_non" p1"_non" p2"_non" (polar p2 pi (* 1 hgt)) )
 (command "._dimlinear" "_non" p2"_non" p3"_non" (polar p3 (/ pi 2) (* 1 hgt)) )
 (ssdel en ss))
(command "_.zoom" "_p")
)

(princ)
 )

in this code dimension text was developed with current Dim style. my requirement is text should be developed with out association of current dim style ( no need dim lines, Ext lines etc.).

Zoom extents by this code also no need, please remove.

text should be developed if units in inches then text height should be 4".

text should be developed if units in meters then text height should be 0.1.

please edit above code for auto dimensions for rectangles.

Thank you.

please edit above code for auto dimensions for rectangles.

Checks in the mail !

Structo cadtutor is a voluntary forum not a please do all these for me so I can save time, I noticed other posts also in other forums. Its about time to have a go yourself.

maybe this -> similar thread?

maybe this -> similar thread?

Thank you han friend,

i have tried but not worked. kindly help me regarding lisp routine.

Thank you all.

1)if my drawing in inches text height should be 4"

2) if my drawing in meters, text height should be 0.1

Thanks.

IMO regardless in meters or inches units text height will not change

i have tried but not worked. kindly help me regarding lisp routine.

@BIGAL is right, Its about time to have a go yourself...

previous ppdim function try edit

snippet

(defun ppdim ( p1 p2 cw box / mp sz mx ); v1.1
;hanhphuc 31/10/2014
 
 (setq vs '(nil (/ (getvar 'viewsize) (cadr (getvar 'screensize))))
sz [color="red"] (* 0.05 (distance p1 p2))[/color] mp (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2)
)
...

Try to change it to 0.1

...
 (setq vs '(nil (/ (getvar 'viewsize) (cadr (getvar 'screensize))))
sz [color="red"][b]0.1[/b][/color] mp (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2)
)
...
...

or more generic.. to change size, command: textsize

...
sz [color="red"][b](getvar 'textsize)[/b][/color] mp
...

copy the c:test code as well to run it

If this is the VBA ?

DimRectangles.zip

IMO regardless in meters or inches units text height will not change

hi friend,

thank you for your guidance.should i merge "pdim" code and "test" code in to one? with you specified modifications?

Thank you

If this is the VBA ?

hi Marat,

thank you for your contribution. while loading your code showing error as attached image.

Thank you.

Is macro VBA

Run : Macro -> Load project -> DimRectangles.dvb

source code:

'Macro DimRectangles
' Autor Dmitry Kirillov
' www.kdmsoft.ru

Sub DimRectangles()
Dim Objsset As AcadSelectionSets
Dim Sset As AcadSelectionSet
Dim Entity As AcadLWPolyline
Dim minExt As Variant
Dim maxExt As Variant
Dim DeltaX As Double
Dim DeltaY As Double
Dim CentrX(0 To 2) As Double
Dim CentrY(0 To 2) As Double
Dim MTextObj As AcadMText
Dim Width As Double
Dim rotationAngle As Double
Dim textString As String
Dim UNITS As Integer
'----------------------------------------------------------------------------------+
UNITS = ThisDrawing.GetVariable("INSUNITS")
'MsgBox UNITS '1-inch ; 4-mm ; 6-m
'----------------------------------------------------------------------------------+
Set Objsset = ThisDrawing.SelectionSets
For Each Sset In Objsset
   If Sset.Name = CStr("TestSet") Then
       ThisDrawing.SelectionSets.Item(CStr("TestSet")).Delete
       Exit For
   End If
Next
'----------------------------------------------------------------------------------+
Set Sset = ThisDrawing.SelectionSets.Add("TestSet")
'----------------------------------------------------------------------------------+
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 0
FilterData(0) = "LWPOLYLINE"
Sset.Select acSelectionSetAll, , , FilterType, FilterData
'----------------------------------------------------------------------------------+
For Each Entity In Sset
   'MsgBox Entity.Length
   Entity.GetBoundingBox minExt, maxExt
   DeltaX = maxExt(0) - minExt(0)
   Width = DeltaX
   CentrX(0) = minExt(0) + (maxExt(0) - minExt(0)) / 2
   CentrX(1) = maxExt(1)
   CentrX(2) = 0
   textString = CStr(DeltaX)
   If UNITS = 1 Then textString = ConvertInchesToFeet(DeltaX)
   Set MTextObj = ThisDrawing.ModelSpace.AddMText(CentrX, Width, textString)
   MTextObj.AttachmentPoint = acAttachmentPointBottomCenter
   MTextObj.InsertionPoint = CentrX
   If UNITS = 1 Then MTextObj.Height = 4
   If UNITS = 6 Then MTextObj.Height = 0.1
   '----------------------------------------------------------------------------------+
   DeltaY = maxExt(1) - minExt(1)
   Width = DeltaY
   CentrY(0) = minExt(0)
   CentrY(1) = minExt(1) + (maxExt(1) - minExt(1)) / 2
   CentrY(2) = 0
   textString = CStr(DeltaY)
   If UNITS = 1 Then textString = ConvertInchesToFeet(DeltaY)
   Set MTextObj = ThisDrawing.ModelSpace.AddMText(CentrY, Width, textString)
   MTextObj.AttachmentPoint = acAttachmentPointBottomCenter
   MTextObj.InsertionPoint = CentrY
   rotationAngle = 1.5708
   MTextObj.Rotate CentrY, rotationAngle
   If UNITS = 1 Then MTextObj.Height = 4
   If UNITS = 6 Then MTextObj.Height = 0.1
   '----------------------------------------------------------------------------------+
Next Entity
'----------------------------------------------------------------------------------+
MsgBox "Done"
End Sub

Public Function ConvertInchesToFeet(Inches As Double) As String
 ConvertInchesToFeet = ThisDrawing.Utility.RealToString(Inches, acArchitectural, 6)
End Function

Is macro VBA

Run : Macro -> Load project -> DimRectangles.dvb

Excellent friend,

it is working.my request from your code is please add select rectangles option. because un wanted rectangle dimensions are developed. please add option for selecting.

Thanking you.

2 - Only select

3 - Available all or a selection

DimRectangles 2.zip

DimRectangles 3.zip

2 - Only select

3 - Available all or a selection

Greetings friend,

thank you very much, excellent working. great contribution.

Thanking you all for supporting.

good luck