[编程申请]：请编一个可以写出图中所有块的程序

szkevin · 发表于 2002-5-18 11:26:14

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

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

×

看到图形中有漂亮的图块,心里就痒,就想把她拥为已有.请编一个可以写出图中所有块的程序,要求写到特定的目录,文件名按块名.

cy956 · 发表于 2002-5-18 15:21:28

(defun c:dwgc(/ E EN IN N NAM S)
(prompt "选择要成dwg图的图块[回车全选:")
(if (NOT (setq s(ssget '((0 . "INSERT")))))
(setq s(ssget "x" '((0 . "INSERT"))))
)
(setq mlm (dos_getdir "\n选择文件存盘目录:" (if mlm mlm "d:\"))
n(sslength s) in 0)
(setvar "cmddia" 0)
(repeat n
(setq e(ssname s in) in(1+ in)
en(entget e)nam (dxf 2 en))
(command "wblock" (strcat mlm nam) nam )
)
(setvar "cmddia" 1) (princ)
)

newer · 发表于 2002-5-19 01:14:05

最初由 cy956 发布
[B][code]
(defun c:dwgc(/ E EN IN N NAM S)
  (prompt "选择要成dwg图的图块[回车全选:")
  (if (NOT (setq s(ssget '((0 . "INSERT")))))
(setq s(ssget "x" '((0 . "INSERT"))))
)
  (setq mlm  (dos... [/B]

是否还应该对匿名块进行下判断？

梦断江南 · 发表于 2002-5-19 01:17:41

[FONT=century gothic]
;;bkc[block countor]选块计数(门窗统计)///bka--全图块统计///ttc文本计数(门窗统计)(text)--------------lxx.2001.2m
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-----门窗统计
(DEFUN c:bkc(/ bn n)
(princ "\n选块计数------lxx.2001.2m")(princ "\n选择要计数的图块:")
(setq bn (cdr (assoc 2 (entget(car (entsel))))))
(princ "\n选择计数范围:")
(setq n (sslength (ssget(list (cons 2 bn)))))
(princ (strcat "\n图块 \042" bn "\042 共有 " (itoa n) " 个"))(princ);\042="
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;bka全图块统计------lxx.2001.2m
(defun c:bka (/ i ss no)
(princ "\nbka全图块统计------lxx.2001.2m")
(setq i 0)
(while (if(= 0 i)(setq bkn (cdr(assoc 2(tblnext "BLOCK" t))))(setq bkn (cdr(assoc 2(tblnext "BLOCK")))))
(setq ss (ssget "x" (list(cons 2 bkn))) i (+ 1 i))
(if ss (setq no (itoa(sslength ss)))(setq no "0"))
(if (< (strlen bkn) 8)(adds (- 8 (strlen bkn))));;;;(adds len)块名不够8位的加到8位--整齐
(princ (strcat "\n 图块 " bkn " 有 " no " 个"))(princ)
)
)
;;;;;;;;;;;;;;adds子程序;;;;;;;;;;;;;;;;
(defun adds (len /)(repeat len (setq bkn (strcat bkn " "))));;;;块名不够8位的加到8位--整齐
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;文本计数----eg.统计"c3"的个数-----门窗统计
(defun c:ttc (/ txt ss i cnt)
(princ "\n ttc--文本计数[门窗统计]------for text-------lxx.2001.2m")
(setq txt (getstring "\n要统计的text文本:") ss (ssget "x" '((0 . "TEXT"))) i 0 cnt 0)
(repeat (sslength ss)
(setq tt (cdr(assoc 1 (entget(ssname ss i)))) i (1+ i))
(if (wcmatch tt txt)(setq cnt (1+ cnt)))
)
(princ (strcat "\n 文本\042 " txt "\042 共有" (itoa cnt) " 个"))(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ "\n (门窗统计)bkc--[blockcountor]选块计数/bka--全图块统计/ttc文本计数(textcount)------lxx.2001.2m")(princ)
[/font]

[FONT=century gothic] 
;;bkc[block countor]选块计数(门窗统计)///bka--全图块统计///ttc文本计数(门窗统计)(text)--------------lxx.2001.2m 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-----门窗统计 
(DEFUN c:bkc(/ bn n) 
  (princ "\n选块计数------lxx.2001.2m")(princ "\n选择要计数的图块:") 
  (setq bn (cdr (assoc 2 (entget(car (entsel)))))) 
  (princ "\n选择计数范围:") 
  (setq n (sslength (ssget(list (cons 2 bn))))) 
  (princ (strcat "\n图块 \042" bn "\042 共有 " (itoa n) " 个"))(princ);\042=" 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
;;;bka全图块统计------lxx.2001.2m 
(defun c:bka (/ i ss no) 
(princ "\nbka全图块统计------lxx.2001.2m") 
(setq i 0) 
(while (if(= 0 i)(setq bkn (cdr(assoc 2(tblnext "BLOCK" t))))(setq bkn (cdr(assoc 2(tblnext "BLOCK"))))) 
 (setq ss (ssget "x" (list(cons 2 bkn))) i (+ 1 i)) 
 (if ss (setq no (itoa(sslength ss)))(setq no "0")) 
 (if (< (strlen bkn) 8)(adds (- 8 (strlen bkn))));;;;(adds len)块名不够8位的加到8位--整齐 
 (princ (strcat "\n    图块   " bkn "  有  " no "  个"))(princ) 
) 
) 
;;;;;;;;;;;;;;adds子程序;;;;;;;;;;;;;;;; 
(defun adds (len /)(repeat len (setq bkn (strcat bkn " "))));;;;块名不够8位的加到8位--整齐 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;文本计数----eg.统计"c3"的个数-----门窗统计 
(defun c:ttc (/ txt ss i cnt) 
(princ "\n    ttc--文本计数[门窗统计]------for text-------lxx.2001.2m") 
(setq txt (getstring "\n要统计的text文本:") ss (ssget "x" '((0 . "TEXT"))) i 0 cnt 0) 
(repeat (sslength ss) 
 (setq tt (cdr(assoc 1 (entget(ssname ss i)))) i (1+ i)) 
 (if (wcmatch tt txt)(setq cnt (1+ cnt))) 
) 
(princ (strcat "\n  文本\042 " txt "\042  共有" (itoa cnt) "  个"))(princ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(princ "\n (门窗统计)bkc--[blockcountor]选块计数/bka--全图块统计/ttc文本计数(textcount)------lxx.2001.2m")(princ) 
[/font]

cy956 · 发表于 2002-5-19 01:32:46

应newer 的建议，改下：

(defun c:dwgc(/ E EN IN N NAM S)
(prompt "选择要成dwg图的图块[回车全选:")
(if (NOT (setq s(ssget '((0 . "INSERT")))))
(setq s(ssget "x" '((0 . "INSERT"))))
)
(setq mlm (dos_getdir "\n选择文件存盘目录:" (if mlm mlm "e:\\16\"))
n(sslength s) in 0)
(setvar "cmddia" 0)
(repeat n
(setq e(ssname s in) in(1+ in)
en(entget e)nam (dxf 2 en))
(if (wcmatch nam "\**")
(setq nam1(strcat "unb-" (substr nam 2)))
(setq nam1 nam)
)
(command "wblock" (strcat mlm nam1) nam)
)
(setvar "cmddia" 1) (princ)
)

newer · 发表于 2002-5-19 01:56:06

最初由 cy956 发布
[B]应newer 的建议，改下：

[code]
(defun c:dwgc(/ E EN IN N NAM S)
(prompt "选择要成dwg图的图块[回车全选:")
(if (NOT (setq s(ssget '((0 . "INSERT")))))
(setq s(ssget "x" '((0 . "INSERT"))))... [/B]

能否程序最后给个提示，告诉生成了多少个块，存放到哪个目录下等等？

szkevin · 发表于 2002-5-19 06:11:25

谢谢各位的辛勤劳动成果,在些深表感谢.
我也从国外的网站下载了一个程序,带dcl对话框,功能还是不全,最好在dcl中选择目录及增加一些选项.比如把实体放在0层的选项.

[CODE]
(defun c:wba (/ dir pref name1 lpref lname bl bln dist star fa masege
            env dialog  ddr)
(setvar "cmdecho" 0)
(setq dir "")
(setq dialog "wba.dcl")
(setq ddr (getvar "dwgprefix"))
;.....................................................................

(setq dat (load_dialog dialog))
(if (not (new_dialog "wba" dat)) (exit))

(set_tile "but" ddr)
(mode_tile "but" 2)
(action_tile "but" "(setq dir $value)")
(action_tile "cancel" "(exit)")

(start_dialog)
(unload_dialog dat)

;....................................................................

(if (= dir "")(exit))
(setq pref (getvar "dwgprefix"))
(setq name1 (getvar "dwgname"))
(setq lpref (+ 1 (strlen pref)))
(setq lname (strlen name1))
(if
(> lname 8)
(setq name (substr name1 lpref))
(setq name name1)
)
(setq file (strcat dir name ".txt"))

  (setq bl (tblnext "block" T))
  (setq bln (cdr (assoc 2 bl)))
  (setq dist (strcat dir bln))
  (setq star (substr bln 1 1))
(if (/= star "*")
   (progn
   (command "wblock" dist "Y" bln)
   (setq fa (open file "w"))
   (write-line bln fa)
   (close fa)
   )
)

(while
(setq bl (tblnext "block"))
(setq bln (cdr (assoc 2 bl)))
(setq dist (strcat dir bln))
(setq star (substr bln 1 1))
   (if (/= star "*")
      (progn
      (command "wblock" dist "Y" bln)
      (setq fa (open file "a"))
      (write-line bln fa)
      (close fa)
      )
   )
)
(setq mesage (strcat "Internal blocks are written to " dir " directory
as External Blocks.
List of blocks stored in " file))
(alert mesage)
(princ)
)
;=====================================================================

;.....................................................................

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(prompt "\nProgram WBA.LSP Version 1.1 is loaded. BTN
At command prompt type: WBA")
(PRINC)
;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
[/COLOR]

szkevin · 发表于 2002-5-19 13:26:31

又一个写块的程序,不知这些程序哪个好,贴出来希望大家来共同学习,共同提高,共同改进.

; ----------------------------------------------------------------------
; (Wblocks all local block definitions to target path)
; Website: [url]http://www.dotsoft.com[/url]
; ----------------------------------------------------------------------
; DISCLAIMER: DotSoft Disclaims any and all liability for any damages
; arising out of the use or operation, or inability to use the software.
; FURTHERMORE, User agrees to hold DotSoft harmless from such claims.
; DotSoft makes no warranty, either expressed or implied, as to the
; fitness of this product for a particular purpose. All materials are
; to be considered 慳s-is? and use of this software should be
; considered as AT YOUR OWN RISK.
; ----------------------------------------------------------------------
(defun c:wblockm ()
(setq cmdecho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
;
(if (not dos_getdir)
(setq path (getstring "\nDS> Target Folder: " T))
(setq path (dos_getdir "Target Folder" (getvar "DWGPREFIX")))
)
(if (/= path nil)
(progn
(if (= (substr path (strlen path) 1) "\")
(setq path (substr path 1 (1- (strlen path))))
)
(princ "\nDS> Building List of Blocks ... ")
(setq lst nil)
(setq itm (tblnext "BLOCK" T))
(while (/= itm nil)
(setq nam (cdr (assoc 2 itm)))
(setq pass T)
(if (/= (cdr (assoc 1 itm)) nil)
(setq pass nil)
(progn
(setq ctr 1)
(repeat (strlen nam)
(setq chk (substr nam ctr 1))
(if (or (= chk "*")(= chk "|"))
(setq pass nil)
)
(setq ctr (1+ ctr))
)
)
)
(if (= pass T)
(setq lst (cons nam lst))
)
(setq itm (tblnext "BLOCK"))
)
(setq lst (acad_strlsort lst))
(princ "Done.")
;
(foreach blk lst
(setq fn (strcat path (chr 92) blk))
(if (findfile (strcat fn ".dwg"))
(command "_.WBLOCK" fn "_Y" blk)
(command "_.WBLOCK" fn blk)
)
)
)
)
;
(setvar "CMDECHO" cmdecho)
(princ)
)

; ---------------------------------------------------------------------- 
;          (Wblocks all local block definitions to target path) 
;            Copyright (C) 2000 DotSoft, All Rights Reserved 
;                   Website: [url]http://www.dotsoft.com[/url] 
; ---------------------------------------------------------------------- 
; DISCLAIMER:  DotSoft Disclaims any and all liability for any damages 
; arising out of the use or operation, or inability to use the software. 
; FURTHERMORE, User agrees to hold DotSoft harmless from such claims. 
; DotSoft makes no warranty, either expressed or implied, as to the 
; fitness of this product for a particular purpose.  All materials are 
; to be considered 慳s-is? and use of this software should be 
; considered as AT YOUR OWN RISK. 
; ---------------------------------------------------------------------- 
 
(defun c:wblockm () 
  (setq cmdecho (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  ; 
  (if (not dos_getdir) 
    (setq path (getstring "\nDS> Target Folder: " T)) 
    (setq path (dos_getdir "Target Folder" (getvar "DWGPREFIX"))) 
  ) 
  (if (/= path nil) 
    (progn 
      (if (= (substr path (strlen path) 1) "\") 
        (setq path (substr path 1 (1- (strlen path)))) 
      ) 
      (princ "\nDS> Building List of Blocks ... ") 
      (setq lst nil) 
      (setq itm (tblnext "BLOCK" T)) 
      (while (/= itm nil) 
        (setq nam (cdr (assoc 2 itm))) 
        (setq pass T) 
        (if (/= (cdr (assoc 1 itm)) nil) 
          (setq pass nil) 
          (progn 
            (setq ctr 1) 
            (repeat (strlen nam) 
              (setq chk (substr nam ctr 1)) 
              (if (or (= chk "*")(= chk "|")) 
                (setq pass nil) 
              ) 
              (setq ctr (1+ ctr)) 
            ) 
          ) 
        ) 
        (if (= pass T) 
          (setq lst (cons nam lst)) 
        ) 
        (setq itm (tblnext "BLOCK")) 
      ) 
      (setq lst (acad_strlsort lst)) 
      (princ "Done.") 
      ; 
      (foreach blk lst 
        (setq fn (strcat path (chr 92) blk)) 
        (if (findfile (strcat fn ".dwg")) 
          (command "_.WBLOCK" fn "_Y" blk) 
          (command "_.WBLOCK" fn blk) 
        ) 
      ) 
    ) 
  ) 
  ; 
  (setvar "CMDECHO" cmdecho) 
  (princ) 
)

cy956 · 发表于 2002-5-21 02:25:29

俺贴的上一个程序有误，重写
了一个，加点儿简单对话框；
最近很忙，没时间细检验了，
让大家试用，有问题请指出。

szkevin · 发表于 2002-5-21 08:46:05

收到，谢谢cy956兄，建议增加一个输出块到0层，使输出的块上所有实体都在0层。
程序运行时出现一些小错误：
1）点改目录出错，出现BLKSC ; 错误: no function definition: DOS_GETDIR
2）点块列表出错，出现BLKSC ; 错误: no function definition: DXF
3）点手选块输出后，选择实体时按右键出错，出现错误: no function definition: DXF
改进这些错误，就是一个共享软件了：）

cy956 · 发表于 2002-5-21 23:21:45

:)

DOS_GETDIR 只要你加载了doslib5.1以上版本即可使用。

把以下行粘贴到lisp文件中:
(defun dxf (#code #list)(cdr (assoc #code #list)))

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

[编程申请]：请编一个可以写出图中所有块的程序

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

相关帖子