[编程交流] Wall LISP请求。

;;; ------------------------------------------------------------------------
;;;    PLAN_STUDWALL.lsp v1.0
;;;
;;;    Copyright © December, 2006
;;;    Timothy G. Spangler
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
;;;    WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
;;;    PURPOSE AND OF MERCHANTIBILITY ARE HEREBY DISCLAIMED BY THE
;;;    PROGRAMMER.
;;;
;;; -----------------------------------------------------------------------
(defun c:STUDWALL (/)(STUD_WALL "CMD" nil nil nil))
(defun STUD_WALL (RunType StudSize StudSpace DryWall / *error* OldClayer OldCmdEcho OldLunits OldLuPrec ActiveDoc Space StudSize StartPoint EndPoint StudSpace WallLength WallAngle Angle-180 Angle+90 Width Length NoStuds )
 
 ;;; Begin Error Handler -------------------------------------------------
(defun *error* (MSG)
        (if (not (member MSG '("Function cancelled" "quit / exit abort")))
                (princ (strcat "\n*** Program Error: " (strcase MSG) " ***"))
                (princ "\n... Program Cancelled ...")
        )
        (while (< 0 (getvar "cmdactive"))
                (command)
        )
        ;; Reset environment varialbes
        (STUDWALL_RESET_ENV)
)
;;; End Error Handler ---------------------------------------------------
(STUDWALL_SET_ENV)
)
;;; ------------ SET ENVIROMENT BEFORE LAUNCH
(defun STUDWALL_SET_ENV(/)
(setq OldClayer (getvar "CLAYER"))
(setq OldCmdEcho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "_undo" "BE")
(setq        ActiveDoc        (vla-get-activedocument (vlax-get-acad-object)))
(setq Space
        (if (= (getvar "cvport") 1)
                (vla-get-paperspace ActiveDoc)
                (vla-get-modelspace ActiveDoc)
        )
)
;; Create framing layer
(STUD_CREATE_LAYER "A-FRAM-WALL" "Framing Plan - Wall framing linework" "Continuous" "25" "157" "0")
(setvar "CLAYER" "A-FRAM-WALL")
;; Create wall
(if (= RunType "CMD")
        (RUN_STUDWALL)
        (GET_STUD_POINTS StudSize StudSpace DryWall)
)
)
;;; ------------ RUN STUDWALL
(defun RUN_STUDWALL (/)
;; Get wall thickness
(initget 1 "4 6 8")
(setq StudSize (getkword " \nEnter wall Thickness: (4=2x4/6=2x6/8=2x8)"))
;; Get stud spacing
(while (< (setq StudSpace (getreal " \nEnter stud spacing: "))6.0)
        (alert " Stud spacing Needs to be greater than 6" ")
)                        
;; Get drywall
(initget 1 "Yes y Y No n N")
(setq DryWall (strcase (getkword " \nAdd drywall?: (Yes/No)")))
(GET_STUD_POINTS StudSize StudSpace DryWall)
)
(defun GET_STUD_POINTS (StudSize StudSpace DryWall /)
;; Create stud block
(CREATE_STUD StudSize)
;; Define start and end points
(setq StartPoint (getpoint " \nDefine Start point for studwall: "))
(setq EndPoint (getpoint StartPoint " \nDefine end point for studwall: "))        
;; Set wall variables
(setq WallLength (distance StartPoint EndPoint))
(setq WallAngle (angle StartPoint EndPoint))        
(setq Angle-180 (- WallAngle (DTR 180)))
(setq Angle+90 (+ WallAngle (DTR 90)))
;; Justify start and end points
(setq StartPoint (polar StartPoint Angle+90 (/ Width 2)))
(setq EndPoint (polar EndPoint Angle+90 (/ Width 2)))
;; Create the wall
(CREATE_STUDWALL)
)
;;; ------------ CREATE STUDWALL
(defun CREATE_STUDWALL ( / Point Temp DWallLine1 DWallLine2 WallLine1 WallLine2 WallCenter WallEnd1 WallEnd2)
;; Create first stud
(INSERT_STUD BlockName (polar StartPoint WallAngle (/ Length 2)) WallAngle)
;; Count the number of studs
(setq NoStuds 1)
;; Create intermediate studs
(setq Point StartPoint)
(setq Temp (- WallLength 3))
(while (> Temp StudSpace)
        (setq Point (polar Point WallAngle StudSpace))
        (INSERT_STUD BlockName Point WallAngle)
        (setq Temp (- Temp StudSpace))
        
        ;; Add to the stud count
        (setq NoStuds (1+ NoStuds))
)
;; Create last stud
(INSERT_STUD BlockName (polar EndPoint Angle-180 (/ Length 2)) WallAngle)
;; Add to the stud count
(setq NoStuds (1+ NoStuds))
;; Create wall lines
(setq WallCenter (vlax-invoke Space 'addline StartPoint EndPoint))
(setq WallLine1 (car (vlax-invoke WallCenter 'offset (/ Width 2))))
(setq WallLine2 (car (vlax-invoke WallCenter 'offset (-(/ Width 2)Width))))
;; Delete centerline
(vlax-invoke WallCenter 'delete)
;; Add drywall
(if (= DryWall "YES")
        (progn
                (setq DWallLine1 (car (vlax-invoke WallLine1 'offset 0.5)))
                (setq DWallLine2 (car (vlax-invoke WallLine2 'offset -0.5)))
                (setq WallEnd1 (vlax-invoke Space 'addline (vlax-get DWallLine1 'Startpoint)(vlax-get DWallLine2 'Startpoint)))
                (setq WallEnd2 (vlax-invoke Space 'addline (vlax-get DWallLine1 'Endpoint)(vlax-get DWallLine2 'Endpoint)))
        )
        (progn
                (setq WallEnd1 (vlax-invoke Space 'addline (vlax-get WallLine1 'Startpoint)(vlax-get WallLine2 'Startpoint)))
                (setq WallEnd2 (vlax-invoke Space 'addline (vlax-get WallLine1 'Endpoint)(vlax-get WallLine2 'Endpoint)))
        )
)
;; Send stud count
(princ (strcat "\nThere are " (rtos NoStuds 5 0)" studs in the wall."))
;; Reset environment varialbes
(STUDWALL_RESET_ENV)
)
;;; ------------ LAYER CREATION ROUINE
(defun STUD_CREATE_LAYER (Layer Descpition Linetype Thickness Color Plot / TmpList VLA-Obj)
;; Check to see if linetype exsists
(if (= (tblsearch "ltype" Linetype) nil)                
        (if (STUD_CHECK_LINETYPE (findfile "acad.lin") Linetype)
                (command "linetype" "load" Linetype "acad.lin" "")
                (setq Linetype "Continuous")
        )
)
;;; ------------ CREATE A LIST FOR ENTMAKE
(setq TmpList
        '((0 . "LAYER")
        (100 . "AcDbSymbolTableRecord")
        (100 . "AcDbLayerTableRecord")
        (70 . 0)
        )
        )
        ;; Create layer name list
        (setq TmpList (append TmpList (list (cons 2 Layer))))
        ;; Create layer color list
        (setq TmpList (append TmpList (list (cons 62 (atoi Color)))))
        ;; Create layer linetype list
        (setq TmpList (append TmpList (list (cons 6 Linetype))))
        ;; Create layer lineweight list
        (setq TmpList (append TmpList (list (cons 370 (atoi Thickness)))))
        ;; Create layer plot list
        (setq TmpList (append TmpList (list (cons 290 (atoi Plot)))))
        ;; Create layer from first item in the list
        (entmake TmpList)      
        ;; Create layer description
        (if(or(= 16.1 (atof(getvar "acadver")))(< 16.1 (atof(getvar "acadver"))))
        (progn
        (setq VLA-Obj(vla-Add (vla-Get-Layers ActiveDoc)Layer))
        (vla-Put-Description VLA-Obj Descpition)
        (vlax-release-object VLA-Obj)
        )
)
)
;;; ------------ CHECKS TO SEE IF A LINETYPE IS AVAILIBLE
(defun STUD_CHECK_LINETYPE (LINFile Linetype / OpenFile LineNumber CurrentLine Result)
(setq OpenFile (open LINFile "r"))
(while (setq CurrentLine (read-line OpenFile))
        (if (wcmatch CurrentLine "`**")
                (progn                                
                        (setq LinetypeName (substr(car(TGS:Stringtolist CurrentLine ","))2))
                        (if (= (strcase Linetype) LinetypeName)
                                (setq Result T)
                        )
                )
        )
)
(close OpenFile)
Result
)
;;; ------------ STRING TO LIST SUB ROUTINE
(defun TGS:StringToList (Stg Del / CurChr PosCnt TmpLst TmpStr)
(setq PosCnt 1
                        TmpStr ""
)
(repeat (1+ (strlen Stg))
        (setq CurChr (substr Stg PosCnt 1))
        (if (= CurChr Del)
                (progn
                        (setq TmpLst (cons TmpStr TmpLst))
                        (setq TmpStr "")
                )
                (setq TmpStr (strcat TmpStr CurChr))
        )
        (setq PosCnt (1+ PosCnt))
)
(setq TmpLst (reverse TmpLst))
)
;;; ------------ INSERT STUD BLOCK SUB
(defun INSERT_STUD (BlockName InsPoint RotAngle /)
(entmake 
        (list 
                (cons 0 "INSERT") ;***
                (cons 2 BlockName) ;***
                (cons 6 "BYLAYER")
                ;(cons 8 "0") ;Layer name
                (cons 10 InsPoint) ;***
                (cons 39 0.0)
                (cons 41 1.0)
                (cons 42 1.0)
                (cons 43 1.0)
                (cons 44 0.0)
                (cons 45 0.0)
                (cons 50 RotAngle)
                (cons 62 256)
                (cons 70 0)
                (cons 71 0)
                (cons 210 (list 0.0 0.0 1.0))
        )
)
)                                                         
;;; ------------ CREATE STUD BLOCK SUB - DOES NOT INSERT BLOCK
(defun CREATE_STUD (StudSize /)
(setq OldLunits (getvar "LUNITS"))
(setq OldLuPrec (getvar "LUPREC"))
(setvar "LUNITS" 2)
(setvar "LUPREC" 1)
(cond
        ((= StudSize "4")(setq BlockName "2x4")(setq Length 1.5)(setq Width 3.5))
        ((= StudSize "6")(setq BlockName "2x6")(setq Length 1.5)(setq Width 5.5))
        ((= StudSize "8")(setq BlockName "2x8")(setq Length 1.5)(setq Width 7.5))
)
(if (= (tblsearch "block" BlockName) nil) 
        (progn 
                (entmake
                        (list
                                (cons 0 "BLOCK")
                                (cons 2 BlockName)
                                (cons 70 64)
                                (cons 10 (list 0.0 0.0 0.0))
                                (cons 8 "0")
                        )
                )
                ;; Left Side Line
                (entmake
                        (list
                                (cons 0 "LINE")
                                (cons 10 (list (- (/ Length 2) Length) (- (/ Width 2) Width) 0.0))
                                (cons 11 (list (- (/ Length 2) Length) (/ Width 2) 0.0))
                                (cons 8 "0")
                                (cons 62 256)
                        )
                )
                ;; Bottom Line
                (entmake
                        (list
                                (cons 0 "LINE")
                                (cons 10 (list (- (/ Length 2) Length) (- (/ Width 2) Width) 0.0))
                                (cons 11 (list (/ Length 2) (- (/ Width 2) Width)  0.0))
                                (cons 8 "0")
                                (cons 62 256)
                        )
                )
                ;; Right Side Line
                (entmake
                        (list
                                (cons 0 "LINE")
                                (cons 10 (list (/ Length 2) (- (/ Width 2) Width)  0.0))
                                (cons 11 (list (/ Length 2) (/ Width 2)  0.0))
                                (cons 8 "0")
                                (cons 62 256)
                        )
                )
                ;; Top Line
                (entmake
                        (list
                                (cons 0 "LINE")
                                (cons 10 (list (/ Length 2) (/ Width 2)  0.0))
                                (cons 11 (list (- (/ Length 2) Length) (/ Width 2) 0.0))
                                (cons 8 "0")
                                (cons 62 256)
                        )
                )
                ;; Left Cross
                (entmake
                        (list
                                (cons 0 "LINE")
                                (cons 10 (list (- (/ Length 2) Length) (/ Width 2) 0.0))
                                (cons 11 (list (/ Length 2) (- (/ Width 2) Width)  0.0))
                                (cons 8 "0")
                                (cons 62 
                        )
                )
                ;; Right Cross
                (entmake
                        (list
                                (cons 0 "LINE")
                                (cons 10 (list (- (/ Length 2) Length) (- (/ Width 2) Width) 0.0))
                                (cons 11 (list (/ Length 2) (/ Width 2)  0.0))
                                (cons 8 "0")
                                (cons 62 
                        )
                )
                ;; Endblock
                (entmake
                        '((0 . "ENDBLK"))
                ) 
        )
        (princ "\n\n Block found in drawing")
)
(setvar "LUNITS" OldLunits)
(setvar "LUPREC" OldLuPrec)
BlockName
)
;; ------------ DEGREES / RADIANS SUB ROUTINES
(defun DTR (NumberOfDegrees) 
(* pi (/ NumberOfDegrees 180.0))
)
;;; ------------ RESET SYSEM VARIABLES
(defun STUDWALL_RESET_ENV (/)
(command "_undo" "End")
(setvar "CMDECHO" OldCmdEcho)
(setvar "CLAYER" OldClayer)
(princ)        
)
;;;
;;; Echos to the command line
(princ "\n CreateStudWall v1.0 ©Timothy Spangler, \n  December, 2006....loaded.")
(terpri)
(princ "Type "STUDWALL" to begin")
(print)
;;; End echo