(princ "tDigite pontos p/ara iniciar ")
(defun contos ()
(setvar"cmdecho" 0)
;(command "osmode" 0)
(command "angbase" 270)
(command "angdir" 1)
(setq flagv "falso")
(setq controle 0)
(setq controle1 0)
(setq contador 0)
(while (= flagv "falso")
(setq mostre (entsel "\nMostre a Polyline <2d> : "))
(setq linha (entget (car mostre )))
(setq verificador (cdr(assoc 0 linha)))
(if (= verificador "LWPOLYLINE")
(progn
(setq verif (cdr (assoc 70 linha)))
(setq flagv "verdade")
)
(princ "tNão é Polyline !! ")
)
)
(setq controle1 (length linha))
(setq amostra '())
(repeat controle1
(setq x (caar linha))
(if (= x 10)
(progn
(setq item (car linha))
(setq amostra (cons item amostra))
(setq contador (1+ contador))
)
)
(setq linha (cdr linha))
)
(setq amostra1 (reverse amostra))
(if (= verif 1)
(setq amostra (cons (car amostra1) amostra))
(setq contador (1- contador))
)
(setq controle contador)
(repeat controle
(setq PTO1 (cdr(car amostra)))
(setq PTO2 (cdr(car(cdr amostra))))
(AZIMUTAR)
(setq amostra(cdr amostra))
)
(princ)
)
(defun AZIMUTAR ()
(setq padroes (getvar "osmode"))
(setvar"cmdecho" 0)
(command "osmode" 0)
(setq A PTO1)
(setq B PTO2)
;;(setq C " - Az ")
;;(setq D (angtos (angle A B) 1 4))
;;(MUDAR)
;;(setq E (rtos (distance A B) 2 4))
;;(setq DADO (strcat E C PALAV))
;;(PARALELO)
;;(command "text" "j" "mc" ponto_meio 2.5 inicio dado )
;;(command "osmode" padroes)
(setq angulo (angle A B))
(setq ang2 (+ angulo (dtr 90)))
(princ angulo)
(princ ang2)
(entmake
(list (cons 0 "point")
(cons 10 B)
)
)
)
(defun PARALELO ()
(setq A1 (polar A (+ (/ pi 2)(angle B A )) 2))
(setq B1 (polar B (+ (/ pi 2)(angle B A )) 2))
(setq ptx (/ (+ (car B1) (car A1)) 2))
(setq pty (/ (+ (cadr B1) (cadr A1)) 2))
(setq ponto_meio (list ptx pty))
(if (< (car A1)(car B1))
(setq inicio B1)
(setq inicio A1)
)
)
(defun MUDAR ()
(setq XL 2)
(setq J "d")
(setq COM1 (substr D 1 1))
(while (< XL 5)
(setq LETRAT (substr D XL 1))
(setq RESTOT (substr D (+ 1 XL) ))
(if (= LETRAT J)
(progn (setq J "%%d")
(setq XL 6)
(setq PALAV (strcat COM1 J RESTOT))
)
)
(setq COM1 (strcat COM1 LETRAT ))
(setq XL (1+ XL))
)
)
(defun RTD ()
(/ (* (angle A B) 180) Pi)
)
(defun DTR (AZIMUTE)
(* (/ AZIMUTE 180.0) pi) ;; esta linha também foi alterada
)
;; Function to place blocks at measured intervals
(defun c:MeasureCSV (/ bname path dist ss n en ed fn f)
;; Ask user to select path, distance & block name
(if (and (setq path (entsel "Select object to measure: ")) ;Check if user's picked an object
(setq dist (getdist "Specify length of segment: ")) ;Check if user's specified distance
(setq bname (getstring t "Enter name of block to insert: ")) ;Check if user's specified block name
(tblsearch "BLOCK" bname) ;Check if block exists
) ;_ end of and
(progn
;; Do the Measure command
(command "_.MEASURE" path "_Block" bname "_Yes" dist)
;; Get a selection set of the blocks created
(if (setq ss (ssget "P")) ;Select previous
(progn
(setq n 0) ;initialize counter
(while (< n (sslength ss)) ;While counter is less than selection set's length
(setq en (ssname ss n) ;Get the nth item from the selection set
ed (entget en) ;Get its DXF data list
) ;_ end of setq
(write-line
(strcat (rtos (cadr (assoc 10 ed))) ;X value
","
(rtos (caddr (assoc 10 ed))) ;Y value
","
(rtos (cadddr (assoc 10 ed))) ;Z value
) ;_ end of strcat
f
) ;_ end of write-line
(setq n (1+ n)) ;Increment counter
) ;_ end of while
) ;_ end of progn
) ;_ end of if
(close f) ;Close the file
) ;_ end of progn
(princ "Stopped.")
) ;_ end of if
) ;_ end of progn
(princ "*Invalid*") ;Else stop & show error
) ;_ end of if
(princ) ;Don't show anything else on command line
) ;_ end of defun
;; BlockAddEOL.lsp
;; Block Add to End Of Line
;; CAB 11.13.08 Version 1.1
(defun c:block2end (/ ss s1 bname ent ename lset doc space s e i )
(vl-load-com)
;; sub to insert the block
(defun InsertBlock (bn pt ang lay aspace)
(setq blk (vla-insertblock
aspace
(vlax-3d-point pt) ; insert point
bn ; block name
1. ; scale x
1.
1.
ang ; radians
)
)
(vla-put-layer blk lay)
blk
)
;;; Returns object to active space (ModelSpace or PaperSpace )
;; CAB 05/31/07
(defun activespace (doc)
(if (or (= acmodelspace (vla-get-activespace doc))
(= :vlax-true (vla-get-mspace doc)))
(vla-get-modelspace doc)
(vla-get-paperspace doc)
)
)
(defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
;;==============================================
;; CAB version
;; do a ssget crossing the size of the pickbox at the pick point
(setq SZ (getvar "SCREENSIZE") ; screen size in pixels
VS (getvar "VIEWSIZE") ; screen height in drawing units
PB (getvar "pickbox") ; get current pickbox size
SWP (car SZ) ; width of screen in pixels
SHP (cadr SZ) ; height of screen in pixels
AR (/ SWP SHP) ; aspect ratio width/height
WSD (* VS AR) ; width of screen dwg units = ratio times height
PPDU (/ WSD SWP) ; pixels per drawing unit
BOX (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
)
(setq ss (ssget "_C"
(polar pt 0.785 box)
(polar pt 3.93 box)
(list (cons 0 typs) (cons 8 lay))
)
)
)
;;=============================
;; Start Here
(setq LineLay "*") ; filter for line layer
(setq blklay "0") ; filter for block layer
(prompt "\nSelect block to use or ENTER key to name block.")
(if
(and
(or
(and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
(setq ent (ssname ss 0))
(setq bname (cdr(assoc 2 (entget ent)))))
(and (setq bname (getstring t "\nName of block to copy: "))
(or (tblsearch "Block" bname)
(prompt (strcat "Cannot find Block " bname ", Ending."))))
)
(or (prompt "\nSelect lines to test.")
(setq lset (ssget (list '(0 . "line")(cons 8 LineLay)))) ;filter line in selection set
)
)
(progn
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
space (activespace doc))
(vla-EndUndoMark doc)
(vla-StartUndoMark doc)
(vla-zoomextents (vlax-get-acad-object))
(setq i -1)
(while (setq ename (ssname lset (setq i (1+ i))))
(setq elst (entget ename)
s (cdr(assoc 10 elst))
e (cdr(assoc 11 elst)))
(if (= (sslength (setq s1 (getss@ s "LINE" Linelay))) 1)
(InsertBlock bname s (angle e s) blklay space)
)
(if (= (sslength (setq s1 (getss@ e "LINE" Linelay))) 1)
(InsertBlock bname e (angle s e) blklay space)
)
)
(vla-zoomprevious (vlax-get-acad-object))
(vla-EndUndoMark doc)
)
) ; endif
(princ "\nThe blocks have been copied")
(princ)
)
(princ)
;; Function to place blocks at end intervals
(vl-load-com) ; initialize vla functions
(defun c:EndsCSV (/ bname path dist ss n en ed fn f)
;; Ask user to select path, distance & block name
(if (and (setq path (car (entsel "Select object to measure end points: "))) ;Check if user's picked an object
(setq dist (- (vlax-curve-getdistatpoint (vlax-ename->vla-object path) (vlax-curve-getendpoint (vlax-ename->vla-object path))) (vlax-curve-getdistatpoint (vlax-ename->vla-object path) (vlax-curve-getstartpoint (vlax-ename->vla-object path))) )) ;Check if specified distance
(setq bname (getstring t "Enter name of block to insert: ")) ;Check if user's specified block name
(tblsearch "BLOCK" bname) ;Check if block exists
) ;_ end of and
(progn
;; Do the Measure command
(command "_.MEASURE" path "_Block" bname "_Yes" dist)
;; Get a selection set of the blocks created
(if (setq ss (ssget "P")) ;Select previous
(progn
(setq n 0) ;initialize counter
(while (< n (sslength ss)) ;While counter is less than selection set's length
(setq en (ssname ss n) ;Get the nth item from the selection set
ed (entget en) ;Get its DXF data list
) ;_ end of setq
(write-line
(strcat (rtos (cadr (assoc 10 ed))) ;X value
","
(rtos (caddr (assoc 10 ed))) ;Y value
","
(rtos (cadddr (assoc 10 ed))) ;Z value
) ;_ end of strcat
f
) ;_ end of write-line
(setq n (1+ n)) ;Increment counter
) ;_ end of while
) ;_ end of progn
) ;_ end of if
(close f) ;Close the file
) ;_ end of progn
(princ "Stopped.")
) ;_ end of if
) ;_ end of progn
(princ "*Invalid*") ;Else stop & show error
) ;_ end of if
(princ) ;Don't show anything else on command line
) ;_ end of defun
;; BlockAddEOC.lsp
;; Block Add to End Of Curve
;; CAB 11.13.08 Version 1.1
;; M.R. modified 10.08.12
(defun c:block2end (/ ss s1 bname ent ename lset doc space s sa e ea i )
(vl-load-com)
;; sub to insert the block
(defun InsertBlock (bn pt ang lay aspace)
(setq blk (vla-insertblock
aspace
(vlax-3d-point pt) ; insert point
bn ; block name
1. ; scale x
1.
1.
ang ; radians
)
)
(vla-put-layer blk lay)
blk
)
;;; Returns object to active space (ModelSpace or PaperSpace )
;; CAB 05/31/07
(defun activespace (doc)
(if (or (= acmodelspace (vla-get-activespace doc))
(= :vlax-true (vla-get-mspace doc)))
(vla-get-modelspace doc)
(vla-get-paperspace doc)
)
)
(defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
;;==============================================
;; CAB version
;; do a ssget crossing the size of the pickbox at the pick point
(setq SZ (getvar "SCREENSIZE") ; screen size in pixels
VS (getvar "VIEWSIZE") ; screen height in drawing units
PB (getvar "pickbox") ; get current pickbox size
SWP (car SZ) ; width of screen in pixels
SHP (cadr SZ) ; height of screen in pixels
AR (/ SWP SHP) ; aspect ratio width/height
WSD (* VS AR) ; width of screen dwg units = ratio times height
PPDU (/ WSD SWP) ; pixels per drawing unit
BOX (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
)
(setq ss (ssget "_C"
(polar pt 0.785 box)
(polar pt 3.93 box)
(list (cons 0 typs) (cons 8 lay))
)
)
)
;;=============================
;; Start Here
(setq CurveLay "*") ; filter for curve layer
(setq blklay "0") ; filter for block layer
(prompt "\nSelect block to use or ENTER key to name block.")
(if
(and
(or
(and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
(setq ent (ssname ss 0))
(setq bname (cdr(assoc 2 (entget ent)))))
(and (setq bname (getstring t "\nName of block to copy: "))
(or (tblsearch "Block" bname)
(prompt (strcat "Cannot find Block " bname ", Ending."))))
)
(or (prompt "\nSelect curves to test.")
(setq lset (ssget (list '(0 . "*line,ellipse,arc")(cons 8 CurveLay)))) ;filter curve in selection set
)
)
(progn
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
space (activespace doc))
(vla-EndUndoMark doc)
(vla-StartUndoMark doc)
(vla-zoomextents (vlax-get-acad-object))
(setq i -1)
(while (setq ename (ssname lset (setq i (1+ i))))
(setq sa (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv (vlax-ename->vla-object ename) (vlax-curve-getstartparam (vlax-ename->vla-object ename))))
ea (angle (vlax-curve-getfirstderiv (vlax-ename->vla-object ename) (vlax-curve-getendparam (vlax-ename->vla-object ename))) '(0.0 0.0 0.0))
s (vlax-curve-getstartpoint (vlax-ename->vla-object ename))
e (vlax-curve-getendpoint (vlax-ename->vla-object ename)))
(if (= (sslength (getss@ s "*LINE,ELLIPSE,ARC" Curvelay)) 1)
(InsertBlock bname s sa blklay space)
)
(if (= (sslength (getss@ e "*LINE,ELLIPSE,ARC" Curvelay)) 1)
(InsertBlock bname e ea blklay space)
)
)
(vla-zoomprevious (vlax-get-acad-object))
(vla-EndUndoMark doc)
)
) ; endif
(princ "\nThe blocks have been copied")
(princ)
)
(princ "\nType block2end to invoke")
(princ)
(defun DXF (code lst)
(cdr (assoc code lst))
)
(defun pline_block (strBlockPath strBlockName strUseLTScale /
objEnt pt1 pt2 ent2 layName ang lts objType)
(while (setq objEnt (entsel "\n Select a point on a line/pline/arc... "))
(progn
(setq objType (cdr (assoc 0 (entget (car objEnt)))))
(princ objType)
(setq pt1 (osnap (cadr objEnt) "_nea"))
(setq pt2 (osnap (cadr objEnt) "_endp"))
(setq ent2 (entget (setq entList (car objEnt))))
(setq layName (DXF 8 ent2))
(if (= strUseLTScale "Y")
(setq lts (getvar "ltscale"))
(setq lts 1.0)
)
(setvar "clayer" layName)
(setq ang (angle pt1 pt2))
(command "-insert" (strcat strBlockPath strBlockName) pt2 lts "" (rtd ang))
)
)
(princ)
)
(pline_block "E:\\temp\\" "test" "Y")
(defun c:test3 (/ANG CL SCL DBX ss s1 bname ent ename lset doc space s e i )
(vl-load-com)
***** Get current layer info and make new layer for inserted blocks *****
[color=red](setq CL (getvar "CLAYER"))
(command "_.-Layer" "m" "L-ANNO-SYMB" "c" "3" "L-ANNO-SYMB" "")[/color]
[color=red]***** Determine INUNITS value and set scale for inserted blocks *****
(cond ((= (getvar "INSUNITS") 1) (setq SCL 1))
((= (getvar "INSUNITS") 2) (setq SCL 0.08333))
((= (getvar "INSUNITS") 4) (setq SCL 25.4))
((= (getvar "INSUNITS") 5) (setq SCL 2.54))
((= (getvar "INSUNITS") 6) (setq SCL 0.0254))
(t (alert "Current DWG set to non-standard units. Check UNITS settings"))
)
***** Iport block form seed drawing *****
(defun open_dbx (dwg / dbx)
(if (< (atoi (substr (getvar "ACADVER") 1 2)) 16)
(setq dbx (vlax-create-object "ObjectDBX.AxDbDocument"))
(setq dbx (vlax-create-object
(strcat "ObjectDBX.AxDbDocument."
(substr (getvar "ACADVER") 1 2)
)
)
)
)
(vla-open dbx dwg)
dbx
)
(setq Dbx (open_dbx "X:/AutoCAD 2018/Drawings/Callouts.dwg"))
(vla-CopyObjects
Dbx
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject '(0 . 0))
(list (vla-item (vla-get-blocks dbx) "MNLA Transition Tick r20"))
)
(vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
)
(vlax-release-object dbx)
[/color]
;; sub to insert the block
(defun InsertBlock (bn pt ang lay aspace)
(setq blk (vla-insertblock
aspace
(vlax-3d-point pt) ; insert point
bn ; block name
1. ; scale x
1.
1.
ang ; radians
)
)
(vla-put-layer blk lay)
blk
)
;;; Returns object to active space (ModelSpace or PaperSpace )
;; CAB 05/31/07
(defun activespace (doc)
(if (or (= acmodelspace (vla-get-activespace doc))
(= :vlax-true (vla-get-mspace doc)))
(vla-get-modelspace doc)
(vla-get-paperspace doc)
)
)
(defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
;;==============================================
;; CAB version
;; do a ssget crossing the size of the pickbox at the pick point
(setq SZ (getvar "SCREENSIZE") ; screen size in pixels
VS (getvar "VIEWSIZE") ; screen height in drawing units
PB (getvar "pickbox") ; get current pickbox size
SWP (car SZ) ; width of screen in pixels
SHP (cadr SZ) ; height of screen in pixels
AR (/ SWP SHP) ; aspect ratio width/height
WSD (* VS AR) ; width of screen dwg units = ratio times height
PPDU (/ WSD SWP) ; pixels per drawing unit
BOX (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
)
(setq ss (ssget "_C"
(polar pt 0.785 box)
(polar pt 3.93 box)
(list (cons 0 typs) (cons 8 lay))
)
)
)
;;=============================
;; Start Here
(setq LineLay "*") ; filter for line layer
[color=red] (setq blklay "L-ANNO-SYMB") ; filter for block layer[/color]
(if
(and
[color=red] (setq bname "MNLA Transition Tick r20")[/color]
(or (prompt "\nSelect lines to test.")
(setq lset (ssget (list '(0 . "line")(cons 8 LineLay)))) ;filter line in selection set
)
)
(progn
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
space (activespace doc))
(vla-EndUndoMark doc)
(vla-StartUndoMark doc)
(vla-zoomextents (vlax-get-acad-object))
(setq i -1)
(while (setq ename (ssname lset (setq i (1+ i))))
(setq elst (entget ename)
s (cdr(assoc 10 elst))
e (cdr(assoc 11 elst)))
(if (= (sslength (setq s1 (getss@ s "LINE" Linelay))) 1)
[color=red] (command "-insert" "MNLA Transition Tick r20" s SCL SCL (angle e s))[/color]
)
(if (= (sslength (setq s1 (getss@ e "LINE" Linelay))) 1)
[color=red] (command "-insert" "MNLA Transition Tick r20" e SCL SCL (angle e s))[/color]
)
)
(vla-zoomprevious (vlax-get-acad-object))
(vla-EndUndoMark doc)
)
) ; endif
(princ "\nThe blocks have been copied")
(princ)
)
(princ)