马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？立即注册
×
- ;;; ----------- Shape Explode - Version 1.0 -----------
- ;;; Copyright (C) 2010 by ResourceCAD International
- ;;; Author: K.E. Blackie
- ;;;
- ;;;
- ;;; RCI PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
- ;;; RESOURCECAD INTERNATIONAL SPECIFICALLY DISCLAIMS ANY
- ;;; IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR
- ;;; USE. RESOURCECAD INTERNATIONAL DOES NOT WARRANT THAT THE OPERATION
- ;;; OF THE PROGRAM WILL BE UNINTERRUPTED OR ERROR FREE.
- ;;;
- ;;;
- ;;; ResouceCAD International
- ;;; http://www.resourcecad.com
- ;;;
- ;;; DESCRIPTION
- ;;; Shape Exploder draws a shape as defined in the associated shx shape file
- ;;; This does not currently include some features available in shapes, but
- ;;; does work on simple shapes. It is expected the additional shape features
- ;;; will be added at some point in the future
- ;;;
- ;;; NOTE
- ;;; The included _ReadStream function which is critical to the operation of
- ;;; this program was developed by MP. The original thread where the function
- ;;; was posted at TheSwamp.org can be found here:
- ;;; http://www.theswamp.org/index.php?topic=17465.msg210365#msg210365
- ;;; No coyright is claimed on those portions of code developed by others.
- ;;;
- ;;; USAGE:
- ;;; SHXPlode
- ;;;
- ;;; May 30, 2010
- ;;;
- ;;; ------------------------------------------------------------
- ;;; Entrypoint - our function to explode shapes
- (defun c:SHXPlode( / data enext insp IsShape name rangl scale shape shapedata sset width )
- (while (/= IsShape t)
- (princ "\nSelect shape to explode: ")
- (setq shape (car (entsel)))
- (if (= (cdr (assoc 0 (entget shape))) "SHAPE")
- (setq IsShape T)
- (princ "\nSelected entity is not a shape: ")
- )
- )
- (setq data (entget shape))
- (setq name (cdr (assoc 2 data))
- scale(cdr (assoc 40 data))
- width(cdr (assoc 41 data))
- rangl(cdr (assoc 50 data))
- insp (cdr (assoc 10 data))
- )
- (setq enext (entlast))
- (setq shapedata (cdr (assoc name (GetMasterDefinitions))))
- (setq osm (getvar "osmode"))
- (DrawVecs (DataString->Points shapedata) insp)
- (setvar "osmode" osm)
- (setq sset (ssadd))
- (while (setq enext (entnext enext))
- (setq sset (ssadd enext sset))
- )
- (vl-cmdf "_rotate" sset "" insp (angtos rangl))
- (vl-cmdf "_scale" sset "" insp scale)
- (entdel shape)
- (princ "\nDone")
- (princ)
- )
- ;;; Put all shape file definitions into a single searchable data list
- (defun GetMasterDefinitions( / n shapefiles)
- (setq shapefiles (GetShapeFiles) MasterDefs nil)
- (foreach n shapefiles
- (setq MasterDefs (append MasterDefs (getShapeDefs n)))
- )
- MasterDefs
- )
- ;;; get shape file definitions from style table
- (defun GetShapeFiles ( / shpfiles test)
- (setq test (tblnext "style" t))
- (while test
- (if (=(cdr (assoc 70 test)) 1)
- (setq shpfiles (append shpfiles (list (cdr (assoc 3 test)))))
- )
- (setq test (tblnext "style"))
- )
- shpfiles
- )
- ;;; readstream function courtesy of MP
- ;;; see post http://www.theswamp.org/index.php?topic=17465.msg210365#msg210365
- (defun _ReadStream ( path len / fso file stream result )
- ;; If the file is successful read the data is returned as
- ;; a string. Won't be tripped up by nulls, control chars
- ;; including ctrl z (eof marker). Pretty fast (feel free
- ;; to bench mark / compare to alternates).
- ;;
- ;; If the caller wants the result as a list of byte values
- ;; simply use vl-string->list on the result:
- ;;
- ;; (setq bytes
- ;; (if (setq stream (_ReadStream path len))
- ;; (vl-string->list stream)
- ;; )
- ;; )
- ;;
- ;; Arguments:
- ;;
- ;; path <duh>
- ;; len Number of bytes to read. If non numeric, less
- ;; than 1 or greater than the number of bytes in
- ;; the file everything is returned.
-
- (vl-catch-all-apply
- '(lambda ( / iomode format size )
- (setq
- iomode 1 ;; 1 = read, 2 = write, 8 = append
- format 0 ;; 0 = ascii, -1 = unicode, -2 = system default
- fso (vlax-create-object "Scripting.FileSystemObject")
- file (vlax-invoke fso 'GetFile path)
- stream (vlax-invoke fso 'OpenTextFile path iomode format)
- size (vlax-get file 'Size)
- len (if (and (numberp len) (< 0 len size)) (fix len) size)
- result (vlax-invoke stream 'read len)
- )
- (vlax-invoke stream 'Close)
- )
- )
- (if stream (vlax-release-object stream))
- (if file (vlax-release-object file))
- (if fso (vlax-release-object fso))
- result
- )
- ;;; Get shapes from file(s)
- (defun GetShapeDefs(strPath / fResult intCount n offset ShapeDefs ShapeIndex TOC)
- (setq strPath (findfile strPath))
- (setq fResult (_ReadStream strPath -1))
- (setq intCount (+(ascii (substr fresult 29 1))(*(ascii (substr fresult 30 1))256)))
- (setq TOC (substr fresult 31 (* intCount 4)))
- (setq offset 0)
- (repeat intCount
- (setq ShapeIndex (append ShapeIndex (list (cons (+(ascii (substr TOC (+ offset 1) 1))(*(ascii (substr TOC (+ offset 2) 1))256)) (+(ascii (substr TOC (+ offset 3) 1))(*(ascii (substr TOC (+ offset 4) 1))256))))))
- (setq offset (+ offset 4))
- )
- (setq offset (1+ offset))
- (foreach n ShapeIndex
- (setq ShapeDefs (append ShapeDefs (list (ParseShapeInfo (substr fResult (+ 30 offset) (cdr n))))))
- (setq offset (+ offset (cdr n)))
- )
- ShapeDefs
- )
- ;;; Parse the shape information string into usable information
- ;;; returns ("SHAPENAME" . "DATASTRING")
- (defun ParseShapeInfo (ShapeInfo / ndx ShapeName)
- (setq ndx 1
- ShapeName "")
- (while (/= (ascii (substr ShapeInfo ndx 1)) 0)
- (setq ShapeName (strcat ShapeName (substr ShapeInfo ndx 1)))
- (setq ndx (1+ ndx))
- )
- (cons ShapeName (substr ShapeInfo (1+ ndx)(- (strlen ShapeInfo)(strlen ShapeName) 2)))
- )
- ;;; DataString->Points converts the datastring of the shape into 3dpoints
- ;;; for use in drawing the shape
- (defun DataString->Points (DataString / mfact penstat plist point testval xOffset yOffset)
- (setq mfact 1.0
- penstat "@")
- (while (>(strlen DataString) 0)
- (setq testVal (ascii (substr DataString 1 1)))
- (cond
- ((= testVal 1)(setq DataString (substr DataString 2) penstat "@")) ;Pen Down
- ((= testVal 2)(setq DataString (substr DataString 2) penstat "")) ;Pen Up
- ((= testVal 3)(setq mfact (/ mfact (ascii (substr DataString 2 1))) DataString (substr DataString 3))) ;Division factor follows
- ((= testVal 4)(setq mfact (* mfact (ascii (substr DataString 2 1))) DataString (substr DataString 3))) ;Multiplication factor follows
- ((= testVal 5)(setq DataString (substr DataString 2))) ;Push current location onto stack **currently ignored
- ((= testVal 6)(setq DataString (substr DataString 2))) ;Pop current location from stack **currently ignored
- ((= testVal 7)(setq DataString (substr DataString 2))) ;Draw subshape number given by next byte **currently ignored
- ((= testVal 8)(setq point (list (* mfact (ascii(substr DataString 2 1)))(* mfact (ascii(substr DataString 3 1)))) DataString (substr DataString 4))) ;x-y displacement from next 2 bytes
- ((= testVal 9)
- (progn
- (while (or (/= 0 (ascii (substr DataString 2 1)))(/= 0 (ascii (substr DataString 3 1))))
- (setq xOffset(ascii(substr DataString 2 1))
- yOffset(ascii(substr DataString 3 1))
- )
- (if (> xOffset 127)
- (setq xOffset (- xOffset 256))
- )
- (if (> yOffset 127)
- (setq yOffset (- yOffset 256))
- )
- (setq point (list (* mfact xOffset)(* mfact yOffset) penstat))
- (setq plist (append plist (list point))
- point nil)
- (setq DataString (substr DataString 3))
- )
- (setq DataString (substr DataString 3))
- )
- ) ;x-y displacement from multiple bytes terminated by double null
- ((= testVal 10)(setq point (ArcVector->ArcPoint (2HexVector (substr DataString 3 1))(ascii (substr DataString 2 1))) DataString (substr DataString 4))) ;Octant arc from next 2 bytes
- ((= testVal 11)(setq DataString (substr DataString 7))) ;Fractional arc from next 5 bytes **currently ignored
- ((= testVal 12)(setq DataString (substr DataString 5))) ;Arc from single x-y displacement and bulge - 3 bytes **currently ignored
- ((= testVal 13)(setq DataString (substr DataString 2))) ;multiple arcs from x-y displacement and bulge data (multiple 3 byte segments terminated by a double null) **currently ignored
- ((= testVal 14)(setq DataString (substr DataString 2))) ;Process next command only if vertical text **Applicable to text only
- ( t (setq point (append (Vector->Point (2HexVector (substr DataString 1 1))) (list PenStat)) DataString (substr DataString 2)))
- )
- (if point
- (setq plist (append plist (list point))
- point nil)
- )
- )
- plist
- )
- ;;; draw the vectors
- ;;; currently only handles lines
- ;;; and octant arcs
- (defun drawvecs(vecs inspoint / ep n sp prevpoint pt)
- (setq prevpoint inspoint)
- (foreach n vecs
- (cond
- ((= (caddr n) "")(setq prevpoint (NextPoint prevpoint n)))
- ((= (caddr n) "@")
- (progn
- (setq pt (strcat (rtos (car prevpoint) 2 8)","(rtos (cadr prevpoint) 2 8)))
- (vl-cmdf "line" pt (strcat "@"(rtos (car n) 2 8)","(rtos (cadr n) 2 8)) "")
- (setq prevpoint (NextPoint prevpoint n))
- )
- )
- (t (vl-cmdf "arc" prevpoint "c" (strcat "@" (rtos (car n) 2 8)","(rtos (cadr n) 2 8)) "a" (caddr n))
- (setq ep (vlax-get (vlax-ename->vla-object (entlast)) 'Endpoint))
- (setq sp (vlax-get (vlax-ename->vla-object (entlast)) 'Startpoint))
- (if (equal sp (append prevpoint (list 0.0)) 0.0000001)
- (setq prevpoint ep)
- (setq prevpoint sp)
- )
- )
- )
- )
- )
- ;;; advance the current point to the next point
- ;;; as determined by the offset
- (defun NextPoint (startpoint offset / newx newy newpoint)
- (setq newx (+ (car startpoint)(car offset))
- newy (+ (cadr startpoint)(cadr offset))
- )
- (setq newpoint (list newx newy))
- newpoint
- )
- ;;; convert a char to a hex vector so it can be parsed
- ;;; according to the rules defining a shape
- (defun 2HexVector (character / ax bx highbit lowbit)
- (setq ascval (ascii character))
- (setq highbit (/ ascval 16))
- (cond
- ((= highbit 0)(setq ax "0"))
- ((= highbit 1)(setq ax "1"))
- ((= highbit 2)(setq ax "2"))
- ((= highbit 3)(setq ax "3"))
- ((= highbit 4)(setq ax "4"))
- ((= highbit 5)(setq ax "5"))
- ((= highbit 6)(setq ax "6"))
- ((= highbit 7)(setq ax "7"))
- ((= highbit 8)(setq ax "8"))
- ((= highbit 9)(setq ax "9"))
- ((= highbit 10)(setq ax "A"))
- ((= highbit 11)(setq ax "B"))
- ((= highbit 12)(setq ax "C"))
- ((= highbit 13)(setq ax "D"))
- ((= highbit 14)(setq ax "E"))
- ((= highbit 15)(setq ax "F"))
- )
- (setq lowbit (- ascval (* highbit 16)))
- (cond
- ((= lowbit 0)(setq bx "0"))
- ((= lowbit 1)(setq bx "1"))
- ((= lowbit 2)(setq bx "2"))
- ((= lowbit 3)(setq bx "3"))
- ((= lowbit 4)(setq bx "4"))
- ((= lowbit 5)(setq bx "5"))
- ((= lowbit 6)(setq bx "6"))
- ((= lowbit 7)(setq bx "7"))
- ((= lowbit 8)(setq bx "8"))
- ((= lowbit 9)(setq bx "9"))
- ((= lowbit 10)(setq bx "A"))
- ((= lowbit 11)(setq bx "B"))
- ((= lowbit 12)(setq bx "C"))
- ((= lowbit 13)(setq bx "D"))
- ((= lowbit 14)(setq bx "E"))
- ((= lowbit 15)(setq bx "F"))
- )
- (strcat "0" ax bx)
- )
- ;;; convert a vector to a point offset
- (defun Vector->Point (vector / ax ay highbit len lowbit)
- (setq highbit (substr vector 2 1)
- lowbit (substr vector 3 1)
- )
- (cond
- ((= highbit "0")(setq len 0))
- ((= highbit "1")(setq len 1))
- ((= highbit "2")(setq len 2))
- ((= highbit "3")(setq len 3))
- ((= highbit "4")(setq len 4))
- ((= highbit "5")(setq len 5))
- ((= highbit "6")(setq len 6))
- ((= highbit "7")(setq len 7))
- ((= highbit "8")(setq len 8))
- ((= highbit "9")(setq len 9))
- ((= highbit "A")(setq len 10))
- ((= highbit "B")(setq len 11))
- ((= highbit "C")(setq len 12))
- ((= highbit "D")(setq len 13))
- ((= highbit "E")(setq len 14))
- ((= highbit "F")(setq len 15))
- )
- (cond
- ((= lowbit "0")(setq ax len ay 0))
- ((= lowbit "1")(setq ax len ay (* len 0.5)))
- ((= lowbit "2")(setq ax len ay len))
- ((= lowbit "3")(setq ax (* len 0.5) ay len))
- ((= lowbit "4")(setq ax 0 ay len))
- ((= lowbit "5")(setq ax (* len -0.5) ay len))
- ((= lowbit "6")(setq ax (* len -1.0) ay len))
- ((= lowbit "7")(setq ax (* len -1.0) ay (* len 0.5)))
- ((= lowbit "8")(setq ax (* len -1.0) ay 0))
- ((= lowbit "9")(setq ax (* len -1.0) ay (* len -0.5)))
- ((= lowbit "A")(setq ax (* len -1.0) ay (* len -1.0)))
- ((= lowbit "B")(setq ax (* len -0.5) ay (* len -1.0)))
- ((= lowbit "C")(setq ax 0 ay (* len -1.0)))
- ((= lowbit "D")(setq ax (* len 0.5) ay (* len -1.0)))
- ((= lowbit "E")(setq ax len ay (* len -1.0)))
- ((= lowbit "F")(setq ax len ay (* len -0.5)))
- )
- (list ax ay)
- )
- ;;; convert the arc vector data into a point offset
- (defun ArcVector->ArcPoint(vector radius / center dvec range start )
- (setq start (substr vector 2 1))
- (if (numberp (distof start))
- (if (< (distof start) 8)
- (setq dvec 1)
- (setq dvec -1)
- )
- (setq dvec -1)
- )
- (setq range (* dvec (* (distof (substr vector 3 1))45)))
- (cond
- ((or (= start "0")(= start "8"))(setq center (polar (list 1 1)(angtof "180") radius)))
- ((or (= start "1")(= start "9"))(setq center (polar (list 1 1)(angtof "225") radius)))
- ((or (= start "2")(= start "A"))(setq center (polar (list 1 1)(angtof "270") radius)))
- ((or (= start "3")(= start "B"))(setq center (polar (list 1 1)(angtof "315") radius)))
- ((or (= start "4")(= start "C"))(setq center (polar (list 1 1) 0 radius)))
- ((or (= start "5")(= start "D"))(setq center (polar (list 1 1)(angtof "45") radius)))
- ((or (= start "6")(= start "E"))(setq center (polar (list 1 1)(angtof "90") radius)))
- ((or (= start "7")(= start "F"))(setq center (polar (list 1 1)(angtof "135") radius)))
- )
- (setq center (list (- (car center) 1.0)(- (cadr center) 1.0)))
- (append center (list range))
- )
| 
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
已领礼包: 
财富等级: 
发表于 2016-12-12 16:59:20
提升卡
置顶卡
沉默卡
变色卡
千斤顶
发表于 2016-12-12 17:43:14
