Topic: Need lisp generate symbol of cutting/terrain

[fmn76]

Hi..there.. i have a problem to generate my symbols cutting.. Manually i just used command 'measure' then i scale that blocks.. how to make this so fast.... c below... sorry my english not so good.

[CAB]

Welcome to the Swamp.
What i your primary language?

Perhaps a sample DWG will help explain your request as I don't understand yet.

[Kerry]

I imagine Prompt something like :-

Select "Top Cutting" line (at start end) :
Select "Btm Cutting" line :
Nominate symbol spacing :

logic ;

locate symbol block spaced along and aligned with the top line, scaled so that the symbol is contained between and touching both the top an bottom lines (refer appendix 3.2 for sketch detail)

[fmn76]

hmmm.. like that Kerry....

[Kerry]

Sortof Like this ??

[Kerry]

Code and attachments ..

this is metric 'cause I work metric.
The block is uniformly scaled, built at 1 unit length.

all care, no responsibility
enjoy,
/// kwb

Code: [Select]


(DEFUN c:test (/             SETOUTANGLE
               INSERTPOINT   L01-DATA
               L01-END       L01-ENT
               L01-PP        L01-START
               L02-DATA      L02-END
               L02-ENT       L02-PP
               L02-START     RET
               ROTANG        SETOUTPOINT
               SYMBOLCOUNT   SYMBOLSCALE
               SYMBOLSPACING TMP
               TOPLENGTH
               ;;
               _insertSymbol
              )
    ;;
    ;; codehimbelonga kwb@theswamp  20070720 
;;;----------------------------------------
    ;; add error trapping
;;;----------------------------------------     
    (DEFUN _insertSymbol (/)
        (SETQ tmp         (INTERS
                              ;;(POLAR insertPoint (+ g:setoutAngle (* PI 1.5)) 1) <<-- kwb
                              (POLAR insertPoint (+ setoutAngle (* PI 1.5)) 1)
                              insertPoint
                              L02-start
                              L02-end
                              nil
                          )
              rotang      (ANGLE insertPoint tmp)
              SymbolScale (ABS (DISTANCE insertPoint tmp))
        )
        (VL-CMDF "-Insert"
                 "cut-symbol"
                 insertPoint
                 (RTOS SymbolScale)
                 (kdub:rtd rotang)
        )
    )
;;;----------------------------------------   
    (SETQ tmp      (kdub:objsel "Select Top line at start end "
                                '("LINE" "LWPOLYLINE")
                                T
                   )
          L01-ent  (CAR tmp)
          L01-data (ENTGET L01-ent)
          L01-pp   (OSNAP (CADR tmp) "nea")
    )
    (SETQ tmp      (kdub:objsel "Select Bottom line "
                                '("LINE" "LWPOLYLINE")
                                T
                   )
          L02-ent  (CAR tmp)
          L02-data (ENTGET L02-ent)
          L02-pp   (OSNAP (CADR tmp) "nea")
    )
    ;;
    ;; Top Line
    (IF (= "LWPOLYLINE" (kdub:getass 0 L01-data))
        (SETQ ret       (kdub:getsegment L01-ent L01-pp)
              L01-start (CADR ret)
              L01-end   (CADDR ret)
        )
        (SETQ L01-start (kdub:getass 10 L01-data)
              L01-end   (kdub:getass 11 L01-data)
        )
    )
    ;;
    ;; Bottom Line
    (IF (= "LWPOLYLINE" (kdub:getass 0 L02-data))
        (SETQ ret       (kdub:getsegment L02-ent L02-pp)
              L02-start (CADR ret)
              L02-end   (CADDR ret)
        )
        (SETQ L02-start (kdub:getass 10 L02-data)
              L02-end   (kdub:getass 11 L02-data)
        )
    )
    ;;----------
    (SETQ setoutPoint   (IF (< (DISTANCE L01-start L01-pp)
                               (DISTANCE L01-end L01-pp)
                            )
                            L01-start
                            L01-end
                        )
          setoutAngle   (ANGLE setoutPoint L01-pp)
          TopLength     (DISTANCE L01-start L01-end)
          ;;---
          SymbolSpacing (GETDIST (STRCAT "\nSymbol spacing (Top Length is "
                                         (RTOS TopLength)
                                         ") : "
                                 )
                        )
          SymbolCount   (FIX (/ (- TopLength (* 0.5 SymbolSpacing))
                                SymbolSpacing
                             )
                        )
          insertPoint   (POLAR setoutPoint
                               setoutAngle
                               (* 0.5 SymbolSpacing)
                        )
    )
    ;;(VL-CMDF "point" setoutPoint)
    ;;(VL-CMDF "point" insertPoint)
    (_insertSymbol)
    (REPEAT SymbolCount
        (SETQ insertPoint
                 (POLAR insertPoint setoutAngle SymbolSpacing)
        )
        (_insertSymbol)
    )
    (PRINC)
)
;;;------------------------------------------------------------------






;;;------------------------------------------------------------------
;; library Routines
;;;------------------------------------------------------------------

(DEFUN kdub:2dPoint (Point) (LIST (CAR Point) (CADR Point)))

;;;------------------------------------------------------------------

(DEFUN kdub:rtd (ang) (/ (* ang 180.0) PI))

;;;------------------------------------------------------------------

(DEFUN kdub:getsegment (obj pt / cpt eparam stparam)
    ;; original ver by Stig Madsen
    ;;
    (COND ((SETQ cpt (VLAX-CURVE-GETCLOSESTPOINTTO obj pt T))
           (SETQ eparam (FIX (VLAX-CURVE-GETENDPARAM obj)))
           (IF (= eparam
                  (SETQ stparam
                           (FIX (VLAX-CURVE-GETPARAMATPOINT obj cpt)
                           )
                  )
               )
               (SETQ stparam (1- stparam))
               (SETQ eparam (1+ stparam))
           )
           (LIST eparam
                 (VLAX-CURVE-GETPOINTATPARAM obj stparam)
                 (VLAX-CURVE-GETPOINTATPARAM obj eparam)
           )
          )
    )
)

;;;------------------------------------------------------------------

(DEFUN kdub:getass (key data /) (CDR (ASSOC key data)))

;;;------------------------------------------------------------------
;; typelist : List of entity types allowed to be selected
;; nentselflag : If true nentsel permitted , otherwise use entsel.
;;
(DEFUN kdub:objsel
       (Promptmsg typelist nentselflag / pickok returnvalue tmp)
    (SETQ Promptmsg (STRCAT "\n"
                            (COND (Promptmsg)
                                  ("Select object")
                            )
                            " : "
                    )
    )
    (WHILE (NOT pickok)
        (SETVAR "ERRNO" 0)
        (SETQ returnvalue (IF nentselflag
                              (NENTSEL Promptmsg)
                              (ENTSEL Promptmsg)
                          )
        )
        (COND
            ((= (GETVAR "ERRNO") 52)                        ; enter
             ;; skip out
             (SETQ pickok T)
            )
            ((= (GETVAR "ERRNO") 7)
             (PRINC "Nothing found at selectedpoint. ")
            )
            ((AND (SETQ tmp (ENTGET (CAR returnvalue)))     ; object type
                  typelist
                  (NOT (MEMBER (CDR (ASSOC 0 tmp))
                               (MAPCAR 'STRCASE typelist)
                       )
                  )
             )                                              ; wrong type
             (ALERT
                 (STRCAT
                     "Selected object is not"
                     "\na "
                     (APPLY
                         'STRCAT
                         (CONS (CAR typelist)
                               (MAPCAR '(LAMBDA (x) (STRCAT "\nor " x))
                                       (CDR typelist)
                               )
                         )
                     )
                     ". "
                 )
             )
            )
            ;; skip out
            ((SETQ pickok T))
        )
    )
    returnvalue
)
;;;------------------------------------------------------------------


edit:
revised as noted.

[Adesu]

Wow....it's great, I like that.

Sortof Like this ??

[Kerry]

Thanks Adesu,

that was fun to build

.. Should work with lines and Plines ...

[fmn76]

Kerry ... im try ur lisp but have error like this

Command: test

Select Top line at start end  :
Select Bottom line  : Symbol spacing (Top Length is 3.7307) :  Specify second
point: ; error: bad argument type: numberp: nil

im used autodesk map 2004

[Kerry]

Revised . I was clumsy.

;;(POLAR insertPoint (+ g:setoutAngle (* PI 1.5)) 1) <<-- kwb
   (POLAR insertPoint (+ setoutAngle (* PI 1.5)) 1)

[It's Alive!]

Wow! that's nice Kerry.

About those function names

kdub:getass

 

[Kerry]

Dan,
yep, like some others here, I enjoy my code ..

[CAB]

Nice one Kerry, I slept through the whole thing. 

[Mark]

Very nice KB.

[Kerry]

Nice one Kerry, I slept through the whole thing. 

funny, that usually happens to me ..