万能框选倒角lsp,只差pl与arc、独立pl不能实现

龙龙仔 · 发表于 2008-5-19 17:04:00

本帖最后由作者于 2008-5-19 17:07:32 编辑

;;可以框選的倒角命令lsp,缺陷是多段線不行,幫修改下好嗎
;;如題所以,對於兩條多段線的情況不行,版主可以完善一下這麼好用功能嗎
(vl-load-com)
;;;=========================================
;;;通用函數：求兩個三維點的中點
(defun MID (PT1 PT2)
(list
(* 0.5 (+ (nth 0 PT1) (nth 0 PT2)))
(* 0.5 (+ (nth 1 PT1) (nth 1 PT2)))
(* 0.5 (+ (nth 2 PT1) (nth 2 PT2)))
)
)
;;陌生人
(defun X_INTLST (OBJ1 OBJ2 PARAM / INTLST1 INTLST2 PTLST)
(if (= 'ENAME (type OBJ1))
(setq OBJ1 (vlax-ename->vla-object OBJ1))
)
(if (= 'ENAME (type OBJ2))
(setq OBJ2 (vlax-ename->vla-object OBJ2))
)
(setq
INTLST1 (vlax-variant-value (vla-intersectwith OBJ1 OBJ2 PARAM))
)
(if (< 0 (vlax-safearray-get-u-bound INTLST1 1))
(progn
(setq INTLST2 (vlax-safearray->list INTLST1))
(while (> (length INTLST2) 0)
(setq PTLST (cons (list (car INTLST2) (cadr INTLST2) (caddr INTLST2))
PTLST
)
INTLST2 (cdddr INTLST2)
)
)
)
)
PTLST
)
;;;=========================================
;;功能：對系統提供的圓角命令的改進
;;日期：zml84 於 2007-08-14 21:10
;;修改：LUCAS 於 2008-05-17 (未詳細測試,測試環境:R2008)
(defun C:F (/ *ERROR* *MYERR* *OLDERR* A B
CMD_OLD ENT INT LST OS_OLD PT1 PT2
SS TEST TEST0 TMP TMP2
)
(princ "\n★★超級圓角★★")
;;============================
(defun *MYERR* (MSG)
(setvar "CMDECHO" CMD_OLD)
(setvar "OSMODE" OS_OLD)
(setq *ERROR* *OLDERR*)
(if (= MSG "完美退出。謝謝使用。")
(princ (strcat "\n>>>" MSG))
(princ "\n>>>雖然中途退出了，對像捕捉已經被恢復。")
)
(princ)
)
(setq *OLDERR* *ERROR*
*ERROR* *MYERR*
OS_OLD (getvar "OSMODE")
CMD_OLD (getvar "CMDECHO")
)
;;==============================
;;1、系統變量設置
(setvar "OSMODE" 0)
(setvar "CMDECHO" 0)
;;顯示選項當前值
(princ
(strcat
"\n當前設置: 模式 = "
(nth (getvar "TRIMMODE") '("不修剪" "修剪"))
"，半徑 = "
(rtos (getvar "FILLETRAD") 2 4)
)
)
;;2、循環連續執行
(setq TEST0 t)
(while TEST0
;;初始化
(setq A NIL
B NIL
)
;;2.1、選擇對像1
(princ "\n選擇對像或 [多段線(P)/半徑(R)/修剪(T)]: ")
(setq TEST t)
(while TEST
(setq TMP (grread t 4 2))
(cond
;;按下鍵盤鍵
((= (car TMP) 2)
(setq INT (cadr TMP))
(cond
;;回車或者空格鍵，則退出
((or (= INT 13)
(= INT 32)
)
(setq TEST NIL
TEST0 NIL
)
)
;;P選項
((or (= (ascii "P") INT)
(= (ascii "p") INT)
)
(if (and (setq SS (entsel " >>選擇二維多段線: "))
(= (cdr (assoc 0 (entget (car SS))))
"LWPOLYLINE"
)
)
(command "_.fillet" "P" SS)
)
)
;;R選項
((or (= (ascii "R") INT)
(= (ascii "r") INT)
)
(princ (strcat "\n>>指定圓角半徑 <"
(rtos (getvar "FILLETRAD") 2 2)
">: "
)
)
(if (setq TMP2 (getdist))
(setvar "FILLETRAD" TMP2)
)
)
;;T選項
((or (= (ascii "T") INT)
(= (ascii "t") INT)
)
(initget "T N")
(setq TMP2
(getkword
(strcat
"\n>>輸入修剪模式選項 [修剪(T)/不修剪(N)] <"
(nth (getvar "TRIMMODE")
'("不修剪" "修剪")
)
">: "
)
)
)
(if (= TMP2 "T")
(setvar "TRIMMODE" 1)
(if (= TMP2 "N")
(setvar "TRIMMODE" 0)
)
)
)
)
(princ "\n選擇對像或 [多段線(P)/半徑(R)/修剪(T)]: ")
)
;;擊鼠標右鍵
((= (car TMP) 12)
(setq TEST NIL
TEST0 NIL
)
)
;;擊左鍵
((= (car TMP) 3)
(setq PT1 (cadr TMP))
(if (setq SS (ssget PT1))
(setq A (list (ssname SS 0) PT1)
TEST NIL
)
(if (and
(setq PT2 (getcorner PT1 " >>>第二點:"))
(progn (command "_.select" "c" PT1 PT2 "")
(setq SS (ssget "p"))
)
)
(progn
(command "_.rectang" PT1 PT2)
(setq ENT (entlast)
TEST NIL
)
(setq
A
(car (setq
LST (X_INTLST (ssname SS 0) ENT acextendnone)
)
)
)
(if (and (= (sslength SS) 1)
(= (length LST) 2)
)
(setq B (cadr LST))
(if (ssname SS 1)
(setq
B (car (X_INTLST (ssname SS 1) ENT acextendnone))
)
)
)
(entdel ENT)
)
(princ
"\n選擇對像或 [多段線(P)/半徑(R)/修剪(T)]: "
)
)
)
)
) ;_ 結束 cond
) ;_ 結束 while
(if (and A
(= (type (car A)) 'ENAME)
(not (redraw (car A) 3))
(= B NIL)
)
(progn
;;2.2、選擇對像2
(princ "\n選擇對像:")
(setq TEST t)
(while TEST
(setq TMP (grread t 4 2))
;;(if (setq PT1 (getpoint "\n選擇對像:"))
(cond
;;擊左鍵
((= (car TMP) 3)
(setq PT1 (cadr TMP))
(if (setq SS (ssget PT1))
(setq B (list (ssname SS 0) PT1)
TEST NIL
)
(if (and
(setq
PT2 (getcorner PT1
" >>>第二點:"
)
)
(setq SS (ssget "c" PT1 PT2))
)
(setq B (list (ssname SS 0)
(MID PT1 PT2)
)
TEST NIL
)
(princ "\n選擇對像:")
)
)
)
;;擊右鍵
((= (car TMP) 12)
(setq TEST NIL)
)
) ;_結束 cond
)
)
) ;_結束 if
;;圓角操作
(if (and A B (= (type (car A)) 'ENAME))
(command "_.fillet" (cadr A) (cadr B))
(command "_.fillet" A B)
)
(if (and A
(= (type (car A)) 'ENAME)
)
(redraw (car A) 4)
)
)
;;3、恢復系統變量設置
;;============
(*ERROR* "完美退出。謝謝使用。")
;;============
(princ)
) ;_結束 defun
;;;=========================================

;;可以框選的倒角命令lsp,缺陷是多段線不行,幫修改下好嗎
;;如題所以,對於兩條多段線的情況不行,版主可以完善一下這麼好用功能嗎
(vl-load-com)
;;;=========================================
;;;通用函數：求兩個三維點的中點
(defun MID (PT1 PT2)
  (list
    (* 0.5 (+ (nth 0 PT1) (nth 0 PT2)))
    (* 0.5 (+ (nth 1 PT1) (nth 1 PT2)))
    (* 0.5 (+ (nth 2 PT1) (nth 2 PT2)))
  )
)
;;陌生人  
(defun X_INTLST (OBJ1 OBJ2 PARAM / INTLST1 INTLST2 PTLST)
  (if (= 'ENAME (type OBJ1))
    (setq OBJ1 (vlax-ename->vla-object OBJ1))
  )
  (if (= 'ENAME (type OBJ2))
    (setq OBJ2 (vlax-ename->vla-object OBJ2))
  )
  (setq
    INTLST1 (vlax-variant-value (vla-intersectwith OBJ1 OBJ2 PARAM))
  )
  (if (< 0 (vlax-safearray-get-u-bound INTLST1 1))
    (progn
      (setq INTLST2 (vlax-safearray->list INTLST1))
      (while (> (length INTLST2) 0)
 (setq PTLST   (cons (list (car INTLST2) (cadr INTLST2) (caddr INTLST2))
       PTLST
        )
       INTLST2 (cdddr INTLST2)
 )
      )
    )
  )
  PTLST
)
;;;=========================================
;;功能：對系統提供的 圓角 命令的改進        
;;日期：zml84 於 2007-08-14 21:10
;;修改：LUCAS 於 2008-05-17 (未詳細測試,測試環境:R2008)
(defun C:F (/     *ERROR* *MYERR* *OLDERR*     A     B
     CMD_OLD ENT     INT     LST     OS_OLD  PT1     PT2
     SS     TEST    TEST0   TMP     TMP2
    )
  (princ "\n★★超級圓角★★")
  ;;============================
  (defun *MYERR* (MSG)
    (setvar "CMDECHO" CMD_OLD)
    (setvar "OSMODE" OS_OLD)
    (setq *ERROR* *OLDERR*)
    (if (= MSG "完美退出。謝謝使用。")
      (princ (strcat "\n>>>" MSG))
      (princ "\n>>>雖然中途退出了，對像捕捉已經被恢復。")
    )
    (princ)
  )
  (setq *OLDERR* *ERROR*
 *ERROR*  *MYERR*
 OS_OLD  (getvar "OSMODE")
 CMD_OLD  (getvar "CMDECHO")
  )
  ;;==============================
  ;;1、系統變量設置
  (setvar "OSMODE" 0)
  (setvar "CMDECHO" 0)
  ;;顯示選項當前值
  (princ
    (strcat
      "\n當前設置: 模式 = "
      (nth (getvar "TRIMMODE") '("不修剪" "修剪"))
      "，半徑 = "
      (rtos (getvar "FILLETRAD") 2 4)
    )
  )
  ;;2、循環連續執行
  (setq TEST0 t)
  (while TEST0
    ;;初始化
    (setq A NIL
   B NIL
    )
    ;;2.1、選擇對像1
    (princ "\n選擇對像或 [多段線(P)/半徑(R)/修剪(T)]: ")
    (setq TEST t)
    (while TEST
      (setq TMP (grread t 4 2))
      (cond
 ;;按下鍵盤鍵
 ((= (car TMP) 2)
  (setq INT (cadr TMP))
  (cond
    ;;回車或者空格鍵，則退出
    ((or (= INT 13)
  (= INT 32)
     )
     (setq TEST NIL
    TEST0 NIL
     )
    )
    ;;P選項
    ((or (= (ascii "P") INT)
  (= (ascii "p") INT)
     )
     (if (and (setq SS (entsel " >>選擇二維多段線: "))
       (= (cdr (assoc 0 (entget (car SS))))
   "LWPOLYLINE"
       )
  )
       (command "_.fillet" "P" SS)
     )
    )
    ;;R選項
    ((or (= (ascii "R") INT)
  (= (ascii "r") INT)
     )
     (princ (strcat "\n>>指定圓角半徑 <"
      (rtos (getvar "FILLETRAD") 2 2)
      ">: "
     )
     )
     (if (setq TMP2 (getdist))
       (setvar "FILLETRAD" TMP2)
     )
    )
    ;;T選項
    ((or (= (ascii "T") INT)
  (= (ascii "t") INT)
     )
     (initget "T N")
     (setq TMP2
     (getkword
       (strcat
         "\n>>輸入修剪模式選項 [修剪(T)/不修剪(N)] <"
         (nth (getvar "TRIMMODE")
       '("不修剪" "修剪")
         )
         ">: "
       )
     )
     )
     (if (= TMP2 "T")
       (setvar "TRIMMODE" 1)
       (if (= TMP2 "N")
  (setvar "TRIMMODE" 0)
       )
     )
    )
  )
  (princ "\n選擇對像或 [多段線(P)/半徑(R)/修剪(T)]: ")
 )
 ;;擊鼠標右鍵
 ((= (car TMP) 12)
  (setq TEST NIL
        TEST0 NIL
  )
 )
 ;;擊左鍵
 ((= (car TMP) 3)
  (setq PT1 (cadr TMP))
  (if (setq SS (ssget PT1))
    (setq A    (list (ssname SS 0) PT1)
   TEST NIL
    )
    (if (and
   (setq PT2 (getcorner PT1 " >>>第二點:"))
   (progn (command "_.select" "c" PT1 PT2 "")
   (setq SS (ssget "p"))
   )
        )
      (progn
        (command "_.rectang" PT1 PT2)
        (setq ENT  (entlast)
       TEST NIL
        )
        (setq
   A
    (car (setq
    LST (X_INTLST (ssname SS 0) ENT acextendnone)
         )
    )
        )
        (if (and (= (sslength SS) 1)
   (= (length LST) 2)
     )
   (setq B (cadr LST))
   (if (ssname SS 1)
     (setq
       B (car (X_INTLST (ssname SS 1) ENT acextendnone))
     )
   )
        )
        (entdel ENT)
      )
      (princ
        "\n選擇對像或 [多段線(P)/半徑(R)/修剪(T)]: "
      )
    )
  )
 )
      ) ;_ 結束 cond
    ) ;_ 結束 while
    (if (and A
      (= (type (car A)) 'ENAME)
      (not (redraw (car A) 3))
      (= B NIL)
 )
      (progn
 ;;2.2、選擇對像2
 (princ "\n選擇對像:")
 (setq TEST t)
 (while TEST
   (setq TMP (grread t 4 2))
   ;;(if (setq PT1 (getpoint "\n選擇對像:"))
   (cond
     ;;擊左鍵
     ((= (car TMP) 3)
      (setq PT1 (cadr TMP))
      (if (setq SS (ssget PT1))
        (setq B   (list (ssname SS 0) PT1)
       TEST NIL
        )
        (if (and
       (setq
         PT2 (getcorner PT1
          " >>>第二點:"
      )
       )
       (setq SS (ssget "c" PT1 PT2))
     )
   (setq B    (list (ssname SS 0)
      (MID PT1 PT2)
       )
         TEST NIL
   )
   (princ "\n選擇對像:")
        )
      )
     )
     ;;擊右鍵
     ((= (car TMP) 12)
      (setq TEST NIL)
     )
   ) ;_結束 cond
 )
      )
    ) ;_結束 if
    ;;圓角操作
    (if (and A B (= (type (car A)) 'ENAME))
      (command "_.fillet" (cadr A) (cadr B))
      (command "_.fillet" A B)
    )
    (if (and A
      (= (type (car A)) 'ENAME)
 )
      (redraw (car A) 4)
    )
  )
  ;;3、恢復系統變量設置
  ;;============
  (*ERROR* "完美退出。謝謝使用。")
  ;;============
  (princ)
) ;_結束 defun
;;;=========================================

liminnet · 发表于 2008-5-19 19:44:00

提示: 作者被禁止或删除内容自动屏蔽

liminnet · 发表于 2008-5-19 21:09:00

提示: 作者被禁止或删除内容自动屏蔽

狂刀无痕 · 发表于 2008-5-19 22:03:00

我也有捐助赈灾的啦

龙龙仔 · 发表于 2008-5-20 07:58:00

狂刀无痕---看來是找出所有端點,最近的端點倒角

狂刀无痕 · 发表于 2008-5-20 12:44:00

本帖最后由作者于 2008-5-20 13:05:46 编辑

基本对头

liminnet · 发表于 2008-5-21 23:33:00

提示: 作者被禁止或删除内容自动屏蔽

liminnet · 发表于 2008-5-23 17:23:00

提示: 作者被禁止或删除内容自动屏蔽

mcxiangxin · 发表于 2008-5-23 22:11:00

支持,好程序!

liminnet · 发表于 2008-5-24 14:42:00

提示: 作者被禁止或删除内容自动屏蔽

账号		自动登录	找回密码
密码			注册

万能框选倒角lsp,只差pl与arc、独立pl不能实现

本帖子中包含更多资源

浏览过的版块

liminnet liminnet 当前离线积分 9754 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	楼主\| 发表于 2008-5-19 19:44:00 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡

liminnet liminnet 当前离线积分 9754 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	楼主\| 发表于 2008-5-19 21:09:00 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡

liminnet liminnet 当前离线积分 9754 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	楼主\| 发表于 2008-5-21 23:33:00 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡

liminnet liminnet 当前离线积分 9754 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	楼主\| 发表于 2008-5-23 17:23:00 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡

liminnet liminnet 当前离线积分 9754 明经币个注册时间 2007-8-22 在线时间小时威望金钱个贡献激情	楼主\| 发表于 2008-5-24 14:42:00 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽

	回复支持反对使用道具举报显身卡