Author Topic: angle fix code problem  (Read 162 times)

0 Members and 1 Guest are viewing this topic.

dussla

  • Bull Frog
  • Posts: 286
angle fix code problem
« on: July 03, 2022, 01:15:48 PM »
this code is  rectify code
Using lots of great friends code, I ended up with the following code:
but there is problem

0 ,enter   rg9 command
1. select objects
2. enter 45 angel

if i   1 object  select ,  work  some  good  result

but tow error
    a.   mulit select object error   
    b, duplicated object

i  seek  error for a long time, but my limit
pls help again

Code: [Select]





;; Outline Objects  -  Lee Mac
;; Attempts to generate a polyline outlining the selected objects.
;; sel - [sel] Selection Set to outline
;; Returns: [sel] A selection set of all objects created

(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
(setq cl (getvar "clayer"))
(command "-Layer" "m" "_boe"  "c" "32" "_boe" "")

(command "-layer" "s" "_boe" "")
       
    (if (setq box (LM:ssboundingbox sel))
        (progn
            (setq app (vlax-get-acad-object)
                  dis (/ (apply 'distance box) 20.0)
                  lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
                  are (apply '* (apply 'mapcar (cons '- (reverse lst))))
                  dis (* dis 1.5)
                  ent
                (entmakex
                    (append
                       '(   (000 . "LWPOLYLINE")
                            (100 . "AcDbEntity")
                            (100 . "AcDbPolyline")

                            (090 . 4)
                            (070 . 1)
                        )
                        (mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
                           '(   (caar   cadar)
                                (caadr  cadar)
                                (caadr cadadr)
                                (caar  cadadr)
                            )
                        )
                    )
                )
            )
            (apply 'vlax-invoke
                (vl-list* app 'zoomwindow
                    (mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
                )
            )
            (setq cmd (getvar 'cmdecho)
                  enl (entlast)
                  rtn (ssadd)
            )
            (while (setq tmp (entnext enl)) (setq enl tmp))
            (setvar 'cmdecho 0)
            (command
                "_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
                (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
            )
            (while (< 0 (getvar 'cmdactive)) (command ""))
            (entdel ent)
            (while (setq enl (entnext enl))
                (if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
                         (equal (vla-get-area obj) are 1e-4)
                    )
                    (entdel enl)
                    (ssadd  enl rtn)
                )
            )
            (vla-zoomprevious app)
            (setvar 'cmdecho cmd)
            rtn
        )
    )
(setvar "clayer" cl)
)

;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

(vl-load-com) (princ)

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;



(defun dtr (a)
(* pi (/ a 180.0))
)

(defun rtd (a)
(/ (* a 180) pi)
)

(defun met2 ()
  (setvar "CMDECHO" 0)

  ; change direction to 0 and clockwise to n
  (command "units" "" "" "" "" "0" "n")
(prompt "\n East = 0")

  (setvar "CMDECHO" 1)
  (princ)
)


(defun C:rg9  ( /  acadobj activeundo adoc coords  del dis getcoords i len  ss ln entang  wid rangle)


(VL-LOAD-COM)
;;RAD TO DEG AND DEG TO RAD
(DEFUN RTD (X) ;_define  RADIAN  TO DEGREE function
  (/ (* X 180.0) PI)
) ;_  DEFUN ADD by DEVITG
;; MULTIPLY THE RAD ING BY 180  AND DIVIDE IT BY PI

(defun getcoords (ln) (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ln))))
(defun lst->str (lst del) (apply 'strcat (append (list (car lst)) (mapcar '(lambda (x) (strcat del x)) (cdr lst)))))
(setq acadobj (vlax-get-acad-object)
adoc (vla-get-ActiveDocument acadobj)
activeundo nil)
  (setvar "orthomode" 0 )
(setvar "osmode" 0)
(command "_.undo" "_begin")
   (setq
aunit (getvar 'aunits)
osm (getvar 'osmode)
blips (getvar 'blipmode)
curlay (getvar 'clayer)
)
  (setvar 'osmode 0)
  (setvar 'blipmode 0)
  (setvar 'aunits 3); radians

(if ( not anginc ) (setq anginc  45 ) )
(setq btemp-wi (getint (strcat "\n angle   <"  (rtos anginc)  ">:")) )
(if btemp-wi (setq anginc btemp-wi))

(setq anginc (dtr anginc) )
(setq d 2000)

(setq lines (ssadd) )


(command "-Layer" "m" "newrect"  "c" "150" "newrect" "")

(command "-layer" "s" "newrect" "")


 


(setq ss (ssget '((0 . "LWPOLYLINE") )))

(repeat (setq i (sslength ss))



   (setq   entang (ssname ss (setq i (1- i))) )
   (setq coords (getcoords entang ))
   (setq ent  (ssname ss (setq i (1- i))))
   (setq dis (mapcar 'distance coords (cdr coords)))
   (setq rangle (mapcar 'angle coords (cdr coords)))
   
   (cond
((< (nth 0 dis) (nth 1 dis)) (setq wid (nth 0 dis)) (setq len (nth 1 dis)) (setq rect-angle (rtd (nth 1 rangle))) )
((>= (nth 0 dis) (nth 1 dis)) (setq wid (nth 1 dis)) (setq len (nth 0 dis)) (setq rect-angle (rtd (nth 0 rangle))) )
   )
 
 
   ; my adds
 
   (SETQ MID-PT-xy (MAPCAR '* '(0.5 0.5 0.8) (MAPCAR '+ (nth 0 coords) (nth 2 coords))))
   (setq MID-PT-x (nth 0 MID-PT-xy))
   (setq MID-PT-y (nth 1 MID-PT-xy))
   ;end my adds
   
     (setvar 'aunits 0); radians
   (command "rotate" entang ""  "_non" MID-PT-xy  (- 360 rect-angle )  )
(setvar 'aunits 3); radians

(command "_.explode" entang)


(setq plpcs (ssget "_P"))

(repeat (sslength plpcs)
  (setq plpc (ssname plpcs 0))
  (if (= (cdr (assoc 0 (entget plpc))) "LINE") (ssadd plpc lines))
  (ssdel plpc plpcs)
); end repeat


(setq sslist (ssadd))


(repeat (sslength lines)

(setq
  ln (ssname lines 0)
  lndata (entget ln)
  lnend1 (cdr (assoc 10 lndata))
  lnend2 (cdr (assoc 11 lndata))
  lnang (angle lnend1 lnend2)
  lnmid (mapcar '/ (mapcar '+ lnend1 lnend2) '(2 2 2))
  lnangnew
(if (zerop anginc)
  0
  (* (fix (+ (/ lnang anginc) 0.5)) anginc)
); end if & lnangnew
); end setq


(setq lndata (subst (cons 10 (polar lnend2 lnang d)) (assoc 10 lndata) lndata)
   lndata (subst (cons 11 (polar lnend1 (+ lnang pi) d)) (assoc 11 lndata) lndata)
)
(entmod lndata)

(setvar 'osmode 0)
(setvar 'aunits 3);
(command "_.rotate" ln "" lnmid "_reference" lnang lnangnew)

(setvar 'aunits 3);
(ssadd ln sslist)

(ssdel ln lines)

;;(LM:outline sel)



(LM:outline sslist)
                                   


); end repeat




  (setq newnet (ssget "_l"))

(setvar 'aunits 0);

(command "rotate"  newnet ""  "_non" MID-PT-xy  (+ 360 rect-angle )  )



(command "_erase"  plpcs "")
   


) ;_  repeat


(command "_.undo" "_end")
)