« previous next »
Pages: 1 2 [All] |   Go Down

Author Topic: Problem with code  (Read 7008 times)

0 Members and 1 Guest are viewing this topic.

lispman21

  • Guest
Problem with code
« on: August 02, 2006, 08:43:49 AM »
Here is code to convert circles to plines, but after the program runs the pline conversions are not placed where the original circles where.  Is there a way to get the original origin of the circles and then make them plines and move the plines back where they should be.


Code: [Select]
(defun C2P (/ OLDVAR1  COUNT LINENO SS1 ename elist pt )

   (alert "\nConverting Circles to PLines\n")
 
   (command ".undo" "Mark")   
   (setq OLDVAR1 (getvar "CMDECHO")) (setvar "CMDECHO" 0)

   (setq SS1 nil)   
   (setq SS1 (ssget "X" ' ((0 . "CIRCLE"))))   
   (setq LINENO (sslength SS1)) 
   (setq COUNT 0)
   (setq PLINFO (ssadd))         
   (repeat LINENO
      (progn     
         (setq ename (ssname SS1 COUNT))   
         (setq elist (entget ename))   
         (setq dia (* 2 (cdr (assoc 40 elist)))) ;get diameter
         (setq pt (cdr (assoc 10 elist))) ;get center point
         (setq lay (cdr (assoc 8 elist))) ;get layer
         (command "donut" dia dia pt "") ;make the donut
         (setq ename (entlast)) ;move donut to circle's layer
         (setq elist (entget ename))
         (setq elist (subst (cons 8 lay) (assoc 8 elist) elist))
         (entmod elist)
         (setq COUNT (1+ COUNT))       
      )
   )
   (COMMAND "ERASE" SS1 "")           
   (setvar "CMDECHO" OLDVAR1)         
   (prompt (strcat "\n" "Erasing original Circles..." "\n"))
   (princ) ; end program
    (terpri)
); end convert.lsp
Logged

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Problem with code
« Reply #1 on: August 02, 2006, 09:12:33 AM »
Could be an osnap problem.
Code: [Select]
(command "donut" dia dia "non" pt "") ;make the donut
Could be a UCS problem.
Code: [Select]
(command "donut" dia dia "non" (trans pt 1 0) "") ;make the donut
Logged
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Problem with code
« Reply #2 on: August 02, 2006, 09:28:05 AM »
Code: [Select]
(defun C:C>LW (/ C D SS)
;(C:C>LW)
  (if (setq ss (ssget "_X" '((0 . "CIRCLE"))))
    (foreach e (mapcar
                 (function entget)
                 (vl-remove-if
                   (function listp)
                   (mapcar
                     (function cadr) (ssnamex ss))
                 ) ;_ vl-remove-if
               ) ;_  mapcar
      (entmakex
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          (assoc 8 e)
          (if (assoc 62 e)
            (assoc 62 e)
            '(62 . 256)
          ) ;_  if
          '(100 . "AcDbPolyline")
          '(90 . 4)
          '(70 . 1)
          (list 10 (+ (car (setq c (cdr (assoc 10 e)))) (setq d (cdr (assoc 40 e))))(cadr c))
          '(42 . 0.4142135623730951)
          (list 10 (car c) (+ (cadr c) d))
          '(42 . 0.4142135623730951)
          (list 10 (- (car c) d) (cadr c))
          '(42 . 0.4142135623730951)
          (list 10 (car c) (- (cadr c) d))
          '(42 . 0.4142135623730951)
        ) ;_  list
      ) ;_  entmakex
      (entdel (cdr(assoc -1 e)))
    ) ;_  foreach
  ) ;_  if
) ;_  defun

(defun C:LW>C (/ P1 P2 SS)
;(C:LW>C)
  (if (setq ss (ssget "_X"
                      '((0 . "LWPOLYLINE")
                        (90 . 4)
                        (70 . 1)
                        (42 . 0.4142135623730951)
                        (42 . 0.4142135623730951)
                        (42 . 0.4142135623730951)
                        (42 . 0.4142135623730951)
                       )
               ) ;_  ssget
      ) ;_  setq
    (foreach e (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss)))
      (entmakex
        (list
          '(0 . "CIRCLE")
          (assoc 8 (entget e))
          (if (assoc 62 (entget e)) (assoc 62 (entget e)) '(62 . 256))
          (cons 10
            (setq
              p1 (mapcar (function (lambda (x1 x2) (/ (+ x1 x2) 2.)))
                         (setq p2 (vlax-curve-getPointAtParam e 0))
                         (vlax-curve-getPointAtParam e 2)
                 ) ;_  mapcar
            ) ;_  setq
          ) ;_  cons
          (cons 40 (distance p1 p2))
        ) ;_  list
      ) ;_  entmakex
      (entdel e)
    ) ;_  foreach
  ) ;_  if
) ;_  defun
Logged

lispman21

  • Guest
Re: Problem with code
« Reply #3 on: August 02, 2006, 09:29:57 AM »
Tried both instances but neither worked but somethign must be really messed up.
Logged

lispman21

  • Guest
Re: Problem with code
« Reply #4 on: August 02, 2006, 09:43:41 AM »
A drawing is attached and the code doesn't work right in this drawing.
Logged

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Problem with code
« Reply #5 on: August 02, 2006, 09:50:12 AM »
Probably, it is better to make a polyline with two points.
I have shown my old program, adapted for a forum...

My code, only for UCS World and normal 0 0 1
Logged

LE

  • Guest
Re: Problem with code
« Reply #6 on: August 02, 2006, 09:52:29 AM »
Here is something, see if works.

Code: [Select]
(if (not dwg)
  (setq dwg (vla-get-activedocument (vlax-get-acad-object))))

(defun 2dpt  (pt)
  (if (caddr pt)
    (list (car pt) (cadr pt))
    pt))

(defun activespace  ()
  (if (= acmodelspace (vla-get-activespace dwg))
    (vla-get-modelspace dwg)
    (if (= (vla-get-mspace dwg) :vlax-true)
      (vla-get-modelspace dwg)
      (vla-get-paperspace dwg))))

(defun variantarray  (ptslist / arrayspace sarray)
  (setq arrayspace
(vlax-make-safeArray
   vlax-vbDouble
   (cons 0
(- (length ptslist) 1))))
  (setq sarray (vlax-safeArray-fill arrayspace ptslist))
  (vlax-make-variant sarray))

(defun getbulge (p1 midp p2 / ang chord midc alt)
  (setq ang   (angle p1 p2)
chord (distance p1 p2)
midc  (polar p1 ang (* chord 0.5))
alt   (distance midp midc))
  (cond
    ((zerop chord) 0.0)
    ((equal (angle midp midc)
    (rem (+ ang (* pi 0.5)) (* pi 2))
    1e-4)
     (/ alt chord 0.5))
    (t (/ alt chord -0.5))))

(defun poner_color  (obj color_use)
  (if (wcmatch (getvar "acadver") "16*")
    (setq vla_truecolor
   (vla-getinterfaceobject
     (vlax-get-acad-object)
     "AutoCAD.AcCmColor.16")))
  (if (wcmatch (getvar "acadver") "16*")
    (progn
      (vla-put-colorindex
vla_truecolor
color_use)
      (if obj
(vla-put-truecolor obj vla_truecolor)))
    (if (wcmatch (getvar "acadver") "15*")
      (vla-put-color obj color_use)))
  (vlax-release-object vla_truecolor)
  (setq vla_truecolor nil))

(defun circ_poly  (obj / ctr radio a b c d pts vla_poly color_use)
  (if (wcmatch (getvar "acadver") "16*")
    (setq color_use (vla-get-colorindex (vla-get-truecolor obj))))
  (if (wcmatch (getvar "acadver") "15*")
    (setq color_use (vla-get-color obj)))
  (setq ctr   (vlax-get obj 'center)
radio (vlax-get obj 'radius)
a     (polar ctr pi radio)
b     (polar ctr 0.0 radio)
c     (polar ctr (* pi 0.5) radio)
d     (polar ctr (* pi 1.5) radio)
pts   (mapcar '2dpt (list a b)))
  (if (not (vl-catch-all-error-p
     (setq vla_poly
    (vl-catch-all-apply
      'vla-addlightweightpolyline
      (list (activespace)
    (variantarray (apply 'append pts)))))))
    (vla-put-closed vla_poly t))
  (vla-setbulge
    vla_poly
    0
    (getbulge a c b))
  (vla-setbulge
    vla_poly
    1
    (getbulge b d a))
  (poner_color vla_poly color_use)
  vla_poly)

(defun C:C2P  (/ ename)
  (if (and (setq ename (car (entsel "\nSelect circle: ")))
   (circ_poly (vlax-ename->vla-object ename)))
    (entdel ename))
  (princ))

(princ)
Logged

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Problem with code
« Reply #7 on: August 02, 2006, 09:55:28 AM »
Quote from: lispman21 on August 02, 2006, 09:43:41 AM
A drawing is attached and the code doesn't work right in this drawing.
Only for your file
Code: [Select]
(defun C:C>LW (/ C D SS)
;(C:C>LW)
  (if (setq ss (ssget "_X" '((0 . "CIRCLE"))))
    (foreach e (mapcar
                 (function entget)
                 (vl-remove-if
                   (function listp)
                   (mapcar
                     (function cadr) (ssnamex ss))
                 ) ;_ vl-remove-if
               ) ;_  mapcar
      (entmakex
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          (assoc 8 e)
          (if (assoc 62 e)
            (assoc 62 e)
            '(62 . 256)
          ) ;_  if
          '(100 . "AcDbPolyline")
          '(90 . 4)
          '(70 . 1)
          (list 10 (+ (car (setq c (cdr (assoc 10 e)))) (setq d (cdr (assoc 40 e))))(cadr c))
          '(42 . 0.4142135623730951)
          (list 10 (car c) (+ (cadr c) d))
          '(42 . 0.4142135623730951)
          (list 10 (- (car c) d) (cadr c))
          '(42 . 0.4142135623730951)
          (list 10 (car c) (- (cadr c) d))
          '(42 . 0.4142135623730951)
          (assoc 210 e)
        ) ;_  list
      ) ;_  entmakex
      (entdel (cdr(assoc -1 e)))
    ) ;_  foreach
  ) ;_  if
) ;_  defun

(defun C:LW>C (/ P1 P2 SS)
;(C:LW>C)
  (if (setq ss (ssget "_X"
                      '((0 . "LWPOLYLINE")
                        (90 . 4)
                        (70 . 1)
                        (42 . 0.4142135623730951)
                        (42 . 0.4142135623730951)
                        (42 . 0.4142135623730951)
                        (42 . 0.4142135623730951)
                       )
               ) ;_  ssget
      ) ;_  setq
    (foreach e (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss)))
      (entmakex
        (list
          '(0 . "CIRCLE")
          (assoc 8 (entget e))
          (if (assoc 62 (entget e)) (assoc 62 (entget e)) '(62 . 256))
          (cons 10
            (setq
              p1 (mapcar (function (lambda (x1 x2) (/ (+ x1 x2) 2.)))
                         (setq p2 (vlax-curve-getPointAtParam e 0))
                         (vlax-curve-getPointAtParam e 2)
                 ) ;_  mapcar
            ) ;_  setq
          ) ;_  cons
          (cons 40 (distance p1 p2))
        ) ;_  list
      ) ;_  entmakex
      (entdel e)
    ) ;_  foreach
  ) ;_  if
) ;_  defun
Logged

lispman21

  • Guest
Re: Problem with code
« Reply #8 on: August 02, 2006, 10:08:25 AM »
OK, Both of the previous codes worked exactly like I wanted them too.  Although Esquivel's code did not automatically select the circles it required user input.  Which really isn't that big of a change, just what I was looking for. Thanks Everyone.
Logged

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Problem with code
« Reply #9 on: August 02, 2006, 10:58:58 AM »
lispman21
Sorry I did not have more time before.
I see you got help before I could get back.
There were several errors in your code and when corrected it did work.

Code: [Select]
(defun c2p (/ oldvar1 ss1 ename elist pt dia lay)

  (alert "\nConverting Circles to PLines\n")

  (command ".undo" "Mark")
  (setq oldvar1 (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)

  (setq ss1 (ssget "X" '((0 . "CIRCLE"))))
  (setq i -1)
  (while (setq ename (ssname ss1 (setq i (1+ i))))
    (setq elist (entget ename))
    (setq dia (* 2 (cdr (assoc 40 elist))))
    (setq pt (cdr (assoc 10 elist)))
    (setq lay (cdr (assoc 8 elist)))
    (command "donut" dia dia "non" (trans pt ename 0) "")
    (setq elist (entget (entlast)))
    (entmod (subst (cons 8 lay) (assoc 8 elist) elist))
  )
  (command "ERASE" ss1 "")
  (setvar "CMDECHO" oldvar1)
  (prompt (strcat "\n" "Erasing original Circles..." "\n"))
  (princ)
)
<edit: added trans>
« Last Edit: August 03, 2006, 12:29:48 AM by CAB »
Logged
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: Problem with code
« Reply #10 on: August 02, 2006, 12:14:41 PM »
O/T:

Code: [Select]
(defun IsEsquivelAlias ( memberName )
    (member (strcase memberName)
       '(   
            "ESQUIVEL"
            "LE"
            "LUIS ESQUIVEL"
            "LUIS"           
            "ROBERT ZIMMERMAN"
            "ZIMMERMAN"
        )   
    )
)
Just tryin' to keep up.
Logged
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

LE

  • Guest
Re: Problem with code
« Reply #11 on: August 02, 2006, 12:17:50 PM »
Quote from: MP on August 02, 2006, 12:14:41 PM
O/T:

Code: [Select]
(defun IsEsquivelAlias ( memberName )
    (member (strcase memberName)
       '(   
            "ESQUIVEL"
            "LE"
            "LUIS ESQUIVEL"
            "LUIS"           
            "ROBERT ZIMMERMAN"
            "ZIMMERMAN"
        )   
    )
)
Just tryin' to keep up.

He he.... none of them is my real name  :roll:
Logged

nivuahc

  • Guest
Re: Problem with code
« Reply #12 on: August 02, 2006, 12:56:19 PM »
How's this?

Code: [Select]
(defun IsJoseRodriguezAlias ( memberName )
    (member (strcase memberName)
       '(   
            "ESQUIVEL"
            "LE"
            "LUIS ESQUIVEL"
            "LUIS"           
            "ROBERT ZIMMERMAN"
            "ZIMMERMAN"
        )   
    )
)
« Last Edit: August 02, 2006, 12:58:54 PM by nivuahc »
Logged

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: Problem with code
« Reply #13 on: August 02, 2006, 12:58:34 PM »
Quote from: nivuahc on August 02, 2006, 12:56:19 PM
Code: [Select]
(defun IsJoseRodriguezAlias ( memberName )
    (member (strcase memberName)
       '(   
            "ESQUIVEL"
            "LE"
            "LUIS ESQUIVEL"
            "LUIS"           
            "ROBERT ZIMMERMAN"
            "ZIMMERMAN"
        )   
    )
)

 :lmao:
Logged
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com • http://cadanalyst.slack.com • http://linkedin.com/in/cadanalyst

LE

  • Guest
Re: Problem with code
« Reply #14 on: August 02, 2006, 01:04:36 PM »
Aha.... so we have spy's here that work undercover for the swamp?..... (nope, Jose Rodriguez is one of my best friends (he is from Texas) and lives now here in SD. - the PC I used here in my office still have his setup, when he was working here...)

As many, that do not want to say their real names... I'll kept Luis Esquivel....  :kewl:
« Last Edit: August 02, 2006, 01:06:25 PM by LE »
Logged

Bobby C. Jones

  • Swamp Rat
  • Posts: 516
  • Cry havoc and let loose the dogs of war.
Re: Problem with code
« Reply #15 on: August 02, 2006, 02:27:38 PM »
Quote from: LE on August 02, 2006, 01:04:36 PM
As many, that do not want to say their real names...
I have a pen name, but I'm not giving it up.  You'll all just have to be happy with my real name!  :-)
Logged
Bobby C. Jones

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Problem with code
« Reply #16 on: August 02, 2006, 04:14:55 PM »
Quote from: Bobby C. Jones on August 02, 2006, 02:27:38 PM
Quote from: LE on August 02, 2006, 01:04:36 PM
As many, that do not want to say their real names...
I have a pen name, but I'm not giving it up.  You'll all just have to be happy with my real name!  :-)

hehehe .. me too.  If I was inventing a name it would be Bob something I think ..

I thought Luis changed his signin name each day to match his Tshirt ... is this not the case ?
Logged
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

LE

  • Guest
Re: Problem with code
« Reply #17 on: August 02, 2006, 04:17:30 PM »
Quote from: Kerry Brown on August 02, 2006, 04:14:55 PM
I thought Luis changed his signin name each day to match his Tshirt ... is this not the case ?

Wow;   :-o -  good guess, man....  :kewl:
Logged
Pages: 1 2 [All] |   Go Up
« previous next »