structo Posted December 3, 2016 Share Posted December 3, 2016 (edited) 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 Edited December 4, 2016 by structo Quote Link to comment Share on other sites More sharing options...
structo Posted December 7, 2016 Author Share Posted December 7, 2016 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. Quote Link to comment Share on other sites More sharing options...
BIGAL Posted December 8, 2016 Share Posted December 8, 2016 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. Quote Link to comment Share on other sites More sharing options...
hanhphuc Posted December 8, 2016 Share Posted December 8, 2016 maybe this -> similar thread? Quote Link to comment Share on other sites More sharing options...
structo Posted December 12, 2016 Author Share Posted December 12, 2016 maybe this -> similar thread? Thank you han friend, i have tried but not worked. kindly help me regarding lisp routine. Thank you all. Quote Link to comment Share on other sites More sharing options...
hanhphuc Posted December 12, 2016 Share Posted December 12, 2016 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 Quote Link to comment Share on other sites More sharing options...
maratovich Posted December 12, 2016 Share Posted December 12, 2016 If this is the VBA ? DimRectangles.zip Quote Link to comment Share on other sites More sharing options...
structo Posted December 13, 2016 Author Share Posted December 13, 2016 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 Quote Link to comment Share on other sites More sharing options...
structo Posted December 13, 2016 Author Share Posted December 13, 2016 If this is the VBA ? hi Marat, thank you for your contribution. while loading your code showing error as attached image. Thank you. Quote Link to comment Share on other sites More sharing options...
maratovich Posted December 13, 2016 Share Posted December 13, 2016 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 Quote Link to comment Share on other sites More sharing options...
structo Posted December 13, 2016 Author Share Posted December 13, 2016 Is macro VBARun : 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. Quote Link to comment Share on other sites More sharing options...
maratovich Posted December 13, 2016 Share Posted December 13, 2016 2 - Only select 3 - Available all or a selection DimRectangles 2.zip DimRectangles 3.zip Quote Link to comment Share on other sites More sharing options...
structo Posted December 13, 2016 Author Share Posted December 13, 2016 2 - Only select3 - Available all or a selection Greetings friend, thank you very much, excellent working. great contribution. Thanking you all for supporting. Quote Link to comment Share on other sites More sharing options...
maratovich Posted December 13, 2016 Share Posted December 13, 2016 good luck Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.