How to make excel vba crash proof?

elimgo

New Member
Joined
Sep 26, 2016
Messages
3
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 :):)

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! ***|;
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

Forum statistics

Threads
1,147,517
Messages
5,741,629
Members
423,674
Latest member
Charles2dodo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top