CHOP
This set of files (attached) divides a centerline with title blocks, inserts and labels match lines, fills the border attributes, and labels the title blocks.
Then the title blocks can be clipped out and written to external drawings.
1. insert TITLEA (master border)
2. insert NA
3. run TBLK
4. run CHOP
5. run CLIPDB
this zip file contains:
CHOP.LSP - create border set
CLIPD.LSP - clip drawing to external file
CLIPDB.LSP - clipd all titleblocks to external files
LBL.LSP - label entity
LBLA.LSP - label all entities
TME.LSP - trim match edge
TBLK.LSP - read/write border attributes to file
SON.LSP - set border of numbers
WUC.LSP - write update clip
IUC.LSP - insert update clip
CBV.LSP - create border views
SBA.LSP - screen to border alignment
PATH.LSP - sets the drawing paths
(load all programs and set the blocks in the search path)
https://forums.augi.com/images/attach/jpg.gif
Code:(DEFUN C:CHOP ();/ LP BP LOP LUP SLPS SLEN SLPP SLNPP CSLNPP SLEPP NO DN DEC SLLA CL SL NO EV1 EVS SV EV2 PEP1 PEP2 UPRA FIP MARK NMSS DBO ISMN LOOP RA PRA PBM MLD MLA MLIP MLRA PIP PM JC1 JC2 JS FLTR DBN DPF NAS NAN NAR PTH OFDN TB DNT PRA MLT PRT PRT2 DWGN TBNP NMSSL IP BM STPD STPA RAR BXSI REA ATR PMA PSTPD PMA MA) (COMMAND "UNDO" "M") (SETQ DBN 0) (SETQ DBO 0) (SETQ ISMN 0) (SETQ PRA NIL) (SETQ NO NIL) (IF (= BXS NIL) (SETQ BXS 240.0)) (SETQ DPF (GETVAR "DWGPREFIX")) (SETQ CL (GETVAR "CLAYER")) (COMMAND "SETVAR" "CLAYER" "TITLE") (SETQ NAS (SSGET "X" '((2 . "NA")) )) (SETQ NAN (SSNAME NAS 0)) (SETQ NAR (/ (* (CDR (ASSOC 50 (ENTGET NAN))) 180) PI) ) (PROMPT "*CHOP*") (SETQ LP 1) (WHILE LP (SETQ BP (GETPOINT "\nPick starting point: ")) (SETQ BP (OSNAP BP "NEA")) (IF (/= BP NIL) (SETQ LP NIL) (PROMPT " POINT NOT ON STATION LINE ")) );END WHILE LP (SETQ LUP 1) (WHILE LUP (SETQ LOP 1) (WHILE LOP (SETQ SLPS (ENTSEL "\nSelect direction on center line: ")) (IF (/= SLPS NIL) (SETQ LOP NIL) (PROMPT " NO OBJECT SELECTED ")) );END WHILE LOP (SETQ SLEN (CAR SLPS)) (IF (= (CDR(ASSOC 0 (ENTGET SLEN))) "LWPOLYLINE") (SETQ LUP NIL) (PROMPT " OBJECT SELECTED NOT A POLYLINE ")) );END WHILE LUP (SETQ SLPP (CADR SLPS)) (SETQ SLNPP (OSNAP SLPP "NEA")) (COMMAND "BREAK" SLNPP "F" BP BP) (SETQ SLEN (SSNAME (SSGET SLNPP) 0)) (SETQ SLLA (ASSOC 8 (ENTGET SLEN)))(SETQ SLLA (ASSOC 8 (ENTGET SLEN))) (SETQ DN (GETINT "\nStarting Drawing# <1>: ")) (IF (= DN NIL) (SETQ DN 1)) (SETQ DEC (GETSTRING "\nStarting match line letter <A>: ")) (IF (= DEC "") (SETQ DEC 65) (SETQ DEC (ASCII DEC))) (INITGET "A D") (SETQ NO (GETKWORD "\nDescend <Ascend>: ")) (IF (= NO NIL) (SETQ NO "A")) (SETQ PTH (GETSTRING "\nDrawing Prefix <DWG->: ")) (IF (= PTH "") (SETQ PTH "DWG-")) (PROMPT "\nBorder scale <") (PRINC BXS) (PROMPT ">: ") (SETQ BXSI (GETREAL)) (IF (/= BXSI NIL) (SETQ BXS BXSI)) (SETQ SL (* BXS 2.08333)) (SETQ SLENL (ENTGET SLEN)) (SETQ EV1 (CDR(ASSOC 10 SLENL))) (SETQ EVS EV1) (SETQ SV 1) (WHILE SV (SETQ SLENL (CDR SLENL)) (SETQ EVT (ASSOC 10 SLENL)) (IF (/= EVT NIL) (SETQ EV2 (CDR EVT)) (SETQ SV NIL)) );END WHILE SV (SETQ PEP1 EV1) (SETQ PEP2 EV2) (IF (> (DISTANCE SLNPP PEP2) (DISTANCE SLNPP PEP1)) (SETQ FIP PEP1) (SETQ FIP PEP2)) ;(SETQ EV1 (ENTNEXT SLEN)) ;(SETQ EVS EV1) ;(SETQ SV 1) ;(WHILE SV ;(IF (= (CDR (ASSOC 0 (ENTGET (ENTNEXT EVS)))) "VERTEX") (PROGN (SETQ EV2 (ENTNEXT EVS)) (SETQ EVS (ENTNEXT EVS))) (SETQ SV NIL)) ;);END WHILE SV ;(SETQ PEP1 (CDR (ASSOC 10 (ENTGET EV1)))) ;(SETQ PEP2 (CDR (ASSOC 10 (ENTGET EV2)))) ;(IF (> (DISTANCE SLNPP PEP2) (DISTANCE SLNPP PEP1)) (SETQ FIP PEP1) (SETQ FIP PEP2)) ;********* ;(SETQ UPRA (ANGLE FIP SLNPP)) ;(IF (AND (< UPRA 1.5708) (> UPRA 4.71239) ) ; (SETQ CSLNPP (POLAR SLNPP (+ UPRA PI) (* 15.9375 BXS))) (SETQ CSLNPP SNLPP);PRE-FLIP MARK TEST ;);END IF UPRA ;(PRINC CSLNPP) (COMMAND "INSERT" "MARK" FIP BXS "" SLNPP) (SETQ MARK (ENTLAST)) (SETQ REA (GETVAR "REGENMODE")) (SETVAR "REGENMODE" 0) (COMMAND "MEASURE" SLNPP "B" "MARK" "Y" (* SL 12)) (SETQ NMSS (SSGET "P")) (SETQ NMSSL (SSLENGTH NMSS)) (SETQ OFDN (+ NMSSL DN)) (IF (> (DISTANCE FIP (CDR(ASSOC 10(ENTGET(ENTNEXT MARK))))) (+ (* SL 12) 1)) (PROGN (SETQ DBN (- NMSSL 1)) (SETQ DBO 1)) ) (SETQ ATR (GETVAR "ATTREQ")) (SETVAR "ATTREQ" 0) (SETQ LOOP 1) (WHILE LOOP (SETQ ELIST (ENTGET MARK)) (SETQ IP (CDR (ASSOC 10 ELIST))) (SETQ RA (/ (* 180 (CDR (ASSOC 50 ELIST)) ) PI)) (IF (AND (> RA 90) (< RA 270) ) (PROGN (SETQ RA (+ RA 180)) (SETQ STPD 1)) (SETQ STPD 0) ) (SETQ RA (- RA (* (FIX (/ RA 360)) 360))) (SETQ RAR (/ (* RA PI) 180)) (SETQ PM MARK) (SETQ MARK (SSNAME NMSS DBN)) (IF (= DBO 1) (SETQ DBN (- DBN 1)) (SETQ DBN (+ DBN 1)) ) (COMMAND "ERASE" PM "") (COMMAND "INSERT" "TITLEB" IP BXS "" RA) (SETQ TB (ENTLAST)) (SETQ APICK (CDR (ASSOC 2 (ENTGET TB)))) (COMMAND "INSERT" "DWGNO" IP BXS "" RA) (SETQ DNT (ITOA DN)) (COMMAND "ATTEDIT" "N" "N" "DWGNO" "DWGNO" "DWGNO" "DWGNO" DNT) (IF (/= PRA NIL) (PROGN (IF (AND (= PSTPD 1) (= DBO 1)) (SETQ PMA PRA) ) (IF (AND (/= PSTPD 1) (= DBO 1)) (SETQ PMA (+ PRA PI)) ) (IF (AND (= PSTPD 1) (/= DBO 1)) (SETQ PMA (+ PRA PI)) ) (IF (AND (/= PSTPD 1) (/= DBO 1)) (SETQ PMA PRA) ) (IF (AND (= STPD 1) (= DBO 1)) (SETQ MA (+ RAR PI)) ) (IF (AND (/= STPD 1) (= DBO 1)) (SETQ MA RAR) ) (IF (AND (= STPD 1) (/= DBO 1)) (SETQ MA RAR) ) (IF (AND (/= STPD 1) (/= DBO 1)) (SETQ MA (+ RAR PI)) ) (prompt "\n ") (princ pstpd) (prompt " ") (princ stpd) (prompt " ") (princ dbo) (SETQ PBM (POLAR PIP PMA (* 15.9375 BXS) )) (SETQ BM (POLAR IP MA (* 15.9375 BXS) )) (SETQ MLD (/ (DISTANCE PBM BM) 2)) (SETQ MLA (ANGLE BM PBM)) (SETQ MLIP (POLAR BM MLA MLD)) (SETQ MLRA (/ (* (- PMA (/ (- PMA (+ MA PI)) 2)) 180) PI)) (IF (AND (> (- MLRA RA) 90) (< (- MLRA RA) 270)) (SETQ MLRA (+ MLRA 180)) );edge flip correction!!! (COMMAND "INSERT" "EDGE3" MLIP BXS BXS MLRA) (SETQ MLT (CHR DEC)) (IF (AND (= NO "A") (= STPD 0)) (PROGN (SETQ PRT (ITOA (- DN 1))) (SETQ PRT2 (ITOA DN)))) (IF (AND (= NO "D") (= STPD 0)) (PROGN (SETQ PRT (ITOA (+ DN 1))) (SETQ PRT2 (ITOA DN)))) (IF (AND (= NO "A") (= STPD 1)) (PROGN (SETQ PRT2 (ITOA (- DN 1))) (SETQ PRT (ITOA DN)))) (IF (AND (= NO "D") (= STPD 1)) (PROGN (SETQ PRT2 (ITOA (+ DN 1))) (SETQ PRT (ITOA DN)))) (COMMAND "ATTEDIT" "N" "N" "EDGE3" "EDGE" "X" "X" MLT) (COMMAND "ATTEDIT" "N" "N" "EDGE3" "PRINT" "SEE DWG NO. 00" "SEE DWG NO. 00" (STRCAT "SEE DWG NO. " PRT)) (COMMAND "ATTEDIT" "N" "N" "EDGE3" "PRINT2" "SEE DWG NO. 000" "SEE DWG NO. 000" (STRCAT "SEE DWG NO. " PRT2)) ));END PROGN/IF PRA (COMMAND "ATTEDIT" "N" "N" "TITLEB" "PN" "--" "--" (ITOA DN)) (SETQ DWGN (STRCAT DPF PTH (ITOA DN))) (COMMAND "ATTEDIT" "N" "N" "TITLEB" "PATH" "XXX" "XXX" DWGN) (C:TBLK) (SETQ TBNP (POLAR IP (/ (* (+ RA 30.474) PI) 180) (* 17.5 BXS))) (COMMAND "INSERT" "NA" TBNP BXS "" NAR) (IF (= NO "D") (PROGN (SETQ DN (- DN 1)) (IF (/= PRA NIL) (SETQ DEC (- DEC 1))) ) (PROGN (SETQ DN (+ DN 1)) (IF (/= PRA NIL) (SETQ DEC (+ DEC 1)))) ) (SETQ PRA RAR) (SETQ PIP IP) (IF (= STPD 1) (SETQ PSTPD 1) (SETQ PSTPD 0)) (IF (AND (= DBO 1) (< DBN 0)) (SETQ LOOP NIL)) (IF (AND (= DBO 0) (> DBN (- NMSSL 1))) (SETQ LOOP NIL)) );END WHILE (C:SON) (SETQ JC1 (MAPCAR '+ BP '(0.01 0.01 0.0) )) (SETQ JC2 (MAPCAR '- BP '(0.01 0.01 0.0) )) (SETQ FLTR (LIST '(-4 . "<AND") SLLA '(0 . "LWPOLYLINE") '(-4 . "AND>"))) (SETQ JS (SSGET "C" JC1 JC2 FLTR)) (COMMAND "PEDIT" SLEN "J" JS "" "X") (SETVAR "ATTREQ" 1) (SETVAR "CLAYER" CL) (SETVAR "REGENMODE" REA) (PRINC) );END SM
Reply With Quote