搜索一个指定点周边特定距离内的实体

山海G

怎样搜索一个指定点周边特定距离内的实体，并构成选择集（运行速度要快）。

meflying

(setq pta (list (- (car pt) dist) (- (cadr pt) dist)))
(setq ptb (list (+ (car pt) dist) (+ (cadr pt) dist)))
(ssget "c" pta ptb)/(ssget "w" pta ptb)

王咣生

;--------------------------------ExportMIF.lsp----------------------------------
; MODULE_ID EXPORTMIF_LSP_
;;;----------------------------------------------------------------------------
;;;    EXPORTMIF.LSP
;;;
;;;    Copyright 2003 by TJCH, Inc.
;;;
;;;    Modified Date: Jun 16,2003.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;----------------------------------------------------------------------------
;;;   DESCRIPTION
;;;
;;;   This function allows the user to export mif file from altitude points of
;;;   DWG file.
;;;
;;;----------------------------------------------------------------------------
;;;
;;; ===========================================================================
;;; ===================== load-time error checking ============================
;;;

  (defun ai_abort (app msg)
     (defun *error* (s)
        (if old_error (setq *error* old_error))
        (princ)
     )
     (if msg
       (alert (strcat " Application error: "
                      app
                      " \n\n  "
                      msg
                      "  \n"
              )
       )
     )
     (exit)
  )

;;; Check to see if AI_UTILS is loaded, if not, try to find it,
;;; and then try to load it.
;;;
;;; If it can't be found or it can't be loaded, then abort the
;;; loading of this file immediately, preserving the (autoload)
;;; stub function.

  (cond
     (  (and ai_dcl (listp ai_dcl)))        ; it's already loaded.

     (  (not (findfile "ai_utils.lsp"))        ; find it
        (ai_abort "EXPORTMIF"
                  (strcat "Can't locate file AI_UTILS.LSP"
                          "\n Check support directory.")))
     (  (eq "failed" (load "ai_utils" "failed"))        ;load it
        (ai_abort "EXPORTMIF" "Can't load file AI_UTILS.LSP"))
     
  )

  (if (not (ai_acadapp))                ; defined in AI_UTILS.LSP
      (ai_abort "EXPORTMIF" nil)                ; a Nil <msg> suppresses
  )                                        ; ai_abort's alert box dialog.

;;; ==================== end load-time operations ===========================


;;;----------------------------------------------------------------------------
;;;  The main program.
;;;----------------------------------------------------------------------------
(defun c:ExportMIF (/
                  ai_error        old_cmd                old_error
                  *error*        do_export_main        )
  
  ;;
  ;; Execute the main operation: match 98 altitude point to 93 altitude point
  ;;
   (defun do_export_main (/ GetScreenCorner do_layer make_set old_osn old_osm layerlist player
                            corner_list lb_corner rt_corner
                            dwg_path dwg_name name gcd93_set i gcd93_name gcd93_list gcd93_x gcd93_y
                            att_field_row)
      ;;
      ;; Get the screen size corner coordinates, the return value is a multiple-list compose of LB-P and RT-P.
      ;;
      (defun GetScreenCorner ( / cen_point height screen_size scale width rt_point lb_point corner_list)
        (command "_.UCS" "V")
        (setq cen_point (getvar "VIEWCTR"))
        (setq height (getvar "VIEWSIZE"))
        
        (setq screen_size (getvar "SCREENSIZE"))
        (setq scale (/ (car screen_size) (cadr screen_size)))
        (setq width (* scale height))
        
        (setq rt_point (list (+ (car cen_point) (/ width 2)) (+ (cadr cen_point) (/ height 2))))
        (setq lb_point (list (- (car cen_point) (/ width 2)) (- (cadr cen_point) (/ height 2))))

        (command "_.UCS" "")
        
        (setq corner_list (list lb_point rt_point))
      );_defun
     
      ;;
      ;; Get list of entire layer name.
      ;;
      (defun do_layer (/ start lyr)
         (setq start 1)
         (while (setq lyr (tblnext "LAYER" start))
           (setq start nil)
           (setq layerlist (append layerlist (list (strcase (cdr (assoc 2 lyr))))))
         )
      )
     
      ;;
      ;; Establishes a selection set and returns the name of the selection set.
      ;;
      (defun make_set (center radius n / ai ae ptl pt mini_set)
        (setq ai 0 ae (* PI 2.0))
        (while (< ai ae)
          (setq ptl (append ptl (list (POLAR center ai radius))))
          (setq ai (+ ai (/ ae n)))
        )
        (command "select" "cp")
        (foreach pt ptl (command pt))
        (command "" "")(command)
        (setq mini_set (ssget "p"))
        mini_set
      );_defun
     
      ;;
      ;; First find LWPOLYLINE, then return the current selection set.
      ;;
      (defun find_set (center n rMin rMax layer1 layer2 / ltext93 ltext98 loop radius sset i ename elist text93 text98 ep ret_val)
        (setq ltext93 nil ltext98 nil)
        (setq loop T)
        (setq radius rMin)
        (while (and loop (< radius rMax))
          (setq sset (make_set center radius n))
          (if sset
            (progn
              (setq i 0)
              (repeat (sslength sset)
                (setq ename (ssname sset i))
                (setq elist (entget ename))
                (cond
                  ((and
                      (= (cdr (assoc 0 elist)) "TEXT")
                      (= (strcase (cdr (assoc 8 elist))) layer1)
                   )
                   (setq ltext93 T)
                   (setq text93 (cdr (assoc 1 elist)))
                   (if (and ltext93 ltext98)
                     (setq loop nil)
                   )
                  );
                  ((and
                      (= (cdr (assoc 0 elist)) "TEXT")
                      (= (strcase (cdr (assoc 8 elist))) layer2)
                   )
                   (setq ltext98 T)
                   (setq text98 (cdr (assoc 1 elist)))
                   (if (and ltext93 ltext98)
                     (setq loop nil)
                   )
                  );
                );_cond
                (setq i (+ i 1))
              );_repeat
            );_progn
          ); _if
          (setq radius (+ radius 2))
        ); _while
        (if (not text93) (setq text93 ""))
        (if (not text98) (setq text98 ""))
        (setq ret_val (strcat "\"" text93 "\"" "," "\"" text98 "\""))
        ret_val
      );_defun
     
      (setq old_osn (getvar "osnapcoord"))
      (setvar "osnapcoord" 0)
      (setq old_osm (getvar "osmode"))
      (setvar "osmode" 0)
     
      (do_layer)                ; define layerlist

      ; testing layer.
      (setq player (list "gcd93" "gcd98"))
      (foreach la player
         (if (not (member (strcase la) layerlist))
           (progn
              (alert (strcat "No layer named "  la " exits."))
              (exit)
           )
        )
        (command "layer" "on" la "")        ; displays layers.
      )
      
      (command "zoom" "e")
      (setq corner_list (GetScreenCorner))
      (setq lb_corner (car corner_list))
      (setq rt_corner (cadr corner_list))
      (command "_.zoom" "w"
               (list (- (car lb_corner) 25)(- (cadr lb_corner) 25))
               (list (+ (car rt_corner) 25)(+ (cadr rt_corner) 25))
      )
     
      ; open files.
      (setq dwg_path (getvar "DWGPREFIX"))
      (setq dwg_name (getvar "DWGNAME"))
      (setq name (cadr (fnsplitl dwg_name)))

      (setq mif_id (open (strcat dwg_path name ".mif") "w"))
      (setq mid_id (open (strcat dwg_path name ".mid") "w"))
      (write-line "Version 300" mif_id)
      (write-line "Charset \"WindowsSimpChinese\"" mif_id)
      (write-line "Delimiter \",\"" mif_id)
      (write-line (strcat "CoordSys NonEarth Units \"m\" Bounds ("
                          (rtos (car lb_corner) 2 4) ", " (rtos (cadr lb_corner) 2 4)
                          ") ("
                          (rtos (car rt_corner) 2 4) ", " (rtos (cadr rt_corner) 2 4)
                          ")"
                  ) mif_id)
      (write-line "Columns 2" mif_id)
      (write-line "  高程93 Char(20)" mif_id)
      (write-line "  高程98 Char(20)" mif_id)
      (write-line "Data\n" mif_id)
     
      (setq gcd93_set (ssget "x" (list (cons 0 "OINT")(cons 8 "gcd93"))))
      (setq i 0)
      (repeat (sslength gcd93_set)
        (setq gcd93_name (ssname gcd93_set i))
        (setq gcd93_list (entget gcd93_name))
        (setq gcd93_x (cadr  (assoc 10 gcd93_list)))
        (setq gcd93_y (caddr (assoc 10 gcd93_list)))
        (write-line (strcat "oint " (rtos gcd93_x 2 2) " " (rtos gcd93_y 2 2)) mif_id)
        (write-line "    Symbol (35,0,12) " mif_id)
        (setq att_field_row (find_set (list gcd93_x gcd93_y) 10 0.1 3 "GCD93" "GCD98"))
        (write-line att_field_row mid_id)
        
        (setq i (+ i 1))
        (if (= (getvar "ACADVER") "14.0")
          (grtext -1 (strcat "waiting..." (itoa i))  0)
          (princ (strcat "\r" (itoa i)))
        )
      );_repeat
      (close mif_id)
      (close mid_id)

      (grtext -1 "" 0)
      (princ "\r")(repeat (strlen (itoa i)) (princ " "))
       
      (princ "\n Processing complete!")
      (princ (strcat "\n Total number:" (itoa i)))

      (setvar "osnapcoord" old_osn)
      (setvar "osmode" old_osm)
      (princ)
   )
  
   ;;
   ;; trap run-time error.
   ;;
   (defun ai_error (errmsg)
      (if (not (member errmsg '("console break" "Function Cancelled"
                              "bad argument type" "Function cancelled" "no function definition: DOS_GETPROGRESS"
                              "bad argument" "函数被取消" "quit / exit abort"))
              ) ;_ end of not
         (princ (strcat "\nError: " errmsg))
      )
      (princ)
   )

   ;; Set up error function.
   (setq old_cmd (getvar "cmdecho")        ; save current setting of cmdecho
        old_error  *error*                ; save current error function
        *error* ai_error                ; new error function
   )

   (setvar "cmdecho" 0)

   (cond
      (  (not (ai_notrans)))                ; transparent not OK
      (  (not (ai_acadapp)))                ; ACADAPP.EXP xloaded?

      (t (do_export_main))                        ; proceed! (GO!)
   )

   (setq *error* old_error)
   (setvar "cmdecho" old_cmd)
   (princ)
)
;;;----------------------------------------------------------------------------
(princ "ExportMIF")
(princ "\nType \"EXPORTMIF\" to run this routine.")
(princ)

我用该程序的目的是搜索高程点周围的文本(两个图层),然后写成Mif文件,用于MapInfo.

其中find_set函数调用了make_set函数,
(find_set center n rMin rMax ...) ,
   center为指定点,
   n 为多边形选取的边数,
   rMin为搜索范围的最小半径,
   rMax为搜索范围的最大半径
其余参数视需要而定.
make_set的选择方法,即多边形选取时要保证选取点在视区内,所以用程序控制时,
一般要先(command "zoom" "e")

山海G

谢谢！好主意！

龙龙仔

;|I want to draw a circle around an item.  Copy the only things are the
circle.  I don't want lines or text that run out of the circle to be copied.
I have seen this before.  Can someone help?  Maybe someone has a program
that I can use?|;

;;Select with pline or circle - by fence, window or crossing
(defun C:SSWITHOBJECT (/ *ERROR* OBJ OBJLST PTLST TPTLST SS COUNT TYP
                       CENPT RAD STPT STANG DIV        INCRANG        2NDANG
                      )
  (defun *ERROR* (MSG)
    (cond
      ((or (not MSG)
           (member MSG
                   '("console break"
                     "Function cancelled"
                     "quit / exit abort"
                    )
           )                                ;member
       )                                ;or
      )                                        ;condition, no message to display
      ((princ (strcat "\nError: " MSG))) ;else display message
    )                                        ;cond
    (setvar "cmdecho" 1)
    (princ)
  )                                        ;end error

  (defun ISCLOSED (POLY)
    (if        (= "LWPOLYLINE" (cdr (assoc 0 (entget POLY))))
      (= 1 (logand 1 (cdr (assoc 70 (entget POLY)))))
    )                                        ;if
  )                                        ;end

  (defun MASSOC        (KEY ALIST / X NLIST)
    (foreach X ALIST
      (if (eq KEY (car X))
        (setq NLIST (cons (cdr X) NLIST))
      )
    )
    (reverse NLIST)
  )                                        ;end

  ;;remove duplicate adjacent points from point list
  ;;arguments: OLST - pointlist, FUZ - fuzz distance
  (defun REMDUPPTS (OLST FUZ / NLST P1 P2)
    (while (> (length OLST) 1)
      (setq P1 (car OLST)
            P2 (cadr OLST)
      )
      (if (> (distance P1 P2) FUZ)
        (setq NLST (cons P1 NLST))
      )                                        ;if
      (setq OLST (cdr OLST))
    )                                        ;while
    (setq NLST (cons (last OLST) NLST))
    (reverse NLST)
  )                                        ;end

                                        ;start
  (setvar "cmdecho" 0)
  (sssetfirst)

  (initget 1 "F W C  ")
  (setq        TYP
         (getkword
           "\nSelect by (F)ence, (W)indow inside or (C)rossing <C>: "
         )
  )
  (if (or (= TYP "") (= TYP "C"))
    (setq TYP "C")
  )                                        ;if

  (cond
    ((= TYP "W")
     (prompt
       "\nSelect circle or pline to define Window selection set:"
     )
    )
    ((= TYP "C")
     (prompt
       "\nSelect circle or pline to define Crossing selection set:"
     )
    )
    ((= TYP "F")
     (prompt
       "\nSelect circle or pline to define Fence selection set:"
     )
    )
  )                                        ;conditions

  (setq OBJ (car (entsel)))
  (while
    (or
      (null OBJ)
      (and
        (/= "LWPOLYLINE" (cdr (assoc 0 (entget OBJ))))
        (/= "CIRCLE" (cdr (assoc 0 (entget OBJ))))
      )                                        ;and
    )                                        ;or
     (princ
       "\nSelection was not a pline or circle - try again..."
     )
     (setq OBJ (car (entsel)))
  )                                        ;while

  (setq OBJLST (entget OBJ))

  (cond
    ((= "LWPOLYLINE" (cdr (assoc 0 OBJLST)))
     (setq PTLST (MASSOC 10 (entget OBJ)))
    )                                        ;cond pline

    ((= "CIRCLE" (cdr (assoc 0 OBJLST)))
     (setq CENPT   (cdr (assoc 10 OBJLST)) ;center pt
           RAD           (cdr (assoc 40 OBJLST)) ;radius
           STPT           (polar CENPT 0.0 RAD) ;start pt
           STANG   0.0                        ;start angle
           DIV           360                        ;number of divisions
           INCRANG (/ pi 180)                ;increment angle
           2NDANG  (+ STANG INCRANG)        ;second angle
           PTLST   (list STPT)
     )                                        ;setq

     (while (> DIV 1)
       (setq PT (polar CENPT 2NDANG RAD)) ;2nd pt
       (setq PTLST (cons PT PTLST))
       (setq 2NDANG (+ 2NDANG INCRANG))
       (setq DIV (1- DIV))
     )                                        ;while
    )                                        ;cond circle
  )                                        ;conditions

  (foreach X PTLST                        ;trans for rotated UCS
    (setq TPTLST (cons (trans X 0 1) TPTLST))
  )                                        ;WCS to UCS
  (setq TPTLST (REMDUPPTS TPTLST 0.001))

  (cond
    ((= TYP "W")
     (setq SS (ssget "WP" TPTLST))
     (if SS
       (progn
         (setq COUNT (sslength SS))
         (princ "\nSelection set contains ")
         (princ COUNT)
         (princ " objects by Window method")
       )                                ;progn
       (princ "\nNothing selected")        ;else
     )                                        ;if
    )                                        ;cond W

    ((= TYP "C")
     (setq SS (ssget "CP" TPTLST))
     (if SS
       (progn
         (ssdel OBJ SS)                        ;remove OBJ
         (setq COUNT (sslength SS))
         (princ "\nSelection set contains ")
         (princ COUNT)
         (princ " objects by Crossing method")
       )                                ;progn
       (princ "\nNothing selected")        ;else
     )                                        ;if
    )                                        ;cond C

    ((= TYP "F")
     (if (ISCLOSED OBJ)
       (setq TPTLST (cons (car TPTLST) (reverse TPTLST)))
                                        ;first point at last
     )                                        ;if
     (setq SS (ssget "F" TPTLST))
     (if SS
       (progn
         (ssdel OBJ SS)                        ;remove OBJ
         (setq COUNT (sslength SS))
         (princ "\nSelection set contains ")
         (princ COUNT)
         (princ " objects by Fence method")
       )                                ;progn
       (princ "\nNothing selected")        ;else
     )                                        ;if
    )                                        ;cond F
  )                                        ;conditions

  (if SS
    (sssetfirst NIL SS)
  )                                        ;select
  (*ERROR* NIL)                                ;reset vars
  (princ)
)                                        ;end