这个程序有时会漏选

皇上快溜

(defun c:tjj()
  (setvar "cmdecho" 0)
  (setvar "osmode" 1)
  (command "osnapcoord" 2)
  (command "ucs" "w")
  (command "layer" "s" "txt" "")
  (setq p4 (getpoint "\n 请输入图框左下角:"))
  (setq p5 (getpoint "\n 请输入图框右上角:"))
  (setq p1 (getpoint "\n 请输入要统计的左下角:"))
  (setq x1 (car p1) y1 (cadr p1))
  (setq p0 (getpoint "\n 请输入要统计的右上角:"))
  (setq p3 (getpoint "\n 请输入统计文字位置:"))
  (setq x4 (car p4) x5 (car p5))
  (setq w (- x5 x4))
  (setq h (* (/ w 280) 2))
  (setq p8 (getpoint "\n 请输入座标放置位置:"))
  (setq p9 (polar p8 0 (* 4 h)))
  (setq p10 (polar p8 0 (* 14 h)))
  (setq p11 (polar p8 0 (* 22 h)))
  (setq p12 (polar p8 (* 1.5 pi) h))
  (setq p13 (polar p11 (* 1.5 pi) h))
  (command "line" p12 p13 "" "")
  (setvar "osmode" 0)
  (command "text" "ml" p9 h 0 "X")
  (command "text" "ml" p10 h 0 "Y")
  (setq txt "ABCDEFGHIJKLMNOPQ")
  (setq ss (ssget "w" p1 p0 '((-4 . "<or") (0 . "arc") (0 . "circle") (-4 . "or>"))))
  (setq i 1)
  (setq pt p3)
  (while ss
     (setq en (ssname ss 0))
     (setq end (entget en))
     (setq rad (+ (cdr (assoc 40 end)) 0.000))
     (setq pci (cdr (assoc 0 end)))
     (setq d (rtos (* 2 rad)))
     (setq ssa (ssget "w" p1 p0 (list (cons 40 rad) (cons 0 pci))))
     (setq nn (sslength ssa))
     (setq stxt (substr txt i 1))
     (setq m 0)
     (setq x 0)
       (repeat nn
          (setq een (ssname ssa m))
          (setq eend (entget een))
          (setq cen (cdr (assoc 10 eend)))
          (setq xxx (- (+ 0.000 (car cen)) x1))
          (setq yyy (- (+ 0.000 (cadr cen)) y1))
          (setq xxxt (rtos xxx))
          (setq yyyt (rtos yyy))
          (setq ssb (ssget "x" (list (cons 10 cen))))
          (setq nnn (sslength ssb))
            (if (= nnn 2)
               (progn
                 (setq f (ssname ssb 0))
                 (setq g (ssname ssb 1))
                 (setq fn (entget f))
                 (setq gn (entget g))
                 (setq radf (+ (cdr (assoc 40 fn)) 0.000))
                 (setq radg (+ (cdr (assoc 40 gn)) 0.000))
                 (setq radma (max radf radg))
                 (setq radmi (min radf radg))
                 (setq p2 (polar cen (* 1.75 pi) (+ 4 radma)))
                 (if (= rad radf) (setq ss (ssdel g ss)) (setq ss (ssdel f ss)))
                 (if (= rad radf) (setq hn fn) (setq hn gn))
                 (setq ty (cdr (assoc 0 hn)))
                 (setq dma (rtos (* 2 radma)))
                 (setq dmi (rtos (* 2 radmi)))
                 (if (= ty "CIRCLE") (setq sssstxt (strcat " %%c" dma "<CB>")) (setq sssstxt (strcat " M" dma)))
                 (setq ssstxt (strcat "-%%C" dmi "<THR>" sssstxt))
                 )
               (setq p2 (polar cen (* 1.75 pi) (+ 3 rad))
                     ssstxt (strcat "-%%C" (rtos (* 2 rad) 2 3) "<THR>"))
              )
          (setq x (+ 1 x))
          (setq xt (itoa x))
          (setq xtxt (strcat stxt xt))
          (setq xxxxt (strcat xtxt ":"))
          (command "text" "ml" p2 h 0 xtxt)
          (setq p8 (polar p8 (* 1.5 pi) (* 2 h)))
          (setq p9 (polar p9 (* 1.5 pi) (* 2 h)))
          (setq p10 (polar p10 (* 1.5 pi) (* 2 h)))
          (setq p11 (polar p11 (* 1.5 pi) (* 2 h)))
          (command "line" (polar p8 (* 1.5 pi) h) (polar p11 (* 1.5 pi) h) "" "")
          (command "text" "ml" p8 h 0 xxxxt)
          (command "text" "ml" p9 h 0 xxxt)
          (command "text" "ml" p10 h 0 yyyt)
          (setq ss (ssdel een ss))
          (setq m (+ 1 m))
         )
     (setq sstxt (strcat stxt " : " (itoa nn) ssstxt))
     (command "text" "ml" pt h 0 sstxt)
     (setq i (+ i 1))
     (setq pt (polar pt (* 1.5 pi) (* 1.5 h)))
     )
  (setvar "osmode" 7)
(prinl)
)

wen1235

(defun c:tjj ()
  (setvar "cmdecho" 0)
  (setvar "osmode" 1)
  (command "osnapcoord" 2)
  (command "ucs" "w")
  ;(command "layer" "s" "txt" "");; 没有这个层就去掉吧
;;;  (setq p4 (getpoint "\n 请输入图框左下角:")) 只是为了取字高 可以和P1 P0共用 减少操作吧
;;;  (setq p5 (getpoint "\n 请输入图框右上角:"))
  (setq p1 (getpoint "\n 请输入图框左下角:"))
  (setq        x1 (car p1)
        y1 (cadr p1)
  )
  (setq p0 (getcorner p1 "\n 请输入图框右上角:"));;;可以用这个带有特效的
  (setq p3 (getpoint "\n 请输入统计文字位置:"))
  (setq        x4 (car p1);;;;
        x5 (car p0);;;;
  )
  (setq w (- x5 x4))
  (setq h (* (/ w 280) 2))
;;;  (setq p8 (getpoint "\n 请输入座标放置位置:")) 也是为了减少操作
  (setq p8 (polar p3 0.06 80))
  (setq p9 (polar p8 0 (* 4 h)))
  (setq p10 (polar p8 0 (* 14 h)))
  (setq p11 (polar p8 0 (* 22 h)))
  (setq p12 (polar p8 (* 1.5 pi) h))
  (setq p13 (polar p11 (* 1.5 pi) h))
  (setvar "osmode" 0);;
  (command "line" p12 p13 "");; 语法多了 ""
  (command "text" "ml" p9 h 0 "X")
  (command "text" "ml" p10 h 0 "Y")
  (setq txt "ABCDEFGHIJKLMNOPQ")
  (setq ss (ssget "w" p1 p0 '((0 . "circle"))));;;单个弧不再处理
  (setq i 1)
  (setq pt p3)
  (while (> (sslength ss) 0)
    (setq en (ssname ss 0))
    (setq end (entget en))
    (setq rad (cdr (assoc 40 end)));;;
    (setq pci (cdr (assoc 0 end)))
    (setq d (rtos (* 2 rad) 2));;; 不加指定的话 可以出意外啊 下面也一样
    (setq ssa (ssget "w" p1 p0 (list (cons 40 rad) (cons 0 pci))))
    (setq nn (sslength ssa))
    (setq stxt (substr txt i 1))
    (setq m 0)
    (setq x 0)
    (repeat nn
      (setq een (ssname ssa m))
      (setq eend (entget een))
      (setq cen (cdr (assoc 10 eend)))
;;;      (setq xxx (- (+ 0.000 (car cen)) x1))
;;;      (setq yyy (- (+ 0.000 (cadr cen)) y1))
      (setq xxx (- (car cen) x1))
      (setq yyy (- (cadr cen) y1))
      (setq xxxt (rtos xxx 2));;;
      (setq yyyt (rtos yyy 2));;;
      (setq ssb (ssget "w" p1 p0 (list (cons 10 cen))))
      (setq nnn (sslength ssb))
      (if (= nnn 2)
        (progn (setq f (ssname ssb 0))
               (setq g (ssname ssb 1))
               (setq fn (entget f))
               (setq gn (entget g))
;;;               (setq radf (+ (cdr (assoc 40 fn)) 0.000))
;;;               (setq radg (+ (cdr (assoc 40 gn)) 0.000))
               (setq radf (cdr (assoc 40 fn)))
               (setq radg (cdr (assoc 40 gn)))
               (setq radma (max radf radg))
               (setq radmi (min radf radg))
               (setq p2 (polar cen (* 1.75 pi) (+ 4 radma)))
               (if (= rad radf)
                 (setq ss (ssdel f ss));;上下调换
                 (setq ss (ssdel g ss));;
               )
               (if (= rad radf)
                 (setq hn gn);;上下调换
                 (setq hn fn);;
               )
               (setq ty (cdr (assoc 0 hn)))
               (setq dma (rtos (* 2 radma) 2 0));;;消零
               (setq dmi (rtos (* 2 radmi) 2));;;;
               (if (= ty "CIRCLE")
                 (setq sssstxt (strcat " %%c" dma "<CB>"))
                 (setq sssstxt (strcat " M" dma))
               )
               (setq ssstxt (strcat "-%%C" dmi "<THR>" sssstxt))
        )
        (setq p2     (polar cen (* 1.75 pi) (+ 3 rad))
              ssstxt (strcat "-%%C" (rtos (* 2 rad) 2 3) "<THR>")
              ss     (ssdel een ss);;; D
        )
      )
      (setq x (+ x 1));;;语法
      (setq xt (itoa x))
      (setq xtxt (strcat stxt xt))
      (setq xxxxt (strcat xtxt ":"))
      (command "text" "ml" p2 h 0 xtxt)
      (setq p8 (polar p8 (* 1.5 pi) (* 2 h)))
      (setq p9 (polar p9 (* 1.5 pi) (* 2 h)))
      (setq p10 (polar p10 (* 1.5 pi) (* 2 h)))
      (setq p11 (polar p11 (* 1.5 pi) (* 2 h)))
      (command "line" (polar p8 (* 1.5 pi) h) (polar p11 (* 1.5 pi) h) "");;语法多了 ""
      (command "text" "ml" p8 h 0 xxxxt)
      (command "text" "ml" p9 h 0 xxxt)
      (command "text" "ml" p10 h 0 yyyt)
      ;;;(setq ss (ssdel een ss)) D 放到上面去
      (setq m (1+ m));;;语法
    )
    (setq sstxt (strcat stxt " : " (itoa nn) ssstxt))
    (command "text" "ml" pt h 0 sstxt)
    (setq i (1+ i));;;语法
    (setq pt (polar pt (* 1.5 pi) (* 1.5 h)))
  )
  (setvar "osmode" 7)
  (princ);;;没见过这函数，自定义的吗?
)
都是搞模具的 给你改了 拿去看看效果吧

皇上快溜

革天明 发表于 2016-9-21 14:45
你先看看统计出的数量对不对

谢谢。请问：程序你做了改动了吗？编码序号全变成a1 a2 a3,,,,,,,没有b  c  d,,,,  失去了孔径大小区分功能。

r弧统计，要是能做到只识别270度圆弧就好了，非270度圆弧忽略不统计，要不然干脆所有圆弧都不统计

目前只有坐标列表，孔径以及对应编码那部分列表好像不在了

此外，编码a1 a2 a3,,,,,,,b1 b2 b3，，，c1 c2 c3,,,,,的排序要是能从左下角开始，从左到右 从下到上  那样排就好了

辛苦你了，这是个很烦人是程序，，我都不好意思了，麻烦了你们各位这么多人

革天明

皇上快溜 发表于 2016-9-21 15:51
谢谢。请问：程序你做了改动了吗？编码序号全变成a1 a2 a3,,,,,,,没有b  c  d,,,,  失去了孔径大小区分功 ...

我不是修改程序，我是重新写了一个
我上次还提了你想要实现的功能，意思是你最终想要的效果（最好是dwg文件而不是图片），这样大家给你写一个就行了，
我就没看你提供的源程序，因为我看这么多人都在改来改去的，还不如新写一个

你把想要有效果写清楚，要是早这样的话，估计新程序都能用了，改程序最好找原作者改，否则花在改程序的时间有可能重新写也能完成了

皇上快溜

该程序的选择方式(setq ss (ssget "w" p1 p0 '((-4 . "<or") (0 . "arc") (0 . "circle") (-4 . "or>"))))有点特别。不知他的原理是怎样的。

有时它会漏选，如图：

尝试将(setq ss (ssget "w" p1 p0 '((-4 . "<or") (0 . "arc") (0 . "circle") (-4 . "or>"))))中的(0 . "arc") 删掉，漏选更多，基本上一碰到圆弧图元，就不再往下统计。


；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；


这两句：(setq p4 (getpoint "\n 请输入图框左下角:"))
             (setq p5 (getpoint "\n 请输入图框右上角:"))

只是为了确定字高(setq w (- x5 x4))         的吗？
                         (setq h (* (/ w 280) 2))

不知它与(setq ss (ssget "w" p1 p0 '((-4 . "<or") (0 . "arc") (0 . "circle") (-4 . "or>"))))中的(0 . "arc") 选取动作有什连系？


；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；


另外，它的编码a1 a2 a3,,,b1 ,, b1,,排序方式是从右上角开始的。
尝试将   (setq p1 (getpoint "\n 请输入要统计的左下角:"))
             (setq p0 (getpoint "\n 请输入要统计的右上角:"))
的p1  p0 对调多来，包括这两句后面的所有p1  p0 对调多来，它的编排序还是从右上角开始的。

；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；；

想请各位前辈指点一下，想弄清楚其中的原理，跟大家学学，谢谢各位

皇上快溜

弱弱顶一次

皇上快溜

弱弱顶一次，，，求解答

前生

(setq ss (ssget "w" p1 p0 '((-4 . "<or") (0 . "arc") (0 . "circle") (-4 . "or>"))))


(setq ss (ssget "c"
                p1
                p0
                    (list (cons 0 "ARC,CIRCLE"))
             )
    )

前生

(setq ss (ssget "c"
                p1
                p0
                    (list (cons 0 "ARC,CIRCLE"))
             )
    )

前生

(setq ss (ssget "c" p1 p0  (list (cons 0 "ARC,CIRCLE"))))

皇上快溜

谢谢楼上，，(setq ss (ssget "c" p1 p0  (list (cons 0 "ARC,CIRCLE"))))还是会漏选，不知怎么会这样

Sylvanas

皇上快溜 发表于 2016-9-14 15:26
谢谢楼上，，(setq ss (ssget "c" p1 p0  (list (cons 0 "ARC,CIRCLE"))))还是会漏选，不知怎么会这样

并没有漏选，(ssget "w") 和 (ssget "c") 只能选当前显示范围内的图元，应该是缩放导致显示不完整

解决办法可以加一句 (command "zoom" "e")，或者在命令前手动缩放到合适大小（能看到所需的全部图元）

皇上快溜

谢谢Sylvanas，，，是图元完整显示状态下选取的，还是那样