源码分享
本帖最后由 highflybird2014 于 2014-3-20 13:06 编辑(defun c:pile(/)
(vl-load-com)
;-------------------
;Set units to mm
;-------------------
(Command "INSUNITS" "4")
;-------------------
;Creating Layers
;-------------------
(if (not (tblsearch "LAYER" "01_PILE"))
(command "_.Layer" "_Make" "01_PILE" "_Color" "3" "" "LType" "Continuous" "" "")
);if
(if (not (tblsearch "LAYER" "02_SPIRAL"))
(command "_.Layer" "_Make" "02_SPIRAL" "_Color" "1" "" "LType" "Continuous" "" "")
);if
(if (not (tblsearch "LAYER" "03_REBAR"))
(command "_.Layer" "_Make" "03_REBAR" "_Color" "6" "" "LType" "Continuous" "" "")
);if
(if (not (tblsearch "LAYER" "04_RING"))
(command "_.Layer" "_Make" "04_RING" "_Color" "5" "" "LType" "Continuous" "" "")
);if
(if (not (tblsearch "LAYER" "05_ANNO_LINE"))
(command "_.Layer" "_Make" "05_ANNO_LINE" "_Color" "252" "" "LType" "Continuous" "" "")
);if
(if (not (tblsearch "LAYER" "06_ANNO_TEXT"))
(command "_.Layer" "_Make" "06_ANNO_TEXT" "_Color" "7" "" "LType" "Continuous" "" "")
);if
;---------------------------------
;getting the Pile center from user
;---------------------------------
(setq cpoint (getpoint "\n Specify the center point of pile: "))
(setq X (car cpoint))
(setq Y (car (cdr cpoint)))
;turn off object snap
(setvar "OSMODE" (boole 7 (getvar "OSMODE") 16384))
;-----------------------------
;getting information from user
;-----------------------------
(setq PileDia (getint "\n Pile Diameter (mm): "))
(setq Pilelen (getint "\n Pile length (m): "))
(setq Pilelen (* Pilelen 1000))
(setq cover (getint "\n Concrete Cover (mm): "))
(setq rebarDia (getint "\n Rebar diameter (mm): "))
(setq Nrebar (getint "\n Number of bars: "))
(setq Devlen (getint "\n Development length (mm): "))
(setq SpiralDia (getint "\n Spiral bar diameter (mm): "))
(setq Spiralpitch (getint "\n Spiral pitch (mm): "))
(setq ringdia (getint "\n Ring bar diameter in (mm): "))
(setq ringpitch (getint "\n Ring pitch in (mm): "))
;--------------------
;Drawing Pile section
;--------------------
;------------
;Drawing Pile
;------------
(Command "-Layer" "_s" "01_Pile" "")
(command "circle" cpoint "_D" PileDia); draw the pile outer line
;--------------
;Drawing Spiral
;--------------
(Command "-Layer" "_s" "02_Spiral" "")
(setq SpiralOD (- Piledia (* 2 cover))) ; Calculate the spiral outer diameter
(setq SpiralID (- SpiralOD (* 2 SpiralDia))) ; Calculate the spiral inner diameter
(command "circle" cpoint "_D" SpiralOD)
(command "circle" cpoint "_D" SpiralID)
;--------------
;Drawing Ring
;--------------
(Command "-Layer" "_s" "04_Ring" "")
(setq ringOD (- SpiralID (* 2 rebarDia)))
(setq ringID (- ringOD (* 2 ringdia)))
(command "circle" cpoint "_D" ringOD)
(command "circle" cpoint "_D" ringID)
(Command "-Layer" "_s" "0" "")
;--------------
;Drawing Rebars
;--------------
; Get coordinates of top inner side of spiral
(setq rbartop (+ y (/ spiralid 2))); calculating the top Y coordinate value of rebar
(setq rbarbottom (+ y (/ ringod 2))); calculating the bottom Y coordinate value of rebar
(setq rbartop (rtos rbartop 2 3)); converting Top Y value to string
(setq rbarbottom (rtos rbarbottom 2 3)); converting bottom Y value to string
(setq xx (rtos x 2 3))
;-----------
(setq Pt1 (strcat xX "," rbartop)); set coordinates of top point of rebar
(setq Pt2 (strcat xX "," rbarbottom)); set coordinates of bottom point of rebar
;-----------
(Command "-Layer" "_s" "03_Rebar" "")
(command "circle" "_2p" Pt1 Pt2); draw the rebar
(command "_ARRAY" "_last" "" "_P" cpoint Nrebar "" "")
(command "hatch" "solid" "last" ""); Hatching the Rebar
;(command "_Arraypolar" "_last" "" cpoint Nrebar "" "");for 2013 version
(command "_ARRAY" "_last" "" "_P" cpoint Nrebar "" "")
;--------------------
;Drawing Pile Profile
;-----------------------
;----------------------------
;getting the Pile top left corner
;----------------------------
(setq xuplcornerp (- X (/ piledia 2)))
(setq Yuplcornerp (- Y (+ piledia (* 2 devlen))))
(setq xxuplcornerp (rtos xuplcornerp 2 3))
(setq YYuplcornerp (rtos Yuplcornerp 2 3))
(setq uplcornerp (strcat xxuplcornerp "," YYuplcornerp))
;-----------------------------
;calculations:
;-----------------------------
;cage dia
;---------
(setq cagedia (- piledia (* 2 cover)))
;-------------------------------------
;Lower right corner of pile
;---------------------------
(setq xlorcornerp (+ xuplcornerp piledia));x value of lower right corner point
(setq ylorcornerp (- yuplcornerp pilelen));y value of lower right corner point
(setq xxlorcornerp (rtos xlorcornerp 2 3));convert to string
(setq yylorcornerp (rtos ylorcornerp 2 3));convert to string
(setq lorcornerp (strcat xxlorcornerp "," yylorcornerp))
;------------------ REBARS ----------------------
;top point of rebar
;------------------
(setq xtoprbar (+ Xuplcornerp cover)); x of top point of rebar string
(setq ytoprbar (+ Yuplcornerp devlen)); y of top point of rebar string
(setq xxtoprbar (rtos xtoprbar 2 3))
(setq yytoprbar (rtos ytoprbar 2 3))
(setq toprbar (strcat xxtoprbar "," yytoprbar))
;-----------------------------------------------------
;bottom point of rebar
;------------------
(setq xbotrbar xtoprbar)
(setq ybotrbar (- Yuplcornerp (- pilelen 100)))
(setq xxbotrbar (rtos xbotrbar 2 3))
(setq yybotrbar (rtos ybotrbar 2 3))
(setq botrbar (strcat xxbotrbar "," yybotrbar))
;-----------------------------------------------------
;Other rebars
;-------------
;center bar
;-----------
(setq xcp X)
(setq xxcp (rtos xcp 2 3))
(setq ycp ybotrbar)
(setq yycp (rtos ycp 2 3))
(setq cp (strcat xxcp "," yycp))
;--------------------------------
;center left
;-----------
(setq xcpl (+ Xuplcornerp (/ piledia 4.5)))
(setq xxcpl (rtos xcpl 2 3))
(setq ycpl ybotrbar)
(setq yycpl (rtos ycpl 2 3))
(setq cpl (strcat xxcpl "," yycpl))
;--------------------------------
;center right
;-----------
(setq xcpr (- Xlorcornerp (/ piledia 4.5)))
(setq xxcpr (rtos xcpr 2 3))
(setq ycpr ybotrbar)
(setq yycpr (rtos ycpr 2 3))
(setq cpr (strcat xxcpr "," yycpr))
;--------------------------------
;mirror bar
;----------
(setq xmbar (- xlorcornerp cover))
(setq ymbar ybotrbar)
(setq xxmbar (rtos xmbar 2 3))
(setq yymbar (rtos ymbar 2 3))
(setq mbar (strcat xxmbar "," yymbar))
;-------------
;Drawing Pile
;-------------
(Command "-Layer" "_s" "01_Pile" "")
(command "_rectang" uplcornerp lorcornerp); draw the pile longitudinal section
;--------------
;Drawing Rebars
;--------------
(Command "-Layer" "_s" "03_Rebar" "")
(command "Line" toprbar botrbar "")
(command "copy" "last" "" botrbar cp)
(command "copy" "last" "" cp mbar)
(command "copy" "last" "" mbar cpl)
(command "copy" "last" "" cpl cpr)
;--------------
;Drawing Spiral
;--------------
(Command "-Layer" "_s" "02_Spiral" "")
;---------
;Spiral Start Point
;---------------------
(setq xspiralstart xtoprbar)
(setq yspiralstart Yuplcornerp)
(setq xxspiralstart (rtos xspiralstart 2 3))
(setq yyspiralstart (rtos yspiralstart 2 3))
(setq spiralstart (strcat xxspiralstart "," yyspiralstart))
;---------
;Spiral med Point
;---------------------
(setq xspiralmed (+ xspiralstart cagedia))
(setq yspiralmed yspiralstart)
(setq xxspiralmed (rtos xspiralmed 2 3))
(setq yyspiralmed (rtos yspiralmed 2 3))
(setq spiralmed (strcat xxspiralmed "," yyspiralmed))
;---------
;Spiral last Point
;---------------------
(setq xspirallast xspiralstart)
(setq yspirallast (- yspiralstart Spiralpitch))
(setq xxspirallast (rtos xspirallast 2 3))
(setq yyspirallast (rtos yspirallast 2 3))
(setq spirallast (strcat xxspirallast "," yyspirallast))
(command "_line" spiralstart spiralmed "")
(setq i 0)
(setq sspiralpitch (rtos spiralpitch 2 3))
(setq ssspiralpitch (strcat "0,-" sspiralpitch ",0"))
(while (< i (/ (- pilelen 100) spiralpitch))
(command "COPY" "LAST" "" "d" ssspiralpitch)
(setq i (+ i 1))
)
(command "_line" spiralmed spirallast"")
(setq i 0)
(while (< i (/ (- (- pilelen 100) spiralpitch) spiralpitch))
(command "COPY" "LAST" "" "d" ssspiralpitch)
(setq i (+ i 1))
)
;---------------------
;ANNOTATION
;---------------------
;ANNO LINE FOR REBARS L1
;---------------------
(setq xP1L1 xspiralstart)
(setq yP1L1 (+ yspiralstart (/ devlen 2)))
(setq xP2L1 (+ xlorcornerp 400))
(setq xxP1L1 (rtos xP1L1 2 3))
(setq xxP2L1 (rtos xP2L1 2 3))
(setq yyP1L1 (rtos yP1L1 2 3))
(setq P1L1 (strcat xxP1L1 "," yyP1L1))
(setq P2L1 (strcat xxP2L1 "," yyP1L1))
(Command "-Layer" "_s" "05_ANNO_LINE" "")
(command "_line" P1L1 P2L1"")
(Command "-Layer" "_s" "03_REBAR" "")
(command "_circle" P1L1 "D" "20")
(setq d1 (rtos (- xcpl xP1L1) 2 3))
(setq strd1 (strcat d1 ",0,0"))
(command "copy" "last" "" "D" strd1)
(setq d2 (rtos (- x xcpl) 2 3))
(setq strd2 (strcat d2 ",0,0"))
(command "copy" "last" "" "D" strd2)
(command "copy" "last" "" "D" strd2)
(command "copy" "last" "" "D" strd1)
;----------------------------
;ANNO LINE FOR SPIRAL L2
;---------------------
(Command "-Layer" "_s" "05_ANNO_LINE" "")
(setq xP1L2 (+ xuplcornerp (* PILEDIA 0.66)))
(setq yP1L2 (- Yuplcornerp (* 10 spiralpitch)))
(setq yP2L2 (- yP1L2 (* spiralpitch 5.5)))
(setq xP3L2 xP2L1)
(setq xxP1L2 (rtos xP1L2 2 3))
(setq yyP1L2 (rtos yP1L2 2 3))
(setq yyP2L2 (rtos yP2L2 2 3))
(setq xxP3L2 (rtos xP3L2 2 3))
(setq P1L2 (strcat xxP1L2 "," yyP1L2))
(setq P2L2 (strcat xxP1L2 "," yyP2L2))
(setq P3L2 (strcat xxP3L2 "," yyP2L2))
(command "_line" P1L2 P2L2 P3L2 "")
(Command "-Layer" "_s" "02_Spiral" "")
(command "_circle" P1L2 "D" "20")
(setq j 0)
(while (< j 5)
(command "copy" "last" "" "D" ssspiralpitch)
(setq j (+ j 1))
)
;----------------------------
;ANNO LINES FOR SECTION
;---------------------
(Command "-Layer" "_s" "05_ANNO_LINE" "")
;-----------------------
ANNO LINES FOR REBAR L3
;----------------------
(COMMAND "_LINE" PT1 "@0,250,0" "")
(SETQ X1L3 (+ (/ PILEDIA 2) 150))
(SETQ STRXL3 (STRCAT "@" (RTOS X1L3 2 3) ",0,0"))
(COMMAND "_LINE" "@0,0,0" STRXL3 "")
;---------------------
ANNO LINES FOR SPIRAL L4
;----------------------
(SETQ X1L4 (+ X (* 0.35355 CAGEDIA)))
(setq Y1L4 (+ Y (* 0.35355 Cagedia)))
(setq P1L4 (strcat (rtos x1l4 2 3) "," (rtos y1l4 2 3)))
(setq x2L4 (+ x X1L3))
(setq P2L4 (strcat (rtos x2l4 2 3) "," (rtos y1l4 2 3)))
(COMMAND "_LINE" P1L4 P2L4 "")
;---------------------
ANNO LINES FOR ring L5
;----------------------
(SETQ X1L5 (+ X (* 0.433 RINGID)))
(SETQ Y1L5 (- Y (* 0.25 RINGID)))
(SETQ X2L5 x2L4)
(SETQ P1L5 (STRCAT (RTOS X1L5 2 3) "," (RTOS Y1L5)))
(SETQ P2L5 (STRCAT (RTOS X2L5 2 3) "," (RTOS Y1L5)))
(COMMAND "_LINE" P1L5 P2L5 "")
;------------------
;ANNOTATION TEXT
;---------------
(command "style" "Anno-Pile-100" "arial.ttf" "300" "" "" "" "")
(Command "-Layer" "_s" "06_ANNO_TEXT" "")
;------------------------
;ANNO text FOR REBARS/profile T1
;------------------------
(setq xT1 (+ xlorcornerp 500))
(setq yT1 (- (+ yspiralstart (/ devlen 2)) 100))
(setq xxT1 (rtos xT1 2 3))
(setq yyT1 (rtos yT1 2 3))
(setq PPT1 (strcat xxT1 "," yyT1))
(setq T1 (strcat (rtos nrebar 2 0) " %%c " (rtos rebarDia 2 0) " mm"))
(command "text" pPT1 "" T1 "")
;--------------------------------
;ANNO text FOR SPIRAL/profile T2
;--------------------------------
(setq xT2 (+ xlorcornerp 500))
(setq yT2 (- yP2L2 100))
(setq xxT2 (rtos xT2 2 3))
(setq yyT2 (rtos yT2 2 3))
(setq PpT2 (strcat xxT2 "," yyT2))
(setq T2 (strcat "%%c " (rtos spiraldia 2 0) " @ "(rtos spiralpitch 2 0) " mm"))
(command "text" pPT2 "" T2 "")
;--------------------------------
;ANNO text FOR profile T7
;--------------------------------
(SETQ XT7 (- X 2100))
(SETQ YT7 (- ylorcornerp 1000))
(SETQ PPT7 (STRCAT (RTOS XT7 2 3) "," (RTOS YT7 2 3)))
(command "text" PPT7 "" "PILE PROFILE - 1:100" "")
;--------------------------------
;ANNO text FOR REBARS/SECTION T3
;--------------------------------
(command "style" "Anno-Pile-10" "arial.ttf" "30" "" "" "" "")
(SETQ XT3 (+ (+ X X1L3) 15))
(SETQ YT3 (- (+ (+ y (/ spiralid 2)) 250) 10))
(SETQ PPT3 (STRCAT (RTOS XT3 2 3) "," (RTOS YT3 2 3)))
(command "text" PPT3 "" T1 "")
;-----------------------------------------------------------
;ANNO text FOR REBARS/SECTION T4
;--------------------------------
(SETQ XT4 XT3)
(SETQ YT4 (- Y1L4 15))
(SETQ PPT4 (STRCAT (RTOS XT4 2 3) "," (RTOS YT4 2 3)))
(command "text" PPT4 "" T2 "")
;-----------------------------------------------------------
;ANNO text FOR RING/SECTION T5
;--------------------------------
(SETQ XT5 (+ X2L5 15))
(SETQ YT5 (- Y1L5 15))
(SETQ PPT5 (STRCAT (RTOS XT5 2 3) "," (RTOS YT5 2 3)))
(setq T5 (strcat "%%c " (rtos RINGdia 2 0) " @ "(rtos RINGpitch 2 0) " mm"))
(command "text" PPT5 "" T5 "")
;----------------------------------------------------------------------------
;ANNO text FOR SECTION T6
;--------------------------------
(SETQ XT6 (- X 188.20))
(SETQ YT6 (- Y (+ 250 (/ PILEDIA 2))))
(SETQ PPT6 (STRCAT (RTOS XT6 2 3) "," (RTOS YT6 2 3)))
(command "text" PPT6 "" "PILE SECTION - 1:10" "")
;--------------------------------
; turn on object snap
(setvar "OSMODE" (boole 6 (getvar "OSMODE") 16384))
(Command "-Layer" "_s" "0" "")
(Command "zoom" "E")
(princ)
);defun
页:
[1]