[编程交流] DCL和Lisp的帮助

intersections : dialog 
{ label = "ΚΑΤΑΣΚΕΥΕΣ  ΣΗΜΕΙΩΝ                Topocad 2017";
 spacer_1;
 : text_part { label = "Επιλέξτε είδος Κατασκευής Σημείου :" ; alignment = left; }   
 spacer_1;
 
 : row
 { children_height = 8.0; children_width = 29.0; children_fixed_width = true; children_fixed_height = true;
   : image_button  { key = "me" ; color = graphics_background; }     
   : image_button { key = "te" ; color = graphics_background; }     
 }
 : row
 { children_height = 8.0; children_width = 29.0; children_fixed_width = true; children_fixed_height = true;
   : image_button  { key = "pse" ; color = graphics_background; }     
   : image_button { key = "tk" ; color = graphics_background; }     
 }
 spacer_1; ok_cancel; : errtile { width = 34; }
}

(start_image "icon_noi")
     (slide_image 0 0 (- (dimx_tile "icon_noi") 1) (- (dimy_tile "icon_noi") 1) "BIG-ALblank")
     (end_image)

; Slides Example
(defun C:test ( / L *error* dcl des dch dcf slidefiles r )
 
 (setq L 
   '(
     ("te" ; inter 
       ( 
         (lambda ( / o1 o2 )
           (and (setq o1 (car (entsel "\nFirst Object: "))) (setq o2 (car (entsel "\nSecond Object: ")))
             (foreach p (LM:Intersections (vlax-ename->vla-object o1) (vlax-ename->vla-object o2) acextendboth)
               (entmake (list '(0 . "POINT") (cons 10 p)))
             )
           )
         )
       )
     )
     ("tk" ; interset
       ( 
         (lambda ( SS ) (if SS (foreach p (LM:intersectionsinset SS) (entmake (list '(0 . "POINT") (cons 10 p))) ) ) )
         (progn (princ "\nSelect objects to intersect: ") (ssget) )
       )
     )
     ("pse" ; perpt
       ( 
         (lambda ( / dis enx pt1 pt2 pt3 sel tmp )
           (while
             (not
               (progn (setvar 'errno 0) (setq sel (entsel "\nSelect line or polyline segment: "))
                 (cond ( (= 7 (getvar 'errno)) (prompt "\nMissed, try again.") ) ( (null sel) )
                   ( (= "LINE" (cdr (assoc 0 (setq enx (entget (car sel))))))
                     (setq 
                       pt1 (trans (cdr (assoc 10 enx)) 0 1)
                       pt2 (trans (cdr (assoc 11 enx)) 0 1)
                       dis (distance pt1 pt2)
                     )
                   )
                   ( (= "LWPOLYLINE" (cdr (assoc 0 enx)))
                     (setq 
                       tmp (vlax-curve-getclosestpointto (car sel) (trans (cadr sel) 1 0))
                       tmp (fix (+ 1e-8 (vlax-curve-getparamatpoint (car sel) tmp)))
                       pt1 (trans (vlax-curve-getpointatparam (car sel)     tmp)  0 1)
                       pt2 (trans (vlax-curve-getpointatparam (car sel) (1+ tmp)) 0 1)
                       dis (distance pt1 pt2)
                     )
                   )
                   ( (prompt "\nThe selected object is not a line or 2D polyline.") )
                 )
               )
             )
           )
           (if (and pt1 pt2 (setq pt3 (getpoint "\nSpecify 3rd point: ")))
             (entmake
               (list '(000 . "POINT") '(008 . "section")
                 (cons 010 (trans (polar pt1 (angle pt1 pt2) (apply '+ (mapcar '* (mapcar '- pt3 pt1) (mapcar '(lambda ( a b ) (/ (- a b) dis)) pt2 pt1) ) ) ) 1 0) )
                 (cons 210 (trans '(0 0 1) 1 0 t))
               )
             )
           )
           (princ)
         )
       )
     )
     ("me" ; MidPl
       ( 
         (lambda ( / e enx o prm mp )
           (and
             (setq e (car (entsel "\nSelect line: "))) (setq enx (entget e))
             (member (cdr (assoc 0 enx)) '("POLYLINE" "LWPOLYLINE" "LINE"))
             (setq o (vlax-ename->vla-object e)) (setq prm (vlax-curve-getEndParam o))
             (setq mp (vlax-curve-getPointAtDist o (* 0.5 (vlax-curve-getDistAtParam o prm))))
             (entmake (list '(0 . "POINT") (cons 10 mp)))
             (princ (strcat "\nPoint object created at mid-point: " (vl-prin1-to-string mp))) (princ)
           )
         )
       )
     )
   ); list
 ); setq L 
 
 (defun *error* ( msg )
   (and (< 0 dch) (unload_dialog dch))
   (and (eq 'FILE (type des)) (close des))
   (and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
   (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)) ))
   (princ)
 ); defun *error*
 
 
 (cond
   ( 
     (progn 
       (setq slidefiles (mapcar '(lambda (x) (strcat x ".sld")) '("me" "te" "pse" "tk"))) ; <- adjust slidernames
       (vl-some '(lambda (x) (if (not (findfile x)) (princ (strcat "\nUnable to find "" x "" file.")))) slidefiles) 
     )
   )
   (
     (not
       (and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
         (princ 
           (apply 'strcat
             (mapcar (function (lambda (x) (apply 'strcat (mapcar 'chr x))))
               '(
                 (116 101 115 116 32 58 32 100 105 97 108 111 103 32) (123 32 108 97 98 101 108 32 61 32 34 73 110 116 101 114 115 101 99 116 105 111 110 115 34 59)
                 (32 32 58 32 98 111 120 101 100 95 99        111 108        117 109        110 32)
                 (32 32 123 32 108 97 98 101 108 32 61        32 34 67 104 111        111 115 101 32 97 99 116 105 111 110 34 59 32        115 112 97 99 101 114 95 49        59)
                 (32 32 32 32 58 32 114 111 119 32)
                 (32 32 32        32 123 32 99 104 105 108 100 114 101 110 95 102 105 120 101 100 95 119 105 100 116 104 32 61 32        116 114 117 
                   101 59 32 99 104 105 108 100 114 101 110 95 102 105 120 101 100 95 104 101 105 103 104 116 32 61 32 116 114 117 101 59
                 )
                 (32 32 32        32 32 32 58 32 105 109 97 103 101 95 98 117        116 116 111 110 32 32 123 32 107 101 121 32 61 32 34 109 101 34 59 32 104        101 105 103
                   104 116        32   61          32   49   50         59   32   119        105  100  116 104 32        61   32          51   50   59         32   99   111        108  111  114
                   32 61        32   103  114  97   112         104  105  99        115  95          98 97 99        107  103  114  111  117         110  100  59        32   125
                 )
                 (32 32 32        32 32 32   58   32         105  109  97        103  101  95 98 117 116 116  111  110  32         123  32   107        101  121  32
                   61 32        34 116 101  34   59         32   104  101        105  103  104 116 32        61 32          49   50   59         32   119  105        100  116  104
                   32 61        32 51 50   59   32         99   111  108        111  114  32 61 32        103 114  97   112  104         105  99   115        95   98          97
                   99 107        103  114  111  117  110         100  59   32        125
                 )
                 (32 32 32 32 125) (32 32 32 32 58 32 114 111 119 32)
                 (32 32   32        32   123  32   99   104         105  108  100        114  101  110 95   102        105  120  101  100  95         119  105  100        116  104  32
                   61   32        116  114  117  101  59         32   99   104        105  108  100 114  101        110  95          102  105  120         101  100  95        104  101  105
                   103  104        116  32          61   32   116         114  117  101        59
                 )
                 (32 32   32        32   32          32   58   32         105  109  97        103  101  95 98 117        116  116  111  110  32         32   123  32        107  101  121
                   32   61        32   34          112  115  101         34   59   32        104  101  105 103  104        116  32          61   32   49         50   59   32        119  105  100
                   116  104        32   61          32   51   50         59   32   99        111  108  111 114  32        61   32          103  114  97         112  104  105        99   115  95
                   98   97        99   107  103  114  111         117  110  100        59   32          125
                 )
                 (32 32   32        32   32          32   58   32         105  109  97        103  101  95 98   117        116  116  111  110  32         123  32   107        101  121  32
                   61   32        34   116  107  34   59         32   104  101        105  103  104 116  32        61   32          49   50   59         32   119  105        100  116  104
                   32   61        32   51          50   59   32         99   111  108        111  114  32 61   32        103  114  97   112  104         105  99   115        95   98          97
                   99   107        103  114  111  117  110         100  59   32        125
                 )
                 (32 32 32 32 125) (32 32 125)
                 (32 32 115 112 97 99 101 114 95 49 59 32 111 107 95 111 110 108 121 59 32 58 32 116 101 120
                   116 32 123 32 108 97 98 101 108 32 61 32 34 67 114 101 100 105 116 115 32 116 111 58 32 76
                   101 101 32 77 97 99 34 59 32 97 108 105 103 110 109 101 110 116 32 61 32 114 105 103 104 116 59 32 125
                 )
                 (125)
               )
             )
           )
           des
         )
         (not (setq des (close des))) (< 0 (setq dch (load_dialog dcl))) 
       ); and
     ); not
     (princ "\nUnable to write or load the DCL file.")
   )
   ( (not (new_dialog "test" dch)) (princ "\nUnable to display the dialog") )
   (
     (progn 
       (mapcar (function (lambda (x) (action_tile x (vl-prin1-to-string '(progn (done_dialog 1) (setq r $key)))))) '("me" "te" "pse" "tk") )
       (mapcar 
         (function
           (lambda ( key sld / w h ) ; (slide_image x1 y1 width height sldname)
             (setq w (1- (dimx_tile key))) (setq h (1- (dimy_tile key)))  
             (start_image key) (fill_image 0 0 w h 0) (slide_image 0 0 w h sld) (end_image) ; (fill_image ...) might be redundant
             ; (start_image "me") (slide_image 0 0 (1- (dimx_tile "me")) (1- (dimy_tile "me")) "SlideName.sld") (end_image)
           )
         )
         '("me" "te" "pse" "tk") slidefiles
       )
       (action_tile "accept" (vl-prin1-to-string '(progn (princ "\nBye!") (done_dialog 2))))
       (/= 1 (setq dcf (start_dialog)))
     ); progn
     (princ) ; (princ "\nUser cancelled the dialog.")
   )
   (T (eval (cadr (assoc r L))) )
 ); cond
 (*error* nil) (princ) 
); defun 
;;--------------------=={ Intersections }==-------------------;;
;;                                                            ;;
;;  Returns a list of all points of intersection between      ;;
;;  two objects for the given intersection mode.              ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2012 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  obj1, obj2 - VLA-Objects                                  ;;
;;  mode       - acextendoption enum of intersectwith method  ;;
;;------------------------------------------------------------;;
;;  Returns:  List of intersection points, or nil             ;;
;;------------------------------------------------------------;;
(defun LM:Intersections ( obj1 obj2 mode / l r )
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
   (setq r (cons (list (car l) (cadr l) (caddr l)) r)
     l (cdddr l)
   )
 )
 (reverse r)
)
;; Intersections in Set  -  Lee Mac
;; Returns a list of all points of intersection between all objects in a supplied selection set.
;; sel - [sel] Selection Set
(defun LM:intersectionsinset ( sel / id1 id2 ob1 ob2 rtn )
 (repeat (setq id1 (sslength sel))
   (setq ob1 (vlax-ename->vla-object (ssname sel (setq id1 (1- id1)))))
   (repeat (setq id2 id1)
     (setq ob2 (vlax-ename->vla-object (ssname sel (setq id2 (1- id2))))
       rtn (cons (LM:intersections ob1 ob2 acextendnone) rtn)
     )
   )
 )
 (apply 'append (reverse rtn))
)

(mapcar (function (lambda (x) (apply 'strcat (mapcar 'chr x))))
               '(
                 (116 101 115 116 32 58 32 100 105 97 108 111 103 32) (123 32 108 97 98 101 108 32 61 32 34 73 110 116 101 114 115 101 99 116 105 111 110 115 34 59)
                 (32 32 58 32 98 111 120 101 100 95 99        111 108        117 109        110 32)
                 (32 32 123 32 108 97 98 101 108 32 61        32 34 67 104 111        111 115 101 32 97 99 116 105 111 110 34 59 32        115 112 97 99 101 114 95 49        59)
                 (32 32 32 32 58 32 114 111 119 32)
                 (32 32 32        32 123 32 99 104 105 108 100 114 101 110 95 102 105 120 101 100 95 119 105 100 116 104 32 61 32        116 114 117 
                   101 59 32 99 104 105 108 100 114 101 110 95 102 105 120 101 100 95 104 101 105 103 104 116 32 61 32 116 114 117 101 59
                 )
                 (32 32 32        32 32 32 58 32 105 109 97 103 101 95 98 117        116 116 111 110 32 32 123 32 107 101 121 32 61 32 34 109 101 34 59 32 104        101 105 103
                   104 116        32   61          32   49   50         59   32   119        105  100  116 104 32        61   32          51   50   59         32   99   111        108  111  114
                   32 61        32   103  114  97   112         104  105  99        115  95          98 97 99        107  103  114  111  117         110  100  59        32   125
                 )
                 (32 32 32        32 32 32   58   32         105  109  97        103  101  95 98 117 116 116  111  110  32         123  32   107        101  121  32
                   61 32        34 116 101  34   59         32   104  101        105  103  104 116 32        61 32          49   50   59         32   119  105        100  116  104
                   32 61        32 51 50   59   32         99   111  108        111  114  32 61 32        103 114  97   112  104         105  99   115        95   98          97
                   99 107        103  114  111  117  110         100  59   32        125
                 )
                 (32 32 32 32 125) (32 32 32 32 58 32 114 111 119 32)
                 (32 32   32        32   123  32   99   104         105  108  100        114  101  110 95   102        105  120  101  100  95         119  105  100        116  104  32
                   61   32        116  114  117  101  59         32   99   104        105  108  100 114  101        110  95          102  105  120         101  100  95        104  101  105
                   103  104        116  32          61   32   116         114  117  101        59
                 )
                 (32 32   32        32   32          32   58   32         105  109  97        103  101  95 98 117        116  116  111  110  32         32   123  32        107  101  121
                   32   61        32   34          112  115  101         34   59   32        104  101  105 103  104        116  32          61   32   49         50   59   32        119  105  100
                   116  104        32   61          32   51   50         59   32   99        111  108  111 114  32        61   32          103  114  97         112  104  105        99   115  95
                   98   97        99   107  103  114  111         117  110  100        59   32          125
                 )
                 (32 32   32        32   32          32   58   32         105  109  97        103  101  95 98   117        116  116  111  110  32         123  32   107        101  121  32
                   61   32        34   116  107  34   59         32   104  101        105  103  104 116  32        61   32          49   50   59         32   119  105        100  116  104
                   32   61        32   51          50   59   32         99   111  108        111  114  32 61   32        103  114  97   112  104         105  99   115        95   98          97
                   99   107        103  114  111  117  110         100  59   32        125
                 )
                 (32 32 32 32 125) (32 32 125)
                 (32 32 115 112 97 99 101 114 95 49 59 32 111 107 95 111 110 108 121 59 32 58 32 116 101 120
                   116 32 123 32 108 97 98 101 108 32 61 32 34 67 114 101 100 105 116 115 32 116 111 58 32 76
                   101 101 32 77 97 99 34 59 32 97 108 105 103 110 109 101 110 116 32 61 32 114 105 103 104 116 59 32 125
                 )
                 (125)
               )