Jump to content

Existing user? Sign In
Sign In

Remember me Not recommended on shared computers

Forgot your password?
Sign Up

AutoLISP, Visual LISP & DCL

HotOffTheGrill lisp

macros55

By macros55
May 20 in AutoLISP, Visual LISP & DCL

Share

Recommended Posts

macros55

Contributor

macros55

Posted September 5

Author

- Share

Posted September 5 (edited)

(vl-load-com)
(mapcar
	'(lambda (x y / ) 
		(if (not (tblsearch "LAYER" x))
			(entmake
				(list
					'(0 . "LAYER")
					'(100 . "AcDbSymbolTableRecord")
					'(100 . "AcDbLayerTableRecord")
					(cons 2 x)
					'(70 . 0)
					(cons 62 y)
					'(6 . "Continuous")
					'(290 . 1)
					'(370 . -3)
				)
			)
		)
	)
	'("H-Arrow" "H-Block" "H-Distance" "H-Elevation" "H-Line" "H-Slope")
	'(5 7 1 4 7 3)
)
(if (not (tblsearch "STYLE" "Arial"))
	(entmake
		'(
		(0 . "STYLE")
		(100 . "AcDbSymbolTableRecord")
		(100 . "AcDbTextStyleTableRecord")
		(2 . "Arial")
		(70 . 0)
		(40 . 0.0)
		(41 . 1.0)
		(50 . 0.0)
		(71 . 0)
		(42 . 0.8)
		(3 . "arial.ttf")
		(4 . "")
		)
	)
)
(if (not (tblsearch "LAYER" "H-Block"))
	(entmake
		'(
			(0 . "LAYER")
			(100 . "AcDbSymbolTableRecord")
			(100 . "AcDbLayerTableRecord")
			(2 . "H-Block")
			(70 . 0)
			(62 . 7)
			(6 . "Continuous")
			(290 . 1)
			(370 . -3)
		)
	)
)
(if (not (tblsearch "BLOCK" "H-BLOCK"))
	(progn
		(entmake '((0 . "BLOCK") (2 . "H-BLOCK") (70 . 2) (4 . "") (370 . -2) (10 0.0 0.0 0.0)))
		(entmake
			'(
				(0 . "ATTDEF")
				(100 . "AcDbEntity")
				(67 . 0)
				(410 . "Model")
				(8 . "H-Distance")
				(100 . "AcDbText")
				(10 -2.82538 0.47 0.0)
				(40 . 0.8)
				(1 . "")
				(50 . 0.0)
				(41 . 1.0)
				(51 . 0.0)
				(7 . "Arial")
				(71 . 0)
				(72 . 4)
				(11 0.0 0.87 0.0)
				(210 0.0 0.0 1.0)
				(100 . "AcDbAttributeDefinition")
				(280 . 0)
				(3 . "")
				(2 . "DISTANCE")
				(70 . 0)
				(73 . 0)
				(74 . 0)
				(280 . 1)
			)
		)
		(entmake
			'(
				(0 . "ATTDEF")
				(100 . "AcDbEntity")
				(67 . 0)
				(410 . "Model")
				(8 . "H-Arrow")
				(100 . "AcDbText")
				(10 -2.14106 -0.530273 0.0)
				(40 . 0.8)
				(1 . "")
				(50 . 0.0)
				(41 . 1.0)
				(51 . 0.0)
				(7 . "Arial")
				(71 . 0)
				(72 . 4)
				(11 0.0 -0.13 0.0)
				(210 0.0 0.0 1.0)
				(100 . "AcDbAttributeDefinition")
				(280 . 0)
				(3 . "")
				(2 . "ARROW")
				(70 . 0)
				(73 . 0)
				(74 . 0)
				(280 . 1)
			)
		)
		(entmake
			'(
				(0 . "ATTDEF")
				(100 . "AcDbEntity")
				(67 . 0)
				(410 . "Model")
				(8 . "H-Slope")
				(100 . "AcDbText")
				(10 -1.86357 -1.53027 0.0)
				(40 . 0.8)
				(1 . "")
				(50 . 0.0)
				(41 . 1.0)
				(51 . 0.0)
				(7 . "Arial")
				(71 . 0)
				(72 . 4)
				(11 0.0 -1.13 0.0)
				(210 0.0 0.0 1.0)
				(100 . "AcDbAttributeDefinition")
				(280 . 0)
				(3 . "")
				(2 . "SLOPE")
				(70 . 0)
				(73 . 0)
				(74 . 0)
				(280 . 1)
			)
		)
		(entmake '((0 . "ENDBLK")))
	)
)
(defun add_vtx (obj add_pt ent_name / bulg)
	(vla-addVertex
		obj
		(1+ (fix add_pt))
		(vlax-make-variant
			(vlax-safearray-fill
				(vlax-make-safearray vlax-vbdouble (cons 0 1))
					(list
						(car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
						(cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
					)
			)
		)
	)
	(setq bulg (vla-GetBulge obj (fix add_pt)))
	(vla-SetBulge obj
		(fix add_pt)
		(/
			(sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
			(cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
		)
	)
	(vla-SetBulge obj
		(1+ (fix add_pt))
		(/
			(sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
			(cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
		)
	)
	(vla-update obj)
)
(defun c:SAD1 ( / AcDoc Space n typ_ent sel l_z ss ent vla_obj d_start d_end pt_start pt_end len pt_mid deriv rtx OK old-dim arrow nw_obj l_pt l_blg pt_cen nw_pl)
	(setq
		AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
		Space
		(if (= 1 (getvar "CVPORT"))
			(vla-get-PaperSpace AcDoc)
			(vla-get-ModelSpace AcDoc)
		)
	)
	(setq n 1 typ_ent nil)
	(repeat 2
		(while (not (member typ_ent '("INSERT" "POINT" "CIRCLE")))
			(setq sel (entsel (strcat "\nSelect insert " (itoa n) ": ")))
			(if sel (setq typ_ent (cdr (assoc 0 (setq dxf_ent (entget (car sel)))))))
		)
		(setq l_z (cons (cdr (assoc 10 dxf_ent)) l_z) n (1+ n) typ_ent nil)
	)
	(princ "\nSelect a curve object")
	(while
		(not
			(setq ss
				(ssget "_+.:E:S"
					'(
						(-4 . "<OR")
							(-4 . "<AND")
								(0 . "LWPOLYLINE")
								(-4 . "<AND")
									(-4 . "<NOT") (-4 . "&") (70 . 1) (-4 . "NOT>")
								(-4 . "AND>")
							(-4 . "AND>")
							(0 . "ARC,LINE")
						(-4 . "OR>")
					)
				)
			)
		)
	)
	(vla-startundomark AcDoc)
	(setq
		ent (ssname ss 0)
		vla_obj (vlax-ename->vla-object ent)
		l_z (mapcar '(lambda (y z) (list (car y) (cadr y) z)) (mapcar '(lambda (x) (vlax-curve-getClosestPointToProjection ent x (vlax-get vla_obj 'Normal))) l_z) (mapcar 'caddr l_z))
		d_start (vlax-curve-getDistAtPoint ent (vlax-curve-getClosestPointTo ent (car l_z)))
		d_end (vlax-curve-getDistAtPoint ent (vlax-curve-getClosestPointTo ent (cadr l_z)))
		pt_start (if (> d_end d_start) (vlax-curve-getPointAtDist ent d_start) (vlax-curve-getPointAtDist ent d_end))
		pt_end (if (> d_end d_start) (vlax-curve-getPointAtDist ent d_end) (vlax-curve-getPointAtDist ent d_start))
		len (abs (- d_end d_start))
		pt_mid (vlax-curve-getPointAtDist ent (+ (if (> d_end d_start) d_start d_end) (* len 0.5)))
		deriv (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt_mid))
		rtx (- (atan (cadr deriv) (car deriv)) (angle '(0 0 0) (getvar "UCSXDIR")))
		OK (apply 'append (mapcar '(lambda (x) (mapcar '(lambda (zx) (equal (list (car x) (cadr x)) (list (car zx) (cadr zx)) 1E-04)) l_z)) (list pt_start pt_end)))
	)
	(cond
		((eq (length (vl-remove nil OK)) 2)
			(setq old-dim (getvar "DIMZIN"))
			(setvar "DIMZIN" 0)
			(setq arrow
				(if (> (vlax-curve-getParamAtPoint ent (cadr l_z)) (vlax-curve-getParamAtPoint ent (car l_z)))
					(if (member (apply 'min (mapcar 'caddr l_z)) (car l_z)) "<<<" ">>>")
					(if (member (apply 'min (mapcar 'caddr l_z)) (car l_z)) ">>>" "<<<")
				)
			)
			(setq arrow
				(if (or (> rtx (* pi 0.5)) (< rtx (- (* pi 0.5))))
					(if (eq arrow ">>>") "<<<" ">>>")
					(if (eq arrow ">>>") ">>>" "<<<")
				)
			)
			(if (or (> rtx (* pi 0.5)) (< rtx (- (* pi 0.5)))) (setq rtx (+ rtx pi)))
			(setq nw_obj (vla-InsertBlock Space (vlax-3d-point pt_mid) "H-BLOCK" 1 1 1 rtx))
			(vlax-put nw_obj 'Layer "H-Block")
			(mapcar
				'(lambda (x y)
					(vla-put-textstring x y)
				)
				(vlax-safearray->list (vlax-variant-value (vla-getattributes nw_obj)))
				(list
					(strcat (rtos len 2 2) "m")
					arrow
					(strcat (rtos (* (/ (abs (apply '- (mapcar 'caddr l_z))) len) 100.0) 2 2) "%")
				)
			)
			(mapcar
				'(lambda (x y / nw_obj)
					(setq nw_obj
						(vla-addMtext Space
							(vlax-3d-point x)
							0.0
							y
						)
					)
					(mapcar
						'(lambda (pr val)
							(vlax-put nw_obj pr val)
						)
						(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'Color)
						(list 5 0.79 5 x "Arial" "H-Elevation" (* pi 0.5) 4)
					)
				)
				(list (polar (car l_z) pi 0.79) (polar (cadr l_z) pi 0.79))
				(list (rtos (caddar l_z) 2 2) (rtos (car (cddadr l_z)) 2 2))
			)
			(cond
				((eq (vla-get-ObjectName vla_obj) "AcDbPolyline")
					(mapcar
						'(lambda (x)
							(if (not (eq (vlax-curve-getParamAtPoint ent x) (fix (vlax-curve-getParamAtPoint ent x))))
								(add_vtx vla_obj (vlax-curve-getParamAtPoint ent x) ent)
							)
						)
						l_z
					)
					(setq n (fix (apply 'min (mapcar '(lambda (x) (vlax-curve-getParamAtPoint ent x)) l_z))))
					(repeat (1+ (fix (abs (apply '- (mapcar '(lambda (x) (vlax-curve-getParamAtPoint ent x)) l_z)))))
						(if (not (equal (vlax-curve-getPointAtParam ent n) (car l_pt) 1E-08))
							(setq
								l_pt (cons (vlax-curve-getPointAtParam ent n) l_pt)
								l_blg (cons (vla-GetBulge vla_obj n) l_blg)
							)
						)
						(setq n (1+ n))
					)
					(setq
						nw_pl
						(vlax-invoke Space 'AddLightWeightPolyline
							(apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) (reverse l_pt)))
						)
						n -1
					)
					(mapcar '(lambda (x) (vla-SetBulge nw_pl (setq n (1+ n)) x)) (reverse l_blg))
				)
				((eq (vla-get-ObjectName vla_obj) "AcDbArc")
					(setq pt_cen (vlax-safearray->list (vlax-variant-value (vla-get-Center vla_obj))))
					(setq nw_pl (vla-AddArc Space (vla-get-Center vla_obj) (vla-get-Radius vla_obj) (angle pt_cen pt_start) (angle pt_cen pt_end)))
				)
				((eq (vla-get-ObjectName vla_obj) "AcDbLine")
					(setq nw_pl (vla-AddLine Space (vlax-3d-point pt_start) (vlax-3d-point pt_end)))
				)
			)
			(vlax-put nw_pl 'Layer "H-Line")
			(vlax-put nw_pl 'Color 2)
			(setvar "DIMZIN" old-dim)
		)
		(T
			(princ "\nInsufficient coincidence between curvilinear object and insertion")
		)
	)
	(vla-endundomark AcDoc)
	(prin1)
)

Edited September 5 by macros55

Quote

Link to comment

Share on other sites

Top Posters In This Topic

19
7
6
4

Popular Days

Top Posters In This Topic

macros55 19 posts
BIGAL 7 posts
Tsuky 6 posts
devitg 4 posts

Popular Days

Popular Posts

pBe

May 21

This is where you posted the request. Let me have a look-see You want to use an Attribute block? Its easy, but one thing the program will not do for you is to create the block, i

pBe

May 21

What is that?

devitg

May 21

@macros55 , it is not to download such HotOffThePress _ rev2.dwg

Posted Images

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.

Guest

Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.

Reply to this topic...

× Pasted as rich text. Restore formatting

Only 75 emoji are allowed.

× Your link has been automatically embedded. Display as a link instead

× Your previous content has been restored. Clear editor

× You cannot paste images directly. Upload or insert images from URL.

Insert image from URL

×

Share

Go to topic listing

×

Tutorials
- Back
- Tutorials
- AutoCAD
- 3ds Max
Michael's Corner
Forums
- Back
- Clubs
- Forums
- Staff
- Leaderboard
Activity
- Back
- All Activity
- Search
Downloads
Gallery
Tips

×

Create New...