|
|
发表于 2014-7-31 16:44:14
|
显示全部楼层
即使在转换回2004年后，我也无法在ACAD2006中打开DWG。它返回纯线条工作=- -==- -==- -==- -==- -==- -==- -==-
;;================================================================
(vl-load-com)
(defun c:wshapes (/ path filename handle stream result InsBlk insLay wShapeDBfn attdata *error*)
(setq InsLay "0") ; layer to use for Block Insert
;; add attributes to BlockDef
;; AttData list of list with 3 strings '((TAG Prompt DefVal)("DATA1" "Prompt1" "DefValue1"))
;; This example add 2 hidden attributes to each new block
(setq attdata '(("DATA1" "Prompt1" "DefValue1")("DATA2" "Prompt2" "DefValue2")))
(setq wShapeDBfn "AISC_SHAPE_W.txt")
;; error function & Routine Exit
(defun *error* (msg)
(if (not (member msg '("console break" "Function cancelled" "quit / exit abort" "")))
(princ (strcat "\nError: " msg))
) ; endif
(and usrosmode (setvar "osmode" usrosmode))
(and usrormode (setvar "orthomode" usrormode))
(if (and MoveStarted Ins)
(command "._erase" Ins "")
)
)
;; parser by CAB single character delim, match ","
(defun sparser (str delim / ptr lst)
(while (setq ptr (vl-string-search delim str))
(setq lst (cons (substr str 1 ptr) lst))
(setq str (substr str (+ ptr 2)))
)
(reverse (cons str lst))
)
;;+++++++++++++++++++++++++++++++
;; convert the text to a number - CAB
;;+++++++++++++++++++++++++++++++
(defun txt2num (txt / num)
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
num
)
(defun getdata (lst / nlst L sl sl2)
(foreach ln lst
(setq l (sparser ln "\t")
sl (car l)
l (cdr l)
sl2 nil
)
(if (/= "" (vl-string-trim " \t\n" sl)) ; skip blank lines
(progn
(foreach itm l (setq sl2 (cons (txt2num itm) sl2)))
(setq l (cons sl (reverse sl2)))
(setq nlst (cons l nlst))
)
)
)
nlst
)
(defun makedatabase (filename / path handle result stream)
(if (null wdatabase*)
(if (setq path (findfile filename))
(if (setq handle (open path "r"))
(progn
(while (setq stream (read-line handle))
(setq result (cons stream result))
)
(setq wdatabase* (getdata result))
(princ)
)
)
)
)
)
;; by CAB 10/05/2007
;; Expects pts to be a list of 2D or 3D point lists
;; Returns new pline object
(defun makepline (spc pts / norm elv pline)
(setq norm (trans '(0 0 1) 1 0 t)
elv (caddr (trans (car pts) 1 norm))
)
;; flatten the point list to 2d
(if (= (length (car pts)) 2) ; 2d point list
(setq pts (apply 'append pts))
(setq pts (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) pts)))
)
(setq
pts (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts))))
pts
)
)
)
(setq pline (vla-addlightweightpolyline spc pts))
(vla-put-elevation pline elv)
(vla-put-normal pline (vlax-3d-point norm))
(vla-put-closed pline :vlax-true)
(vla-put-layer pline "0")
;;(vla-put-Color PolObj AcYellow)
;;(vla-put-Linetype PolObj "HIDDEN")
pline
)
;; sname dep bf tw tf
;; ("W12X16" 12.0 4.0 0.25 0.25 0.8125 0.5625)
(defun makewshape (space data attdata / att attdata atts bf blkdef bn d doc l1 l2 p1 p10
p11 p12 p13 p2 p3 p4 p5 p6 p7 p8 p9 plobj r tf tw x y)
(mapcar '(lambda (x y) (set x y)) '(bn d bf tf tw x y) data)
(if (tblsearch "block" bn) ; block exist
(vlax-invoke space 'insertblock (trans '(0. 0. 0.) 1 0) bn 1. 1. 1. 0.)
(progn
;; make the shape with pline, chamfer ILO arc at web
;; p2 is lower left point
;; radius at web is undifined by ASCI & left to the Manufactures
;; This shape uses 1/2 the web thickness (tw) for the chamfer
;; Chamfer points occur at p5 p6 p11 p12 so in place of p5 use
;; (vadd p5 (list 0. r)) (vadd p5 (list r 0.))
(defun vadd (v1 v2) (mapcar '+ v1 v2))
(setq p1 '(0. 0.)
l1 (/ bf 2.) ; 1/2 base
l2 (- l1 (/ tw 2.))
r (/ tw 2.) ; chamfer value
p2 (vadd p1 (list (- l1) 0.)) ; 0 = no change
p3 (vadd p2 (list bf 0.))
p4 (vadd p3 (list 0. tf))
p5 (vadd p4 (list (- l2) 0.))
p6 (vadd p5 (list 0. (- d (* tf 2))))
p7 (vadd p6 (list l2 0.))
p8 (vadd p7 (list 0. tf))
p9 (vadd p8 (list (- bf) 0.))
p10 (vadd p9 (list 0. (- tf)))
p11 (vadd p10 (list l2 0.))
p12 (vadd p11 (list 0. (- (- d (* tf 2)))))
p13 (vadd p12 (list (- l2) 0.))
)
;; create the block def
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq blkdef (vlax-invoke (vla-get-blocks doc) 'add '(0. 0. 0.) bn))
;; add attributes to BlockDef
;; AttData list of list with 3 strings '((TAG Prompt DefVal)("DATA1" "Prompt1" "DefValue1"))
(foreach itm attdata
(setq atts ; list of enames for the attribute Def
(cons
;; AddAttribute (Height, Mode, Prompt, InsertionPoint, Tag, Value)
;;(setq att (vla-AddAttribute blk 0.5 acAttributeModeInvisible (cadr itm) p1 (car itm) (caddr itm)))
(setq att (vlax-invoke blkdef 'addattribute 0.5 1 (cadr itm) '(0. 0. 0.) (car itm) (caddr itm)))
atts))
(vla-put-layer att "0")
) ; end foreach
;; chamfer added to web, pline obj added to BlockDef
(setq plobj (makepline blkdef (list p2 p3 p4
(vadd p5 (list r 0.)) (vadd p5 (list 0. r))
(vadd p6 (list 0. (- r))) (vadd p6 (list r 0.))
p7 p8 p9 p10
(vadd p11 (list (- r) 0.)) (vadd p11 (list 0. (- r)))
(vadd p12 (list 0. r)) (vadd p12 (list (- r) 0.))
p13))) ; vla object
(vlax-invoke space 'insertblock (trans '(0. 0. 0.) 1 0) bn 1. 1. 1. 0.)
)
) ; endif
)
;; DCL routine for user to select shape from database
;; Returns the shape name i.e. "W4X12"
(defun getuserpick (database picked / dclfile dcl# fn shapepick)
(setq fn "wShapes.dcl")
(cond
((not (setq dclfile (findfile fn))) (prompt (strcat "\nCannot find " fn ".")))
((=- -==- -==- -==- -==- -==- -==- -==-
;; Run the Dialog
;; -==- -==- -==- -==- -==- -==- -==- -==-
(defun doit (dcl_id data pick / action fulllst n pick)
(setq fulllst (mapcar 'car data)) ; list of only shape names
(start_list "shapelist")
(mapcar 'add_list fulllst)
(end_list)
;; Update filename display for list box
(action_tile "shapelist" "(setq pick (nth (atoi $value) fulllst))")
(if (setq n (vl-position pick fulllst))
(set_tile "shapelist" (itoa n))
(set_tile "shapelist" "0")
)
(action_tile "Insert" "(done_dialog 2)")
(action_tile "HelpDialog" "(done_dialog 5)")
(action_tile "Done" "(done_dialog 0)")
;; ******************************************************
(setq action (start_dialog))
;; ******************************************************
(cond
((= action 1) (setq pick null)) ; exit
((= action 2)) ; exit
((= action 5) (setq pick null)) ;
((setq pick null)) ; unknown code
)
(unload_dialog dcl_id)
pick
) ; end defun
;; This is my clumsy routine to move & rotate an Insert. It repeats with the same Block
;; until user hits Enter or Escape
(defun MoveBlock (obj spc lay / ins movestarted npt ormodetmp osmodetmp pt shape usrormode usrosmode bn)
(setq pt '(0 0))
(setq usrosmode (getvar "osmode")) ; reset when routine ends
(setq usroRmode (getvar "orthomode")) ; reset when routine ends
(setq osmodetmp (getvar "osmode")) ; temp setting
(setq ormodetmp (getvar "orthomode")) ; temp setting
(setq bn (vla-get-name obj))
;; (setvar "osmode" 0)
(while
(progn
(setq MoveStarted t)
;; (setvar "osmode" 0)
(setvar "orthomode" 0)
(setq Ins (vlax-vla-object->ename obj))
(vla-put-layer obj Lay) ; Layer of Insert
(command "._move" Ins "" pt)
;;(setvar "osmode" osmodetmp)
(command pause)
(if (or (and (null npt) (setq npt (getvar "lastpoint")))
(> (distance pt (setq npt (getvar "lastpoint"))) 0.001))
(progn
;; allow user to rotate
(setvar "osmode" osmodetmp)
(setvar "orthomode" 1)
(command "._rotate" Ins "" "_non" npt)
(command pause)
(setq MoveStarted nil)
(setq osmodetmp (getvar "osmode"))
(command "._undo" "_end")
(command "._undo" "_begin")
;; Add a new Insert
(setq obj (vlax-invoke spc 'insertblock (trans '(0. 0. 0.) 1 0) bn 1. 1. 1. 0.))
t ; stay in loop
)
)
)
) ; while
(*error* "")
(command "._undo" "_end")
(princ)
)
;;================================================================
;; Start of Routine
;;================================================================
(setq space
(if (= 1 (getvar "CVPORT"))
(vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
(vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
)
)
(or UserShapePick (setq UserShapePick "")) ; string = to 1st item in list "W4X12"
; (setq wdatabase* nil) ; debug
(cond
((not (or wdatabase* (makedatabase wShapeDBfn))) ; load database from text file
(princ "\nDatabase Failed to Load.")
)
((not (setq shape (getuserpick wdatabase* UserShapePick))) ; need user selection
(princ "\nUser Quit or Problem with DCL.")
)
((setq data (assoc shape wdatabase*))
;; got new shape
(setq UserShapePick shape)
;; make block if not in drawing
(setq InsBlk (makewshape space data attdata)) ; add block to DWG & Insert @ 0,0
(if insBlk ; move it into position
(MoveBlock InsBlk space InsLay)
)
)
((princ "\nUser Quit."))
)
(princ)
)
[/code]
|
|
置顶卡
