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

---

Well this set of files "CHOP" were created 25 yeas ago and got them to work with little effort.
I've been trying to keep them as original as possible.

Now I am ready to modify them to make them better.

I guess CLIPD is obsolete where paper space viewports would make more sense in modern AutoCAD.

OK, I think I'll add insertion of TITLEA.DWG and NA.DWG to CHOP.LSP, if they don't exist, and running TBLK.LSP after.
I need to make the programs work with all units and not just engineering.
Creating layouts with CBV.LSP seems like a good idea.
Also maybe creating layers for all borders when CHOP.LSP is used.

Please comment with your suggestions.

So I've been working on CBV.LSP.
I can't figure out how to change the paper space sheet size.
Below the remed out works in 2021 and not 2020.

Code:

---


(DEFUN C:CBV ()
(PROMPT "\n*CREATE BORDER VIEWS*")
(SETQ BSS (SSGET '((2 . "TITLEB"))))
(SETQ BSSL (SSLENGTH BSS))
(SETQ CT (- BSSL 1))
(SETQ LP 1)
(WHILE LP
(SETQ BN (SSNAME BSS CT))
(SETQ BNL (ENTGET BN))
(SETQ BIP (CDR (ASSOC 10 BNL)))
(SETQ BS (CDR (ASSOC 41 BNL)))
(SETQ BEN BN)
(SETQ LP2 1)
(WHILE LP2
(SETQ BEN (ENTNEXT BEN))
(SETQ BENL (ENTGET BEN))
(SETQ BET (CDR (ASSOC 0 BENL)))
(SETQ BAT (CDR (ASSOC 2 BENL)))
(IF (AND (= BET "ATTRIB") (= BAT "PN")) (SETQ LP2 NIL))
);END LP2
(SETQ BPN (CDR (ASSOC 1 BENL)))
(IF (OR (= BPN "") (= BPN "--")) (SETQ BPN (STRCAT "BD" (ITOA CT))) (SETQ BPN (STRCAT "PG" BPN)))
(SETQ PT1 (POLAR BIP (* 0.25 PI) (* 25 BS)))
(SETQ PT2 (POLAR BIP (* 1.25 PI) (* 25 BS)))
(SETQ RA (CDR (ASSOC 50 BENL)))
(SETQ RA (/ (* RA 180) PI))
(SETQ RA (* RA -1.0))
(COMMAND "LAYOUT" "NEW" BPN)
(COMMAND "LAYOUT" "S" BPN)

;(COMMAND "-PAGESETUP" "NONE" "ARCH D (24.00 x 36.00 Inches)" "Inches" "Landscape" "NO" "LAYOUT" "1:1" "0.00,0.00" "YES" "." "YES" "NO" "NO" "NO")

(COMMAND "ERASE" "L" "")
(COMMAND "MVIEW" "F")
(COMMAND "MSPACE")
(COMMAND "DVIEW" BN "" "TW" RA "X")
(COMMAND "ZOOM" "C" BIP (* BS 25))
(COMMAND "VIEW" "W" BPN PT1 PT2)
(SETQ CT (- CT 1))
(IF (< CT 0) (SETQ LP NIL))
);END LP
(COMMAND "VIEW" "?" "*")
);END CBV

---

pi day made drag this up today :)
i can't figure out how to use CLIPD on DWG-7 in Drawing1.dwg :(

so i don't have to load alota files to test it.
it only works if the files are in the search path :)