Hi all,
I have vba to copy selection and paste it after concatenated with some specific string into a notepad and then save it. And then it will open autocad and write a command then run my lisp to plot it into the autocad drawing.
It’s run the way I want it. However it will occasionally crash the excel. The excel windows will close itself and then opened again in recovered mode. I’m not sure as to what caused the crash. Can you guys please suggest me a method to analyse what causing the crash and how to fix it?
I attach my vba and my lisp
Thank you very much
I have vba to copy selection and paste it after concatenated with some specific string into a notepad and then save it. And then it will open autocad and write a command then run my lisp to plot it into the autocad drawing.
It’s run the way I want it. However it will occasionally crash the excel. The excel windows will close itself and then opened again in recovered mode. I’m not sure as to what caused the crash. Can you guys please suggest me a method to analyse what causing the crash and how to fix it?
I attach my vba and my lisp
Thank you very much
Code:
'allows access to autocad
Public acadApp As Object
Public acaddoc As Object
Sub open_Cad()
Dim warning As Integer
'ENSURES USER KNOWS OPEN DRAWING WILL BE EDITED, YES NO TO PROCEED
warning = MsgBox("Coordinates will be saved into currently opened drawing." & vbCrLf & "If no drawing is open, a blank drawing will be opened." & vbCrLf & "Would you like to continue?", vbYesNo, "Data Loss Warning")
Select Case warning
'if they select yes to proceed
Case 6
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
'If AutoCAD is not opened create a new instance and make it visible.
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0
'If there is no active drawing create a new one.
On Error Resume Next
Set acaddoc = acadApp.ActiveDocument
If acaddoc Is Nothing Then
Set acaddoc = acadApp.Documents.Add
End If
On Error GoTo 0
'Check if the active space is paper space and change it to model space if so
'If acaddoc.ActiveSpace = acPaperSpace Then
'acaddoc.ActiveSpace = acModelSpace
'End If
Case 7
Exit Sub
End Select
'acadApp.ActiveDocument.SendCommand ("wew ")
''CALL NEXT PROCEDURE TO RUN, SPECIFYING HOW MANY RECORDS HAVE BEEN SAVED
'Call Start_Drawing(int_)
End Sub
Sub Talk_CAD()
'SUB PROCEDURE, REQUIRES INPUT STRING TO RUN AND GIVES SPECIFIC COMMAND TO AUTOCAD
'acadApp.ActiveDocument.SendCommand ("-layer set AS_SURVEYED " & vbCrLf & "-color BYLAYER ")
'acadApp.ActiveDocument.SendCommand ("circle 50,50 50 ")
acadApp.ActiveDocument.SendCommand ("wew ")
End Sub
Sub concatwptocad()
'concatenate selected cells (description, easting, and northing) into wp2 format
Dim ActSheet As Worksheet
Dim SelRange As Range
Dim MyAppID, ReturnValue
Set ActSheet = ActiveSheet
Set SelRange = Selection
ActSheet.Select
SelRange.Select
Selection.Copy
Sheets.Add After:=ActSheet
Range("A1").Select
ActiveSheet.Paste
Range("D1").Select
Application.CutCopyMode = False
If Range("A2") = vbNullString Then
ActiveCell.FormulaR1C1 = "=CONCATENATE(char(34),RC[-3],char(34),char(59),RC[-2],char(59),RC[-1],char(59),""0.000"",char(59),14.1,char(59),4.1,char(59),14.1,char(59),char(34),""Arial"",char(34),char(59),""0.00"",char(59),-2.1,char(59),char(34),char(34),char(59),""0.00"",char(59),char(34),char(34),char(59),1,char(59),""0.000"",char(59),""0.000"",char(59),""0.000"",char(59),0,char(59),0.05)"
Else
ActiveCell.FormulaR1C1 = "=CONCATENATE(char(34),RC[-3],char(34),char(59),RC[-2],char(59),RC[-1],char(59),""0.000"",char(59),14.1,char(59),4.1,char(59),14.1,char(59),char(34),""Arial"",char(34),char(59),""0.00"",char(59),-2.1,char(59),char(34),char(34),char(59),""0.00"",char(59),char(34),char(34),char(59),1,char(59),""0.000"",char(59),""0.000"",char(59),""0.000"",char(59),0,char(59),0.05)"
Range("D1").Select
Selection.AutoFill Destination:=Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row)
End If
With Application
If Range("A2") = vbNullString Then
Range("D1").Select
Selection.Copy
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End If
Call Copytonotepad
End With
Call delsh
ActSheet.Activate
Call open_Cad
Call Talk_CAD
End Sub
Private Sub Copytonotepad()
Dim f As Integer, c As Range
f = FreeFile
Open "L:\Plot to CAD\XLtoCAD.wp2" For Output As #f
For Each c In Selection
Print #f, Replace(c.Value, vbLf, vbCrLf)
Next c
Close #f
End Sub
Code:
;;; This is the AutoLISP source file for
;;; ============
;;; POINTSIN.LSP
;;; ============
;;;
;;; Changelog by Agung Hutomo
;;; 1.Delete ALERT
;;; 2.Edit Tagnames so it will only show Desc ("TAGNAMES" "NORTH" "EAST" "DESC")
;;; 3. Added (command "zoom" "e") on 23-12-2015 at the end of PI:POINTSIN
;;; 4. Added (setvar "PDMODE" 3) to change point style to be X and (setvar "PDSIZE" 1) to make point size smaller so it would look nice and tidy on screen : on 24-12-2015
;;; 5. Added (setq INSUTS (getvar "insunits")) in the POINTSIN defun to set the insertion unit to 0 (unitless) and then back to the previous unit : on 28-12-2015
;;; 6. Added (setq SNAPMOD (getvar "osmode")) in the POINTSIN defun to set the snap mode to 0 and then back to the previous unit so that the points are inputted correctly and not get snapped to the closest object : on 28-12-2015
;;; 7. Added PI:DWGSETTING to for above setting to make thing tidy
;;; 8. Removed PI:GETDNPATH to set X:\Waypoint as the default folder to select files
;;; 9. Added overkill command (from lee mac) to delete redundant/overlapping objects. It is useful if you have new waypoints added to wp2 and you want to ;;; append it to the drawing.
;;;
;;;
(DEFUN
PI:GETPOINTFORMAT ()
;; This function defines the rules for using file field values for point block
;; coordinates (in the XYZNAMES list)
;; and attributes (in the TAGNAMES list).
;; Caution: The file format definitions in (PI:GETFILEFORMAT) use these same names to describe
;; the order of fields in the input file formats.
;; So you have to change both this function and that one when you change the attributes in POINT.DWG
;; ========================================================================
;; The XYZNAMES list names the file fields used for x, y, and z insertion point coordinates
;; They can have any names, but if you want to put them into an attribute of the block,
;; their names must match the attribute tag, which is given next in the attributes list.
;; If you don't want an insertion coordinate (like elevation/z) to come from the file,
;; just use nil, and a 0.0 value will be used.
;; '("XYZNAMES" xname yname zname)
;;(PROMPT "\nOption to fill in NORTH and EAST attributes is not active. Search this text in the source code to change behavior.")
;; Examples:
'(
;; This line tells POINTSIN to put all points (not 2D blocks) at their correct elevation.
("XYZNAMES" "EAST" "NORTH" "ELEV")
;; This line tells POINTSIN to put all points (not 2D blocks) at 0 elevation
;; '("XYZNAMES" "EAST" "NORTH" nil)
;; ========================================================================
;; The DESCNAME list names the point description (for use in constructing description-specific layer names)
;; If you don't have a description attribute and aren't using description-specific layer names, this is ignored. Just leave it alone.
("DESCNAME" . "DESC")
;; ========================================================================
;; The TAGNAMES list tells POINTSIN which block attribute tags need to receive the data in the file fields.
;; The order of the attribute fields in the list doesn't matter.
;; If any of the attributes are to receive coordinate values (x, y, or z),
;; the coordinate names in the XYZNAMES list must also match the attribute tag.
;; Examples:
;; This list tells POINTSIN to fill in the "POINT", "DESC", and "ELEV" attributes of each block insertion.
;;("TAGNAMES" "POINT" "DESC" "ELEV")
;; This list tells POINTSIN to fill in the "NORTH", "EAST", "POINT", "DESC", and "ELEV" attributes of each block insertion.
("TAGNAMES" "DESC")
)
;; ========================================================================
)
(DEFUN
PI:GETBLOCKLAYERFORMAT (POINTFORMAT / LAYERFORMATSTRING)
;; Set up the point block layer scheme.
;; 1. If you want each block to go on a layer whose name includes the point description,
;; use the code "/d" where you want the point description included (NCS/AIA/US example on next line).
;; (SETQ LAYERFORMATSTRING '("V-NODE-/d" "cyan"))(PROMPT "\nBlock layer names by description is activated. All descriptions must be legal layer names. Search this text in the source code to deactivate.")
;; 2. If you want all point blocks to be put on the same layer, take out the /d.
(SETQ LAYERFORMATSTRING '("DESCRIPTION" "magenta"))(PROMPT "\nOption to put all point blocks on same layer is active. Search this text in the source code to change behavior.")
;; 3. If you want all point blocks to be put on the current layer, comment out both lines above as well as the following line.
(PI:LAYERPARSE LAYERFORMATSTRING)
)
(DEFUN
PI:GETNODELAYERFORMAT (POINTFORMAT / LAYERFORMATSTRING)
;; Set up the point node layer scheme.
;; 1. If you want each node to go on a layer whose name includes the point description,
;; use the code "/d" where you want the point description included (NCS/AIA/US example on next line).
;; (SETQ LAYERFORMATSTRING '("POINT-/d" "yellow"))(PROMPT "\nNode layer names by description is activated. All descriptions must be legal layer names. Search this text in the source code to deactivate.")
;; 2. If you want all point nodes to be put on the same layer, take out the /d.
(SETQ LAYERFORMATSTRING '("POINT" "magenta"))
;; 3. If you want all point blocks to be put on the current layer, comment out both lines above as well as the following line.
(PI:LAYERPARSE LAYERFORMATSTRING)
)
(DEFUN C:wew ()
(PI:DWGSETTING)
(PI:POINTSIN)
(PI:DWGSETTINGEND)
(PI:KILL)
(graphscr)
)
(DEFUN PI:DWGSETTING ()
(setq INSUTS (getvar "insunits")) ;added by me
(setvar "insunits" 0) ;added by me
(setq ANGDIRECTION (getvar "angdir")) ;added by me
(setvar "angdir" 1) ;added by me
(setq ANGBAS (getvar "angbase")) ; check the base angle of the drawing
(setvar "angbase" 1.5708) ; set base angle to north
(setq SNAPMOD (getvar "osmode")) ;added by me
(setvar "osmode" 0) ;added by me
(setvar "PDMODE" 3) ;added by me
(setvar "PDSIZE" 1) ;added by me
)
(DEFUN PI:DWGSETTINGEND ()
(setvar "insunits" INSUTS) ;added by me
(setvar "osmode" SNAPMOD) ;added by me
(setvar "angbase" ANGBAS)
(setvar "angdir" ANGDIRECTION)
(setvar "clayer" "0")
)
(DEFUN
PI:POINTSIN (/ DMTXT 3DPLAYERHASDESCRIPTION FILEFORMAT FNAME
NODELAYERFORMAT PBLAYERHASDESCRIPTION
POINTBLOCKLAYERFORMAT POINTFORMAT POINTSLIST
)
(PI:ERRORTRAP)
(SETQ POINTFORMAT (PI:GETPOINTFORMAT))
(SETQ FILEFORMAT (LIST(LIST "DESC" "EAST" "NORTH" "ELEV" "POINT") ";" ":,`#,;,'"))
(SETQ FNAME '"L:/Plot to CAD/XLtoCAD.wp2")
(SETQ POINTSLIST (PI:GETPOINTSLIST FNAME FILEFORMAT POINTFORMAT))
;; Insert point blocks. Comment out the following line if you don't want point blocks.
(PI:INSERTPOINTBLOCKS POINTSLIST POINTFORMAT)
;; Insert 3d points. Comment out the following line if you don't want 3d points.
(PI:INSERT3DPOINTS POINTSLIST POINTFORMAT)(PROMPT "\nOption to insert AutoCAD Point objects is activated. Search this text in the source code to deactivate.")
(PI:ERRORRESTORE)
(command "zoom" "e") ;added by me
(princ) ;added by me
)
;; Command for a user to insert points into a drawing manually.
(DEFUN C:INSPT () (PI:USERINSERTPOINT))
(DEFUN
PI:USERINSERTPOINT (/
INSPT POINTBLOCKLAYERFORMAT POINTFORMAT POINTLIST PTDESC PTDESC-DEFAULT PTELEV PTELEV-DEFAULT PTNUM PTNUM-DEFAULT)
(SETQ POINTFORMAT (PI:GETPOINTFORMAT))
(SETQ POINTBLOCKLAYERFORMAT (PI:GETBLOCKLAYERFORMAT POINTFORMAT))
(SETQ INSPT (GETPOINT "\nInsertion Point : "))
;; Get point number
(SETQ PTNUM-DEFAULT (1+ (PI:GETVAR "number")))
(SETQ
PTNUM
(GETINT
(STRCAT "\nNode number <" (ITOA PTNUM-DEFAULT) ">: ")
)
)
(IF (NOT PTNUM)
(SETQ PTNUM PTNUM-DEFAULT)
)
(PI:SETVAR "number" PTNUM)
;; Get point description
(SETQ PTDESC-DEFAULT (PI:GETVAR "description"))
(SETQ
PTDESC
(GETSTRING (STRCAT "\nDescription <" PTDESC-DEFAULT ">: "))
)
(IF (NOT PTDESC)
(SETQ PTDESC PTDESC-DEFAULT)
)
(PI:SETVAR "description" PTDESC)
;; Get point elevation and store as a string
(SETQ PTELEV-DEFAULT (RTOS (CADDR INSPT) 2))
(SETQ PTELEV (GETREAL (STRCAT "\nElevation <" PTELEV-DEFAULT ">: ")))
(IF (NOT PTELEV)
(SETQ PTELEV PTELEV-DEFAULT)
(SETQ PTELEV (RTOS PTELEV 2))
)
(PI:SETVAR "elevation" PTELEV)
;; Insert a point block
;; The format of pointlist is defined in GETPOINTSLIST
(SETQ
POINTLIST
(LIST
;; '(x y z)
(LIST (CAR INSPT) (CADR INSPT) 0.0)
;;North string
(RTOS (CADR INSPT) 2 2)
;;East string
(RTOS (CAR INSPT) 2 2)
(ITOA PTNUM)
PTDESC
PTELEV
)
)
(PI:INSERTPOINTBLOCK
POINTLIST
POINTFORMAT
POINTBLOCKLAYERFORMAT
)
)
;; Get a global setting for the current session
;; A common standard for global variables is encasement in *asterisks*
(DEFUN
PI:GETVAR (VAR-NAME / PI:DEFAULTS)
(SETQ
PI:DEFAULTS
'(("number" . 0)
("elevation" . "0.00")
("description" . "")
)
)
;;If the settings don't exist, create them.
;;This statement is our official definition of our settings and defaults
(IF (NOT *PI:SETTINGS*)
(SETQ *PI:SETTINGS* PI:DEFAULTS)
)
;; Now that we know the settings exist, return the requested setting's current value or an error message.
(COND
((CDR (ASSOC VAR-NAME *PI:SETTINGS*)))
((CDR (ASSOC VAR-NAME PI:DEFAULTS)))
(T
(ALERT
(PRINC
(STRCAT
"\n\""
VAR-NAME
"\" isn't a known setting for the points application."
)
)
)
""
)
)
)
;; Set a global setting for the current session
(DEFUN
PI:SETVAR (VAR-NAME VAR-VAL)
;; Populate the settings list so it's complete and we know we are not setting an unknown (maverick) setting.
(PI:GETVAR VAR-NAME)
;; Put the requested value in the settings list
(SETQ
*PI:SETTINGS*
(SUBST
(CONS VAR-NAME VAR-VAL)
(ASSOC VAR-NAME *PI:SETTINGS*)
*PI:SETTINGS*
)
)
)
(DEFUN
PI:ERRORTRAP ()
(SETQ
*PI:OLDERROR* *ERROR*
*ERROR* *PI:ERROR*
)
)
(DEFUN
*PI:ERROR* (MESSAGE)
(COND
((/= MESSAGE "Function cancelled")
(PRINC (STRCAT "\nTrapped error: " MESSAGE))
)
)
(COMMAND)
(IF (= (TYPE F1) (QUOTE FILE))
(SETQ F1 (CLOSE F1))
)
(IF *PI:OLDERR*
(SETQ
*ERROR* *PI:OLDERR*
*PI:OLDERR* NIL
)
)
(PRINC)
)
(DEFUN
PI:ERRORRESTORE ()
(SETQ
F1 NIL
*ERROR* *PI:OLDERR*
*PI:OLDERR* NIL
)
)
(DEFUN
PI:GETFILEFORMAT (/ STDCOMMENT OPTION)
(TEXTPAGE)
;; Menu
;; Show the various formats
(PROMPT
"\nSelect a file format:
1. EIVA (Wp2 format)
2. PNEZD (comma delimited)
3. PNEZD (tab delimited)
4. PNEZD (white-space delimited)
5. PENZD (comma delimited)
6. PENZD (tab delimited)
7. PENZD (white-space delimited)
" )
;;Set the allowed inputs and get one from user.
(INITGET "1 2 3 4 5 6 7")
(SETQ OPTION (GETKWORD "\n\n1/2/3/4/5/6/7: "))
;; Define the various formats by calling out the fields in order,
;; then specifying the field delimiter and the comment delimiter(s)
;; The field delimiter is a one-character string.
;; The comment delimiter is an AutoCAD style wild card string
(SETQ STDCOMMENT ":,`#,;,'")
(COND
((= OPTION "1")
(LIST
(LIST "DESC" "EAST" "NORTH" "ELEV" "POINT")
";"
STDCOMMENT
)
)
((= OPTION "2")
(LIST
(LIST "POINT" "NORTH" "EAST" "ELEV" "DESC")
","
STDCOMMENT
)
)
((= OPTION "3")
(LIST
(LIST "POINT" "NORTH" "EAST" "ELEV" "DESC")
"\t"
STDCOMMENT
)
)
((= OPTION "4")
(LIST
(LIST "POINT" "NORTH" "EAST" "ELEV" "DESC")
"W"
STDCOMMENT
)
)
((= OPTION "5")
(LIST
(LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
","
STDCOMMENT
)
)
((= OPTION "6")
(LIST
(LIST "POINT" "EAST" "NORTH" "ELEV" "DESC")
"\t"
STDCOMMENT
)
)
((= OPTION "7")
(LIST
(LIST "POINT" "NORTH" "EAST" "ELEV" "DESC")
"W"
STDCOMMENT
)
)
)
)
;;; PI:LAYERPARSE
;;; Returns a LAYERLIST with the name (first element) parsed into
;;; part before /d and part after /d. If no /d, returns only one element.
(DEFUN
PI:LAYERPARSE
(LAYERLIST / NAMELIST NAMESTRING GROWINGSTRING COUNTER)
(SETQ
NAMESTRING
(CAR LAYERLIST)
GROWINGSTRING ""
COUNTER 0
)
(WHILE (< COUNTER (STRLEN NAMESTRING))
(SETQ COUNTER (1+ COUNTER))
(IF (= (STRCASE (SUBSTR NAMESTRING COUNTER 2)) "/D")
(SETQ
NAMELIST
(CONS GROWINGSTRING NAMELIST)
GROWINGSTRING ""
COUNTER
(1+ COUNTER)
)
(SETQ
GROWINGSTRING
(STRCAT
GROWINGSTRING
(SUBSTR NAMESTRING COUNTER 1)
)
)
)
)
(CONS
(REVERSE (CONS GROWINGSTRING NAMELIST))
(CDR LAYERLIST)
)
)
;;; PI:MAKELAYER
;;; Sets current layer. Makes layer if required.
;;; The format of layerlist is '(([NAME BEFORE DESC] [NAME AFTER DESC OR NIL IF NOT USING DESC]) COLOR)
;;; The format of pointlist is '((XEAST YNORTH) POINT DESC ELEV)
(DEFUN
PI:MAKELAYER (LAYERFORMAT POINTLIST POINTFORMAT / DWGLAYER LAYERNAME
NAMELIST LAYERCOLOR
)
(COND
(LAYERFORMAT
(SETQ
NAMELIST
(CAR LAYERFORMAT)
LAYERNAME
(STRCAT
(CAR NAMELIST)
(IF (CADR NAMELIST)
(STRCAT
(NTH
;; Calculate the position of the description in the pointlist
(LENGTH
(MEMBER
;; Name of point description
(CDR (ASSOC "DESCNAME" POINTFORMAT))
(REVERSE
(CDR (ASSOC "TAGNAMES" POINTFORMAT))
)
)
)
POINTLIST
)
(CADR NAMELIST)
)
""
)
)
LAYERCOLOR
(CADR LAYERFORMAT)
)
(COND
((AND
;; Layer exists in drawing
(SETQ DWGLAYER (TBLSEARCH "LAYER" LAYERNAME))
;; Layer is already proper color
(= (CDR (ASSOC 62 DWGLAYER)) (CADR LAYERFORMAT))
;; Layer isn't frozen
(/= 1 (LOGAND (CDR (ASSOC 70 DWGLAYER)) 1))
)
;; Set that layer current without using command interpreter
(SETVAR "CLAYER" LAYERNAME)
)
(T
;; Else make layer using (command)
(COMMAND
"._layer" "_thaw" LAYERNAME "_make" LAYERNAME "_on" ""
"_color" LAYERCOLOR "" ""
)
)
)
)
)
)
;; Format of list for each point is:
;; The first member is the point list (list x y z)
;; The other members are attribute value strings as defined by the GETPOINTFORMAT function
(DEFUN
PI:GETPOINTSLIST (FNAME FILEFORMAT POINTFORMAT / ATTVALUES COORD
FIELDNAME I INSPOINT POINTLIST POINTSLIST RDLIN
)
(SETQ F1 (OPEN FNAME "r"))
(WHILE (SETQ RDLIN (READ-LINE F1))
(SETQ
I 0
POINTLIST NIL
)
;;Create a point list for the line if it's not a comment.
(COND
((NOT (WCMATCH (SUBSTR RDLIN 1 1) (CADDR FILEFORMAT)))
;; Read and label the fields in the order specified by FILEFORMAT
(FOREACH
FIELD (CAR FILEFORMAT)
(SETQ I (1+ I))
(SETQ
POINTLIST
(CONS
(CONS
FIELD
(PI:RDFLD I RDLIN (CADR FILEFORMAT) 1)
)
POINTLIST
)
)
)
;; Strip the labels from the fields and put them into internal order
;; specified by POINTFORMAT.
(SETQ
;; Get insertion coordinates
INSPOINT
(MAPCAR
'(LAMBDA (FIELDNAME / COORD)
(COND
((AND
;; If the coordinate is defined
(SETQ
COORD
(CDR (ASSOC FIELDNAME POINTLIST))
)
;; and if the file gave a value
(SETQ COORD (DISTOF COORD))
)
;; use it.
COORD
)
;; Use 0.0 for any missing or undefined coordinates.
(0.0)
)
)
(CDR (ASSOC "XYZNAMES" POINTFORMAT))
)
;; Get attribute values.
ATTVALUES
(MAPCAR
'(LAMBDA (FIELDNAME / COORD)
(CDR (ASSOC FIELDNAME POINTLIST))
)
(CDR (ASSOC "TAGNAMES" POINTFORMAT))
)
)
;; Add point to list.
(SETQ POINTSLIST (CONS (CONS INSPOINT ATTVALUES) POINTSLIST))
)
)
)
(SETQ F1 (CLOSE F1))
POINTSLIST
)
(DEFUN
PI:INSERTPOINTBLOCKS
(POINTSLIST POINTFORMAT / AROLD POINTBLOCKLAYERFORMAT)
(SETQ POINTBLOCKLAYERFORMAT (PI:GETBLOCKLAYERFORMAT POINTFORMAT))
(COMMAND "._undo" "_group")
(SETQ AROLD (GETVAR "attreq"))
(SETVAR "attreq" 0)
;;Insert a Softdesk style block
(FOREACH
;; The format of pointlist is defined in GETPOINTSLIST
POINTLIST POINTSLIST
(PI:INSERTPOINTBLOCK
POINTLIST
POINTFORMAT
POINTBLOCKLAYERFORMAT
)
)
(SETVAR "attreq" AROLD)
(COMMAND "._undo" "_end")
)
(DEFUN
PI:INSERTPOINTBLOCK (POINTLIST POINTFORMAT POINTBLOCKLAYERFORMAT / AT
AV EL EN ET N NEWVALUE SHORTLIST kordx kordy koord
)
(PI:MAKELAYER POINTBLOCKLAYERFORMAT POINTLIST POINTFORMAT)
(setq kordx (+ 1.5 (car (reverse (cdr (reverse (car pointlist)))))))
(setq kordy (cdr (reverse (cdr (reverse (car pointlist))))))
(setq koord (cons kordx kordy))
(command
"-text"
"j"
"ml"
koord
"1.5"
"90"
(nth 0 (cdr pointlist))
)
(SETQ EN (ENTLAST))
;;Fill in attributes
(WHILE (AND
(SETQ EN (ENTNEXT EN))
(/= "SEQEND"
(SETQ ET (CDR (ASSOC 0 (SETQ EL (ENTGET EN)))))
) ;_ end of /=
) ;_ end of and
(COND
((= ET "ATTRIB")
(SETQ
AT (CDR (ASSOC 2 EL))
AV (CDR (ASSOC 1 EL))
) ;_ end of setq
(COND
((SETQ
SHORTLIST
(MEMBER
AT
(REVERSE (CDR (ASSOC "TAGNAMES" POINTFORMAT)))
)
)
(SETQ
N (LENGTH SHORTLIST)
NEWVALUE (NTH N POINTLIST)
)
;; Round elevation attribute to current drawing LUPREC value
;;(IF
;; (= AT "ELEV")
;; (SETQ NEWVALUE (RTOS (ATOF NEWVALUE) 2))
;;)
(ENTMOD
(SUBST (CONS 1 NEWVALUE) (ASSOC 1 EL) EL) ;_ end of SUBST
) ;_ end of ENTMOD
)
) ;_ end of cond
(ENTUPD EN)
)
) ;_ end of cond
) ;_ end of while
)
(DEFUN
PI:INSERT3DPOINTS
(POINTSLIST POINTFORMAT / NODELAYERFORMAT POINTLIST)
(SETQ NODELAYERFORMAT (PI:GETNODELAYERFORMAT POINTFORMAT))
(COMMAND "._undo" "_group")
(FOREACH
POINTLIST POINTSLIST
(PI:MAKELAYER NODELAYERFORMAT POINTLIST POINTFORMAT)
(COMMAND "._point" (CAR POINTLIST))
)
(COMMAND "._undo" "_end")
)
;;Read fields from a text string delimited by a field width or a delimiter
;;character.
;;Usage: (PI:RDFLD
;; [field number]
;; [string containing fields]
;; [uniform field width, field delimiter character, or "W" for words separated by one or more spaces]
;; [sum of options: 1 (non-numerical character field)
;; 2 (unlimited length field at end of string)
;; ]
;; )
(DEFUN
PI:RDFLD (FLDNO STRING FLDWID OPT / ISCHR ISLONG I J ATOMX CHAR
CHARPREV LITERAL FIRSTQUOTE
)
(SETQ
ISCHR
(= 1 (LOGAND 1 OPT))
ISLONG
(= 2 (LOGAND 2 OPT))
) ;_ end of setq
(COND
((= FLDWID "W")
(SETQ
I 0
J 0
ATOMX ""
CHAR " "
) ;_ end of setq
(WHILE (AND (/= I FLDNO) (< J (STRLEN STRING))) ;_ end of and
;;Save previous character unless it was literal
(SETQ
CHARPREV
(IF LITERAL
""
CHAR
) ;_ end of IF
;;Get new character
CHAR
(SUBSTR STRING (SETQ J (1+ J)) 1)
) ;_ end of setq
;;Find if new character is literal or a doublequote
(COND
((= CHAR (SUBSTR STRING J 1) "\"")
(IF (NOT LITERAL)
(SETQ LITERAL T)
(SETQ LITERAL NIL)
) ;_ end of if
(IF (NOT FIRSTQUOTE)
(SETQ FIRSTQUOTE T)
(SETQ FIRSTQUOTE NIL)
) ;_ end of if
)
(T (SETQ FIRSTQUOTE NIL))
) ;_ end of cond
(IF (AND
(WCMATCH CHARPREV " ,\t")
(NOT (WCMATCH CHAR " ,\t,\n"))
)
(SETQ I (1+ I))
) ;_ end of if
) ;_ end of while
(WHILE (AND
(OR ISLONG LITERAL (NOT (WCMATCH CHAR " ,\t,\n"))) ;_ end of or
(<= J (STRLEN STRING))
) ;_ end of and
(IF (NOT FIRSTQUOTE)
(SETQ ATOMX (STRCAT ATOMX CHAR))
) ;_ end of if
(SETQ CHAR (SUBSTR STRING (SETQ J (1+ J)) 1))
(COND
((= CHAR "\"")
(IF (NOT LITERAL)
(SETQ LITERAL T)
(SETQ LITERAL NIL)
) ;_ end of if
(IF (NOT FIRSTQUOTE)
(SETQ FIRSTQUOTE T)
(SETQ FIRSTQUOTE NIL)
) ;_ end of if
)
(T (SETQ FIRSTQUOTE NIL))
) ;_ end of cond
) ;_ end of while
)
((= (TYPE FLDWID) 'STR)
(SETQ
I 1
J 0
ATOMX ""
) ;_ end of setq
(WHILE (AND
(/= I FLDNO)
(IF (> (SETQ J (1+ J)) 1000)
(PROMPT (STRCAT "\nFields or delimiters missing in this line?" STRING))
T
) ;_ end of if
) ;_ end of and
(IF (= (SETQ CHAR (SUBSTR STRING J 1)) "\"")
(IF (NOT LITERAL)
(SETQ LITERAL T)
(SETQ LITERAL NIL)
) ;_ end of if
) ;_ end of if
(IF (AND (NOT LITERAL) (= (SUBSTR STRING J 1) FLDWID))
(SETQ I (1+ I))
) ;_ end of if
) ;_ end of while
(WHILE
(AND
(OR (/= (SETQ CHAR (SUBSTR STRING (SETQ J (1+ J)) 1)) FLDWID)
LITERAL
) ;_ end of or
(<= J (STRLEN STRING))
) ;_ end of and
(COND
((= CHAR "\"")
(IF (NOT LITERAL)
(SETQ LITERAL T)
(SETQ LITERAL NIL)
) ;_ end of if
(IF (NOT FIRSTQUOTE)
(SETQ FIRSTQUOTE T)
(SETQ FIRSTQUOTE NIL)
) ;_ end of if
)
(T (SETQ FIRSTQUOTE NIL))
) ;_ end of cond
(IF (NOT FIRSTQUOTE)
(SETQ ATOMX (STRCAT ATOMX CHAR))
) ;_ end of if
) ;_ end of while
(IF (AND ISCHR (NOT ISLONG))
(SETQ ATOMX (PI:RDFLD-UNPAD ATOMX))
)
)
(T
(SETQ
ATOMX
(SUBSTR
STRING
(1+ (* (1- FLDNO) FLDWID))
(IF ISLONG
1000
FLDWID
) ;_ end of if
) ;_ end of substr
) ;_ end of setq
(IF (AND ISCHR (NOT ISLONG))
(SETQ ATOMX (PI:RDFLD-UNPAD ATOMX))
)
)
) ;_ end of cond
(SETQ
ATOMX
(IF ISCHR
ATOMX
(DISTOF ATOMX)
) ;_ end of if
) ;_ end of setq
) ;_ end of defun
;;Strip white space from beginning and end of a string
(DEFUN
PI:RDFLD-UNPAD (STR)
(WHILE (WCMATCH (SUBSTR STR 1 1) " ,\t")
(SETQ STR (SUBSTR STR 2))
) ;_ end of while
(IF (/= STR "")
(WHILE (WCMATCH (SUBSTR STR (STRLEN STR)) " ,\t")
(SETQ STR (SUBSTR STR 1 (1- (STRLEN STR))))
) ;_ end of while
)
STR
)
(defun PI:KILL ( / ss )
(acet-error-init (list '("cmdecho" 0) T))
(setq ss (ssget "_X"))
(load "overkill.lsp")
(acet-overkill2
(list ss
(max (acet-overkill-fuz-get) 1.0e-08)
(acet-overkill-ignore-get)
(acet-overkill-no-plines-get)
(acet-overkill-no-partial-get)
(acet-overkill-no-endtoend-get)
)
)
)
(acet-error-restore)
(princ)
(graphscr)
(princ (strcat "\nLoaded POINTSIN.LSP version " *PI:VERSION* "."))
;|«Visual LISP© Format Options»
(72 2 40 2 nil "end of " 60 2 2 2 1 nil nil nil T)
(princ)
;*** DO NOT add text below the comment! ***|;
