Coordinates lisp

[dani_cs]

Hello,

I am looking for the next lisp. I need to create a plline (for example a rectangle) wherever I want inside the model. Then, the routine will ask me about the distance between coordinate crosses (x) , the plot scale (1/500 for example) and the height text. Then I will click the rectangle and finally it will create all the coordinate crosses inside the rectangle as a editable objects (block for example). I am attaching a photo as a example.

Thanks,

Best regards,

Daniel.

[Anonymous]

@dani_cs

One advice, whenever you make a post opt to post a .Dwg makes the job a lot easier.
Note: You would not be happy if we post the code photo.

[Satish_Rajdev]

Do you want something like this?

[dani_cs]

Hello Satish_Rajdev,

Oh my god, it's much better I've imagined. I saw you are the owner, aren't you? congratulations for that, it's fantastic.

Could you please share it with us?

or do you know a routine able to do that? I only need the tic marks coordinates, not the full grid.

Best regards,

Daniel.

[Satish_Rajdev]

Yes. It's my channel. The whole package is not freeware so sharing you the ADGRID part of it which you have seen in the video.

Add "Ssurvey_Chart.dcl" file in your AutoCAD program files directory in c drive.

Something like this : "C:\Program Files\Autodesk\AutoCAD 2016\Support"

Please rename "Adgrid.txt" to "Adgrid.fas" because I want unable to add that attachment here.

and after that you can upload and run "Adgrid.fas" program. Please don't forget to subscribe my channel.

[dani_cs]

Hello Satish_Rajdev,

I have just suscribed to your channel.

I followed your steps but autocad displays and error when I run the adgrid.fas. It is something like this (own traduction):

"; error: insufficient arguments"

Do you know the reason?

Best regards,

Daniel.

[pbejse]

@Anonymous wrote:

@dani_cs

One advice, whenever you make a post opt to post a .Dwg makes the job a lot easier.
Note: You would not be happy if we post the code photo.

Nice 😄

@dani_cs

Hows about posting a sample drawing for the rest of us who don't have a YouTube channel.

[dani_cs]

Hello pbejse,

I am attaching a dwg sample. I need to create a plline (for example a rectangle) wherever I want inside the model. Then, the routine will ask me about the distance between coordinate tic marks (x) , the plot scale (1/500 for example) and the height text. Then I will click the rectangle and finally it will create all the coordinate tick marks inside the rectangle as a editable objects (block for example).

best regards,

daniel

[pbejse]

Do the sample drawing you posted the result of typing these values at the user prompt?

...the distance between coordinate tic marks (x) :  10.00

... the plot scale:  1/500
.. the height text. 2.00

---

@dani_cs wrote:

Then I will click the rectangle and finally it will create all the coordinate tick marks inside the rectangle as a editable objects (block for example).

---

To show or do what? 

[Kent1Cooper]

For the crosses part, you don't say why you want them to be editable objects, but if whatever that need is could be served in some other way, have you considered a Hatch pattern?  A very easy modification of the one called CROSS would do.  It could be defined as 1-unit spacing so the drawn spacing would be set directly via the scale factor.  There would be several advantages [I think, without knowing how you are using any of this].  The crosses would be "locked" in relation to each other, and couldn't be accidentally moved [assuming you wouldn't want  to be able to reposition some in relation to others].  You could change the spacing between them with a simple entry in the Properties box, and could change their locations relative to the perimeter all together by giving it a new Origin point.  You could change the perimeter object and they would adjust to any new shape you give it.  Etc.

The editable-object part could still be splattered around at the same spacing.  If that's in Blocks, they just wouldn't need to include  the cross part in them.

[dani_cs]

Hello  pbejse,

Yes, it' s an example of distance, plot scale and height text specified by the user.

I would like that the tick marks will be a generl block ( for example a matrix) because I want to click in the center of them for checking coordinates for example. If you know a better option for that, I'm all ears.

Best regards,

Daniel

[dani_cs]

Hello Kent1Cooper,

I would like that the tick marks will be a general block ( for example a matrix) because I want to click in the center of them for checking coordinates for example. If a hatch pattern can do it, perfect.

all in all, I need to specify plot scale, distance between tick marks (to axis) and height text, then I select a rectangle and the tick marks will appear automaticly (accurated coordinates)

Best regards,

Daniel

[CADaSchtroumpf · Accepted solution]

Hello,

I have this , or also you can look at this.

Note: Code is construct for metric

I hope that you can use it?

(vl-load-com)
(defun des_vec (lst col / lst_sg)
  (setq lst_sg (list (cadr lst) (car lst)))
  (setq lst (cdr lst))
  (while lst
    (if (cadr lst)
      (setq lst_sg (cons (cadr lst) (cons (car lst) lst_sg)))
      (setq lst_sg (cons (last lst_sg) (cons (car lst) lst_sg)))
    )
    (setq lst (cdr lst))
  )
  (setq lst_sg (cons col lst_sg))
  (grvecs lst_sg)
)
(defun l-coor2l-pt (lst flag / )
  (if lst
    (cons (list (car lst) (cadr lst) (if flag (caddr lst) 0.0))
      (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
    )
  )
)
(defun c:DIM-GRID ( / unit_draw AcDoc Space UCS save_ucs WCS dx_u hview old_snapang pt_ins dx dy pt_tmp ang l_scale format_scale coeff
 key pt_key n nb_column nb_raw pt_row count s_ang nw_style f_pat nw_pl ech htx nw_pl_out nw_pl_in hatch_out hatch lst_pt str ori_txt nw_txt)
  (if (or (eq (getvar "USERS5") "") (not (eq (substr (getvar "USERS5") 1 2) "qz")))
    (setvar "USERS5" (strcat "qz" (itoa (setq unit_draw 1000))))
    (setq unit_draw (atoi (substr (getvar "USERS5") 3)))
  )
  (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-StartUndoMark AcDoc)
  (setq
    Space
    (if (eq (getvar "CVPORT") 1)
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
    UCS (vla-get-UserCoordinateSystems AcDoc)
    save_ucs
    (vla-add UCS
      (vlax-3d-point '(0.0 0.0 0.0))
      (vlax-3d-point (getvar "UCSXDIR"))
      (vlax-3d-point (getvar "UCSYDIR"))
      "CURRENT_UCS"
    )
  )
  (vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG")))
  (setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS"))
  (vla-put-activeUCS AcDoc WCS)
  (initget 6)
  (setq dx_u (getreal "\nDistance in millimeter of your template iso <210.0>: "))
  (if (not dx_u) (setq dx_u 210.0))
  (setq
    hview (getvar "VIEWSIZE")
    old_snapang (getvar "SNAPANG")
    pt_ins (list (- (car (getvar "VIEWCTR")) (* hview 0.5)) (- (cadr (getvar "VIEWCTR")) (* hview 0.5)))
    dx dx_u dy (* dx_u (sqrt 2)) pt_tmp pt_ins ang (getvar "SNAPANG")
    l_scale '(1.0 1.25 2.0 2.5 5.0 7.5)
    format_scale (car l_scale)
    coeff 1.0
  )
  (if (> (fix (/ hview dy)) 3)
    (while (> (fix (/ hview dy)) 3)
      (foreach value l_scale
        (if (> (fix (/ hview dy)) 3)
          (setq format_scale value dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
        )
      )
      (if (> (fix (/ hview dy)) 3)
        (setq
          coeff (* coeff 10.0)
          l_scale (mapcar '(lambda (x) (* x coeff)) l_scale)
          format_scale (car l_scale)
        )
      )
    )
  )
  (if (< (fix (/ hview dy)) 1)
    (while (< (fix (/ hview dy)) 1)
      (foreach value (reverse l_scale)
        (if (< (fix (/ hview dy)) 1)
          (setq format_scale value dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
        )
      )
      (if (< (fix (/ hview dy)) 1)
        (setq
          coeff (* coeff 0.1)
          l_scale (mapcar '(lambda (x) (* x coeff)) l_scale)
          format_scale (last l_scale)
        )
      )
    )
  )
  (princ (strcat "\nSpecify up rigth corner or: [P] for new Position of down left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
  (while (and (setq key (grread T 4 0)) (/= (car key) 3))
    (cond
      ((eq (car key) 5)
        (setq pt_key (cadr key))
        (setq n
          (*
            (setq nb_column (fix (/ (+ (* (- (car pt_key) (car pt_ins)) (cos ang)) (* (- (cadr pt_key) (cadr pt_ins)) (sin ang))) dx)))
            (setq nb_raw (fix (/ (- (* (- (cadr pt_key) (cadr pt_ins)) (cos ang)) (* (- (car pt_key) (car pt_ins)) (sin ang))) dy)))
          )
          pt_row pt_ins count 0
        )
        (redraw)
        (repeat n
          (des_vec
            (list
              (list (car pt_ins) (cadr pt_ins))
              (list (+ (car pt_ins) (* dx (cos ang))) (+ (cadr pt_ins) (* dx (sin ang))))
              (setvar "LASTPOINT"
                (list
                  (+ (car pt_ins) (- (* dx (cos ang)) (* dy (sin ang))))
                  (+ (cadr pt_ins) (+ (* dy (cos ang)) (* dx (sin ang))))
                )
              )
              (list (- (car pt_ins) (* dy (sin ang))) (+ (cadr pt_ins) (* dy (cos ang))))
            )
            3
          )
          (setq count (1+ count))
          (if (< count nb_column)
            (setq pt_ins (list (+ (car pt_ins) (* dx (cos ang))) (+ (cadr pt_ins) (* dx (sin ang)))))
            (setq pt_ins (list (- (car pt_row) (* dy (sin ang))) (+ (cadr pt_row) (* dy (cos ang)))) pt_row pt_ins count 0)
          )
        )
        (setq pt_ins pt_tmp)
      )
      ((or (eq (cadr key) 114) (eq (cadr key) 82))
        (initget 0)
        (setq s_ang
          (getorient pt_ins
            (strcat
              "\nNew angle<"
              (angtos (getvar "SNAPANG"))
              ">: "
            )
          )
        )
        (if (not s_ang) (setq s_ang ang))
        (if (and (> s_ang (/ pi 2)) (<= s_ang (/ (* 3 pi) 2)))
          (setq ang (+ s_ang pi))
          (setq ang s_ang)
        )
        (setvar "SNAPANG" ang)
        (princ (strcat "\nSpecify down rigth corner or: [P] for new Position of down left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
      )
      ((or (eq (cadr key) 112) (eq (cadr key) 80))
        (initget 9)
        (setq pt_ins (getpoint "\nSpecify down left corner: "))
        (setq pt_ins (list (car pt_ins) (cadr pt_ins)) pt_tmp pt_ins)
        (princ (strcat "\nSpecify down rigth corner or: [P] for new Position of down left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
      )
      ((eq (cadr key) 43)
        (setq format_scale (cadr (member format_scale l_scale)))
        (if (not format_scale) (setq format_scale (car (setq l_scale (mapcar '(lambda (x) (* x 10.0)) l_scale)))))
        (setq dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
        (princ (strcat "\nSpecify down rigth corner or: [P] for new Position of down left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
      )
      ((eq (cadr key) 45)
        (setq format_scale (cadr (member format_scale (reverse l_scale))))
        (if (not format_scale) (setq format_scale (last (setq l_scale (mapcar '(lambda (x) (* x 0.1)) l_scale)))))
        (setq dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
        (princ (strcat "\nSpecify down rigth corner or: [P] for new Position of down left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
      )
    )
  )
  (princ "\n")
  (redraw)
  (if (not (tblsearch "STYLE" "$DIM-GRID"))
    (progn
      (setq nw_style (vla-add (vla-get-textstyles AcDoc) "$DIM-GRID"))
      (mapcar
        '(lambda (pr val)
          (vlax-put nw_style pr val)
        )
        (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
        (list "SIMPLEX.SHX" 0.0 0.0 1.0 0.0)
      )
    )
  )
  (if (not (tblsearch "LAYER" "DIM-GRID"))
    (vlax-put (vla-add (vla-get-layers AcDoc) "DIM-GRID") 'color 7)
  )
  (if (not (findfile "QUADISO.pat"))
    (progn
      (setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\QUADISO.pat") "w"))
      (write-line "*QUADISO,Quadrillage lambert" f_pat)
      (write-line "0, -.015,0, 0,1, .03,-.97" f_pat)
      (write-line "90, 0,-.015, 0,1, .03,-.97" f_pat)
      (close f_pat)
    )
  )
  (if (not (findfile "REPQUADISO.pat"))
    (progn
      (setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\REPQUADISO.pat") "w"))
      (write-line "*REPQUADISO,Repere du quadrillage lambert" f_pat)
      (write-line "0, 0,0, 0,1" f_pat)
      (write-line "90, 0,0, 0,1" f_pat)
      (close f_pat)
    )
  )
  (setq
    nw_pl
    (vlax-invoke Space 'AddLightWeightPolyline
      (append
        pt_ins
        (polar pt_ins (+ (getvar "SNAPANG") (* pi 0.5)) (* (distance pt_ins (getvar "LASTPOINT")) (sin (- (angle pt_ins (getvar "LASTPOINT")) (getvar "SNAPANG")))))
        
        (list (car (getvar "LASTPOINT")) (cadr (getvar "LASTPOINT")))
        (polar pt_ins (getvar "SNAPANG") (* (distance pt_ins (getvar "LASTPOINT")) (cos (- (angle pt_ins (getvar "LASTPOINT")) (getvar "SNAPANG")))))
      )
    )
    ech (* unit_draw format_scale)
    htx (/ ech 500.0)
  )
  (vla-put-Closed nw_pl 1)
  (vla-put-layer nw_pl "DIM-GRID")
  (vla-Offset nw_pl (* htx 2.5))
  (setq nw_pl_out (vlax-ename->vla-object (entlast)))
  (vla-Offset nw_pl (+ (* htx 2.5) (* htx 10.0)))
  (setq nw_pl_in (vlax-ename->vla-object (entlast)))
  (setvar "HPORIGINMODE" 0)
  (setvar "HPORIGIN" '(0.0 0.0))
  (setq hatch_out (vla-AddHatch Space acHatchPatternTypeCustomDefined "REPQUADISO" :vlax-True))
  (vlax-invoke hatch_out 'AppendOuterLoop (list nw_pl))
  (vlax-invoke hatch_out 'AppendInnerLoop (list nw_pl_out))
  (vla-put-patternscale hatch_out (/ ech 10.0))
  (vla-put-patternangle hatch_out 0.0)
  (vla-put-layer hatch_out "DIM-GRID")
  (vla-evaluate hatch_out)
  (setq hatch (vla-AddHatch Space acHatchPatternTypeCustomDefined "QUADISO" :vlax-True))
  (vlax-invoke hatch 'AppendOuterLoop (list nw_pl_in))
  (vla-put-patternscale hatch (/ ech 10.0))
  (vla-put-patternangle hatch 0.0)
  (vla-put-layer hatch "DIM-GRID")
  (vla-evaluate hatch)
  (setq lst_pt
    (l-coor2l-pt
      (vlax-invoke
        hatch_out
        'IntersectWith
        nw_pl_out
        acExtendThisEntity
      )
      T
    )
  )
  (foreach el lst_pt
    (cond
      ((or (equal (rem (car el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (car el) (/ ech 10.0)) 0.0 1E-8))
        (setq str (strcat " " (rtos (car el) 2 0) " ") ori_txt (* pi 0.5))
      )
      ((or (equal (rem (cadr el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (cadr el) (/ ech 10.0)) 0.0 1E-8))
        (setq str (strcat " " (rtos (cadr el) 2 0) " ") ori_txt 0.0)
      )
      (T (setq str nil ori_txt nil))
    )
    (cond
      ((and el str ori_txt)
        (setq nw_txt (vla-AddText Space str (vlax-3d-point el) htx))
        (vla-put-layer nw_txt "DIM-GRID")
        (vla-put-StyleName nw_txt "$DIM-GRID")
        (vla-put-Alignment nw_txt acAlignmentMiddleLeft)
        (vla-put-Rotation nw_txt ori_txt)
        (vla-put-TextAlignmentPoint nw_txt (vlax-3d-point el))
        (if (vlax-invoke nw_pl 'IntersectWith nw_txt acExtendThisEntity)
          (vla-put-Alignment nw_txt acAlignmentMiddleRight)
        )
      )
    )
  )
  (setq pt_ins (polar pt_ins (+ (* pi 0.25) (getvar "SNAPANG")) (* htx 10)))
  (setq nw_txt (vla-AddText Space (strcat " Scale 1/" (rtos ech 2 0)) (vlax-3d-point pt_ins) (* 2 htx)))
  (vla-put-layer nw_txt "DIM-GRID")
  (vla-put-StyleName nw_txt "$DIM-GRID")
  (vla-put-Alignment nw_txt acAlignmentMiddleLeft)
  (vla-put-Rotation nw_txt (getvar "SNAPANG"))
  (vla-put-TextAlignmentPoint nw_txt (vlax-3d-point pt_ins))
  (and save_ucs (vla-put-activeUCS AcDoc save_ucs))
  (and WCS (vla-delete WCS) (setq WCS nil))
  (vla-EndUndoMark AcDoc)
  (setvar "SNAPANG" old_snapang)
  (prin1)
)

[dani_cs]

Hello CADaStroumph,

It is not exactly I was looking for but it will help me a lot. Thanks.

Best regards,

Daniel

[Satish_Rajdev]

I've made some correction to my program, you can try this copy and let me know.

[dani_cs]

Hello Satish_Rajdev,

I have other error... It is:

Comando: (LOAD "C:/Users/Nadir05/Desktop/AddGrid.fas") ; error: instrucción xsubr(L) errónea (código desf): 2496 107

In english it could be something like this:

Command: (LOAD "C:/Users/Nadir05/Desktop/AddGrid.fas") ; error: bad instruction xsubr(L) (code desf): 2496 107

Thanks for you time.

Best regards,

Daniel.