[分享]：批量偏移程序

ago9999 · 发表于 2006-2-27 11:27:25

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;;批量偏移
;;;ago9999,梨胡鸟编写(QQ17137646)
(defun c:py (/ en offd pt py_fs offd dx_ss dx_ss dx_n pt pt0 n)
(command "undo" "be") ; 定义返回点
(setvar "cmdecho" 0) ; 关闭命令提示
(if (or (= py_fs0 nil) (eq py_fs0 ""))
(setq py_fs0 "Z")
)
(princ "\n请输入偏移方式[正向(Z)/反向(F)/双向(S)/通过(T)]<")
(princ py_fs0) ;输入偏移方式
(princ ">:")
(setq py_fs (getstring))
(if (or (= py_fs nil) (eq py_fs ""))
(setq py_fs py_fs0)
(setq py_fs0 py_fs)
)
(if (or (eq py_fs "t") (eq py_fs "T"))
(princ "\n采用通过点偏移方式")
(progn
(if (= offd0 nil)
(setq offd0 "0")
)
(princ "\n请输入偏移距离(")
(princ offd0)
(princ ")") ;输入偏移距离
(setq offd (getdist))
(if (= offd nil)
(setq offd offd0)
(setq offd0 offd)
)
)
)
(princ "\n请选择线段,弧,圆,多段线:")
(setq dx_ss (ssget))
(if (or (eq py_fs "s") (eq py_fs "S"))
(setq pt (list 0 0))
(setq pt (getpoint "\n请选择基点"))
) ;输入偏移基点
(setq n 0)
(while (< n (sslength dx_ss))
(setq dx_n (ssname dx_ss n))
(if
(or (eq py_fs "t") (eq py_fs "T"))
(command "OFFSET" "t" dx_n pt "")
(progn
(cond
((or (eq "LINE" (cdr (assoc '0 (entget dx_n))))
(eq "LWPOLYLINE" (cdr (assoc '0 (entget dx_n))))
)
(command "OFFSET" offd dx_n pt "") ;正向偏移
(setq ptst (cdr (assoc '10 (entget dx_n))))
(setq pten (cdr (assoc '10 (entget (entlast)))))
(if (or (eq py_fs "f") (eq py_fs "F")) ;正向偏移删除
(command "ERASE" "l" "")
)
(if (or (eq py_fs "f")
(eq py_fs "F")
(eq py_fs "s")
(eq py_fs "S")
) ;反向偏移
(progn
(setq pt0 (list (- (* 2 (nth 0 ptst)) (nth 0 pten))
(- (* 2 (nth 1 ptst)) (nth 1 pten))
)
)
(command "OFFSET" offd dx_n pt0 "")
)
)
)
((or (eq "ARC" (cdr (assoc '0 (entget dx_n))))
(eq "CIRCLE" (cdr (assoc '0 (entget dx_n))))
)
(command "OFFSET" offd dx_n pt "") ;正向偏移
(setq rst (cdr (assoc '40 (entget dx_n))))
(setq ren (cdr (assoc '40 (entget (entlast)))))
(if (or (eq py_fs "s") (eq py_fs "S")) ;正向偏移复制
(command "copy" "l" "" "0,0,0" "0,0,0")
)
(if (or (eq py_fs "f")
(eq py_fs "F")
(eq py_fs "s")
(eq py_fs "S")
) ;反向偏移
(progn
(setq r0 (- (* 2 rst) ren))
(if (<= r0 0)
(command "ERASE" "l" "") ;正向偏移删除
(progn
(setq dx_n0 (entget (entlast)))
(setq dx_n0
(subst (cons '40 r0) (assoc '40 dx_n0) dx_n0)
)
(entmod dx_n0)
) ;正向偏移更改
)
)
)
)
)
)
)
(setq n (1+ n))
)
(command "undo" "e") ; 定义返点
(setvar "cmdecho" 1) ; 打开命令提示
(princ)
)

;;;批量偏移 
;;;ago9999,梨胡鸟编写(QQ17137646) 
(defun c:py (/ en offd pt py_fs offd dx_ss dx_ss dx_n pt pt0 n) 
  (command "undo" "be")                        ; 定义返回点 
  (setvar "cmdecho" 0)                        ; 关闭命令提示 
 
  (if (or (= py_fs0 nil) (eq py_fs0 "")) 
    (setq py_fs0 "Z") 
  ) 
  (princ "\n请输入偏移方式[正向(Z)/反向(F)/双向(S)/通过(T)]<") 
  (princ py_fs0)                        ;输入偏移方式 
  (princ ">:") 
  (setq py_fs (getstring)) 
  (if (or (= py_fs nil) (eq py_fs "")) 
    (setq py_fs py_fs0) 
    (setq py_fs0 py_fs) 
  ) 
 
  (if (or (eq py_fs "t") (eq py_fs "T")) 
    (princ "\n采用通过点偏移方式") 
    (progn 
      (if (= offd0 nil) 
        (setq offd0 "0") 
      ) 
      (princ "\n请输入偏移距离(") 
      (princ offd0) 
      (princ ")")                        ;输入偏移距离 
      (setq offd (getdist)) 
      (if (= offd nil) 
        (setq offd offd0) 
        (setq offd0 offd) 
      ) 
    ) 
  ) 
 
  (princ "\n请选择线段,弧,圆,多段线:") 
  (setq dx_ss (ssget)) 
  (if (or (eq py_fs "s") (eq py_fs "S")) 
    (setq pt (list 0 0)) 
    (setq pt (getpoint "\n请选择基点")) 
  )                                        ;输入偏移基点 
 
  (setq n 0) 
  (while (< n (sslength dx_ss)) 
    (setq dx_n (ssname dx_ss n)) 
    (if 
      (or (eq py_fs "t") (eq py_fs "T")) 
       (command "OFFSET" "t" dx_n pt "") 
       (progn 
         (cond 
           ((or        (eq "LINE" (cdr (assoc '0 (entget dx_n)))) 
                (eq "LWPOLYLINE" (cdr (assoc '0 (entget dx_n)))) 
            ) 
            (command "OFFSET" offd dx_n pt "") ;正向偏移 
            (setq ptst (cdr (assoc '10 (entget dx_n)))) 
            (setq pten (cdr (assoc '10 (entget (entlast))))) 
 
            (if        (or (eq py_fs "f") (eq py_fs "F")) ;正向偏移删除 
              (command "ERASE" "l" "") 
            ) 
            (if        (or (eq py_fs "f") 
                    (eq py_fs "F") 
                    (eq py_fs "s") 
                    (eq py_fs "S") 
                )                        ;反向偏移 
              (progn 
                (setq pt0 (list        (- (* 2 (nth 0 ptst)) (nth 0 pten)) 
                                (- (* 2 (nth 1 ptst)) (nth 1 pten)) 
                          ) 
                ) 
                (command "OFFSET" offd dx_n pt0 "") 
              ) 
            ) 
           ) 
           ((or        (eq "ARC" (cdr (assoc '0 (entget dx_n)))) 
                (eq "CIRCLE" (cdr (assoc '0 (entget dx_n)))) 
            ) 
            (command "OFFSET" offd dx_n pt "") ;正向偏移 
            (setq rst (cdr (assoc '40 (entget dx_n)))) 
            (setq ren (cdr (assoc '40 (entget (entlast))))) 
 
            (if        (or (eq py_fs "s") (eq py_fs "S")) ;正向偏移复制 
              (command "copy" "l" "" "0,0,0" "0,0,0") 
            ) 
            (if        (or (eq py_fs "f") 
                    (eq py_fs "F") 
                    (eq py_fs "s") 
                    (eq py_fs "S") 
                )                        ;反向偏移 
              (progn 
                (setq r0 (- (* 2 rst) ren)) 
                (if (<= r0 0) 
                  (command "ERASE" "l" "") ;正向偏移删除 
                  (progn 
                    (setq dx_n0 (entget (entlast))) 
                    (setq dx_n0 
                           (subst (cons '40 r0) (assoc '40 dx_n0) dx_n0) 
                    ) 
                    (entmod dx_n0) 
                  )                        ;正向偏移更改 
                ) 
              ) 
            ) 
           ) 
         ) 
 
       ) 
    ) 
    (setq n (1+ n)) 
  ) 
  (command "undo" "e")                        ; 定义返点 
  (setvar "cmdecho" 1)                        ; 打开命令提示 
  (princ) 
)

yy99 · 发表于 2006-2-27 11:58:15

我问个问题，楼主的这个程序和cad自带的用来偏移的命令有什么区别么？

ago9999 · 发表于 2006-2-27 16:25:57

可以正方向偏移,反方向偏移,以及双向偏移,关键是可以批量处理,不用一个一个去选择

taner · 发表于 2006-2-27 20:15:58

[FONT=courier new]
;;;不記得出自哪位大蝦之手,曾經在曉東空間發表過.
(defun c:test1 (/ ss dis objs)
(princ "\n一次偏移多個實體.")
(vl-load-com)
(setq ss (ssget))
(setq dis (getdist "\nSpecify Offset Distance:"))
(setq objs (vla-get-activeselectionset
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(vlax-for obj objs (vla-offset obj dis))
(princ)
)
(defun c:test2 (/ ss dis objs)
(princ "\n一次雙向偏移多個實體.")
(vl-load-com)
(setq ss (ssget))
(setq dis (getdist "\nSpecify Offset Distance:"))
(setq objs (vla-get-activeselectionset
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(vlax-for obj objs (vla-offset obj dis))
(vlax-for obj objs (vla-offset obj (* -1 dis)))
(princ)
)
(defun c:test3 (/ ss dis objs)
(princ "\n一次雙向偏移多個實體,並將原實體刪除.")
(vl-load-com)
(setq ss (ssget))
(setq dis (getdist "\nSpecify Offset Distance:"))
(setq objs (vla-get-activeselectionset
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(vlax-for obj objs (vla-offset obj dis))
(vlax-for obj objs (vla-offset obj (* -1 dis)))
(command "erase" ss "")
(princ)
)
[/FONT]

[FONT=courier new] 
;;;不記得出自哪位大蝦之手,曾經在曉東空間發表過. 
(defun c:test1 (/ ss dis objs) 
  (princ "\n一次偏移多個實體.") 
  (vl-load-com) 
  (setq ss (ssget)) 
  (setq dis (getdist "\nSpecify Offset Distance:")) 
  (setq        objs (vla-get-activeselectionset 
               (vla-get-activedocument 
                 (vlax-get-acad-object) 
               ) 
             ) 
  ) 
  (vlax-for obj objs (vla-offset obj dis)) 
  (princ) 
) 
(defun c:test2 (/ ss dis objs) 
  (princ "\n一次雙向偏移多個實體.") 
  (vl-load-com) 
  (setq ss (ssget)) 
  (setq dis (getdist "\nSpecify Offset Distance:")) 
  (setq        objs (vla-get-activeselectionset 
               (vla-get-activedocument 
                 (vlax-get-acad-object) 
               ) 
             ) 
  ) 
  (vlax-for obj objs (vla-offset obj dis)) 
  (vlax-for obj objs (vla-offset obj (* -1 dis))) 
  (princ) 
) 
(defun c:test3 (/ ss dis objs) 
  (princ "\n一次雙向偏移多個實體,並將原實體刪除.") 
  (vl-load-com) 
  (setq ss (ssget)) 
  (setq dis (getdist "\nSpecify Offset Distance:")) 
  (setq        objs (vla-get-activeselectionset 
               (vla-get-activedocument 
                 (vlax-get-acad-object) 
               ) 
             ) 
  ) 
  (vlax-for obj objs (vla-offset obj dis)) 
  (vlax-for obj objs (vla-offset obj (* -1 dis))) 
  (command "erase" ss "") 
  (princ) 
) 
  [/FONT]

lemonx · 发表于 2006-3-4 09:01:47

顶楼程序有些bug
4楼的功能比较简单，但不能保存数据

taner · 发表于 2006-3-4 09:53:32

最初由 lemonx 发布
[B]顶楼程序有些bug
4楼的功能比较简单，但不能保存数据 [/B]

[FONT=courier new]
;;;下面這個是改過的,同樣是曉東空間上的.不記得出自哪位高人.
(defun c:test4 (/ getds obj red-dist)
(princ "\nÒ»´ÎëpÏòÆ«ÒÆ¶à‚?#338;ów.")
(vl-load-com)
(initget 2)
(setq red-dist (vl-registry-read
"HKEY_CURRENT_USER\\Software\\Autodesk\\BDYCAD"
"OFDIST"
)
)
(if red-dist
(setq getds (getdist (strcat "\nÕˆÈëÆ«ÒÆ¾àÀë<" red-dist ">:")))
(setq getds (getdist "\nÕˆÈëÆ«ÒÆ¾àÀë<¿ÉÖ±½ÓÁ¿È¡>:"))
)
(if (= getds nil)
(setq getds (atof red-dist))
)
(vl-registry-write
"HKEY_CURRENT_USER\\Software\\Autodesk\\BDYCAD"
"OFDIST"
(rtos getds)
)
(if (ssget '((0 . "Arc,Circle,Ellipse,*Line")))
(vlax-for obj (vla-get-activeselectionset
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(vla-offset obj getds)
(vla-offset obj (* getds -1))
)
(vlax-release-object obj)
)
)
[/FONT]

[FONT=courier new] 
;;;下面這個是改過的,同樣是曉東空間上的.不記得出自哪位高人. 
(defun c:test4 (/ getds obj red-dist) 
  (princ "\n&Ograve;&raquo;&acute;&Icirc;&euml;p&Iuml;ò&AElig;&laquo;&Ograve;&AElig;&para;à&#8218;?#338;&#141;ów.") 
  (vl-load-com) 
  (initget 2) 
  (setq        red-dist (vl-registry-read 
                   "HKEY_CURRENT_USER\\Software\\Autodesk\\BDYCAD" 
                   "OFDIST" 
                 ) 
  ) 
  (if red-dist 
    (setq getds (getdist (strcat "\n&Otilde;&#710;&Egrave;&euml;&AElig;&laquo;&Ograve;&AElig;&frac34;à&Agrave;&euml;<" red-dist ">:"))) 
    (setq getds (getdist "\n&Otilde;&#710;&Egrave;&euml;&AElig;&laquo;&Ograve;&AElig;&frac34;à&Agrave;&euml;<&iquest;&Eacute;&Ouml;±&frac12;&Oacute;&Aacute;&iquest;&Egrave;&iexcl;>:")) 
  ) 
  (if (= getds nil) 
    (setq getds (atof red-dist)) 
  ) 
  (vl-registry-write 
    "HKEY_CURRENT_USER\\Software\\Autodesk\\BDYCAD" 
    "OFDIST" 
    (rtos getds) 
  ) 
  (if (ssget '((0 . "Arc,Circle,Ellipse,*Line"))) 
    (vlax-for obj (vla-get-activeselectionset 
                    (vla-get-activedocument 
                      (vlax-get-acad-object) 
                    ) 
                  ) 
      (vla-offset obj getds) 
      (vla-offset obj (* getds -1)) 
    ) 
    (vlax-release-object obj) 
  ) 
) 
  [/FONT]

81153643 · 发表于 2006-3-4 10:19:19

正需要收下拉

lemonx · 发表于 2006-3-4 12:37:01

最初由 taner 发布
[B]
[CODE]

;;;下面這個是改過的,同樣是曉東空間上的.不記得出自哪位高人.
(defun c... [/B]

在我机器上显示但提示部分有乱码，是繁体的？

xyp1964 · 发表于 2006-3-4 13:05:18

批量偏移扩展版

[FONT=courier new](load "xyp_lib.vlx") ;版本 V.20060303(2153)
;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
★1·在acad.lsp中增加(load"xyp_lib.vlx")
■2·在每个程序内增加(load"xyp_lib.vlx")
■3·在command下，输入(load"xyp_lib.vlx")
■4·在菜单.mnl中增加(load"xyp_lib.vlx")
■5·将xyp_lib.vlx文件直接拽到cad屏幕
[COLOR=red] ★通用函数下载地址：[/COLOR]
[url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]
|;
;;;批量偏移扩展
(defun c:test184 ()
(cmdla0)
(defun ch-la ()
(if (= ukw2 "Y")
(command "change" (entlast) "" "P" "la" la "")
)
)
(setvar "OFFSETGAPTYPE" 0)
(setvar "osmode" 0)
(if (null ukw)
(setq ukw "4")
)
(if (null ukw2)
(setq ukw2 "N")
)
(if (null getds)
(setq getds 100)
)
(SETQ getds (UDIST 7 "" "\n输入偏移距离<或直接量取>:" getds nil)
ukw (UKWORD
7
"1 2 3 4"
"\n选择偏移方式 : 1-单向（向内）/2-单向（向外）/3-双向（保留原线）/4-双向（删除原线）"
ukw
)
ukw2 (UKWORD 7 "Y N" "\n选择偏移后层方式 : Y-当前层/N-原层" ukw2)
la (getvar "clayer")
ss (ssget '((0 . "Arc,Circle,Ellipse,*Line")))
i -1
)
(setvar "OFFSETDIST" getds)
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq pt (vlax-curve-getstartPoint s1)
pt1 (PT-FAXIAN s1 pt 10)
pt2 (PT-FAXIAN s1 pt -10)
)
(cond ((= ukw "1")
(command "offset" "" s1 pt1 "")
(ch-la)
)
((= ukw "2")
(command "offset" "" s1 pt2 "")
(ch-la)
)
((= ukw "3")
(command "offset" "" s1 pt1 "")
(ch-la)
(command "offset" "" s1 pt2 "")
(ch-la)
)
((= ukw "4")
(command "offset" "" s1 pt1 "")
(ch-la)
(command "offset" "" s1 pt2 "")
(ch-la)
(command "erase" s1 "")
)
)
)
(cmdla1)
)[/FONT]

[FONT=courier new](load "xyp_lib.vlx")  ;版本 V.20060303(2153) 
;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下) 
利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序： 
★1·在acad.lsp中增加(load"xyp_lib.vlx") 
■2·在每个程序内增加(load"xyp_lib.vlx") 
■3·在command下，输入(load"xyp_lib.vlx") 
■4·在菜单.mnl中增加(load"xyp_lib.vlx") 
■5·将xyp_lib.vlx文件直接拽到cad屏幕 
[COLOR=red] ★通用函数下载地址：[/COLOR] 
[url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url] 
|; 
 
;;;批量偏移扩展 
(defun c:test184 () 
  (cmdla0) 
  (defun ch-la () 
    (if        (= ukw2 "Y") 
      (command "change" (entlast) "" "P" "la" la "") 
    ) 
  ) 
  (setvar "OFFSETGAPTYPE" 0) 
  (setvar "osmode" 0) 
  (if (null ukw) 
    (setq ukw "4") 
  ) 
  (if (null ukw2) 
    (setq ukw2 "N") 
  ) 
  (if (null getds) 
    (setq getds 100) 
  ) 
  (SETQ        getds (UDIST 7 "" "\n输入偏移距离<或直接量取>:" getds nil) 
        ukw   (UKWORD 
                7 
                "1 2 3 4" 
                "\n选择偏移方式 : 1-单向（向内）/2-单向（向外）/3-双向（保留原线）/4-双向（删除原线）" 
                ukw 
              ) 
        ukw2  (UKWORD 7 "Y N" "\n选择偏移后层方式 : Y-当前层/N-原层" ukw2) 
        la    (getvar "clayer") 
        ss    (ssget '((0 . "Arc,Circle,Ellipse,*Line"))) 
        i     -1 
  ) 
  (setvar "OFFSETDIST" getds) 
  (while (setq s1 (ssname ss (setq i (1+ i)))) 
    (setq pt  (vlax-curve-getstartPoint s1) 
          pt1 (PT-FAXIAN s1 pt 10) 
          pt2 (PT-FAXIAN s1 pt -10) 
    ) 
    (cond ((= ukw "1") 
           (command "offset" "" s1 pt1 "") 
           (ch-la) 
          ) 
          ((= ukw "2") 
           (command "offset" "" s1 pt2 "") 
           (ch-la) 
          ) 
          ((= ukw "3") 
           (command "offset" "" s1 pt1 "") 
           (ch-la) 
           (command "offset" "" s1 pt2 "") 
           (ch-la) 
          ) 
          ((= ukw "4") 
           (command "offset" "" s1 pt1 "") 
           (ch-la) 
           (command "offset" "" s1 pt2 "") 
           (ch-la) 
           (command "erase" s1 "") 
          ) 
    ) 
  ) 
  (cmdla1) 
)[/FONT]

附件删除，可到13楼下载最新编译程序！[/COLOR]

雨箭风刀 · 发表于 2006-3-4 16:44:55

1-单向（向内）/2-单向（向外）/
pt1 (PT-FAXIAN s1 pt 10)
　pt2 (PT-FAXIAN s1 pt -10)

这个内外如何界定？　用法向不够科学，我认为用面积来界定比较好，比较直观，也复合提示字面的意思，更符合函数ｖｌａ－ｏｆｆｓｅｔ的解释。面积增大的偏移为外。对直线，以右，上为外。
而楼上ｘｙｐ的程序没有能做到这一点。可以将一个　封闭多义线左右镜像后看看效果就知道

lemonx · 发表于 2006-3-5 08:06:06

xyp的东西真的不错，程序非常好用，加到启动组了

雨箭风刀 · 发表于 2006-3-5 18:03:36

c:mff
功能：曲线多个同时偏移---by 雨箭风刀

偏移规则提示选项：
选层(A)/选色(C)/ 删除原曲线(E)/ 退出(X) / 输入偏移距离<"ACE300,500">:
选项可组合，如：
60, 外偏６０
,60 内偏６０
60 双向偏移６０
60,120 外偏60,内偏120
A,C,E均可和以上偏移值组合，如：
AC60, 选参照实体层及颜色，外偏60
CE60,120 选参照实体颜色，外偏60，内偏120并删除原实体
回车默认上次偏移规则
输入一次偏移规则可多次选实体

偏移的内外是以面积为规则，偏移后面积增大为“外”，反之为“内”，因此，一个封闭曲线，无论是正向还是反向，“外”偏的结果都一样。对直线未做判断。

xyp1964 · 发表于 2006-8-24 19:17:39

最新版：
1-单向（向内）/2-单向（向外）/3-双向（保留原线）/4-双向（删除原线)
选择偏移后层方式 : Y-当前层/N-原层

chengfana · 发表于 2006-8-29 23:09:57

本人初学vlisp, 多谢楼主给我参考

就一砖头 · 发表于 2006-8-31 16:38:17

多谢楼主很好用！

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

[分享]：批量偏移程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

还是有点区别

点评

点评