Jump to content
prodromosm

viewport grid help

Recommended Posts

prodromosm

Hi i am using this lisp to create  grids in my viewports. Can any one update this code to work with twisted coordinate systems ?


(vl-load-com) 
(prompt "\nKoordinatenanschrieb fόr Ansichtsfenster fόr AutoCAD Civil 3D - Start mit CVP")

 ;
 ; Hauptprogramm
 ;
(defun C:cvp ( / alterror sblip scmd sosmode al anz x axl zen_af zen_af_x zen_af_y zen_modw zen_mod_xw zen_mod_yw
		    br_af h_af h_mod affakt br_mod alpha liun_af_x liob_af_x reun_af_x reob_af_x liun_af_y liob_af_y
		    reun_af_y reob_af_y element punkte liun_mb liob_mb reun_mb reob_mb liun_mb_x liob_mb_x reun_mb_x
		    reob_mb_x liun_mb_y liob_mb_y reun_mb_y reob_mb_y startx starty delta_l delta_m delta_a cy_af
		    richtg textht textri textausri cx_mb minx maxx delta_m1 cx_af ctext p1 p2 pt cy_mb miny maxy
		    elemlist temp digits viewdir
                )
  (setq alterror *error*)
  (setq *error* my_error)
  (command "_undo" "_mark")
  (COMMAND "_layer" "_m" "VP_grid" "_c" "5" "" "")
  ; globale Variablen

(setq  *AD:TEXTHOEHE*  2.5
       *AD:LINIENLAENGE* (* 0.8 *AD:TEXTHOEHE*)
)       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Unterprogramme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun createCvp (p1 p2 textausri pt textht textri ctext / elelist)
            (command "_LINE" p1 p2 "")
            (setq elelist (list (entlast)))
            (if (> (cdr (assoc 40 (tblsearch "Style" (getvar "textstyle")))) 0.0); wenn aktueller Textstil keine feste Texthφhe
	      (command "_TEXT" "_Justify" textausri pt textri ctext)
              (command "_TEXT" "_Justify" textausri pt *AD:TEXTHOEHE* textri ctext)
	    )
            (setq elelist (cons (entlast) elelist)) ; Rόckgabe er Liste
    	    ;(COMMAND "_-INSERT" "CVP" p1 1.0  (angtos richtg) (itoa cx_mb))
	    ;(CreateBLockinPaperspace "CVPRECHTS" p1 richtg (itoa cx_mb))
  )

 (prompt "\nCoordinate Labeling for Viewports")
 ;
 ; Sichern und Setzen einiger Systremvariable
 ;
 (setq sblip (getvar "blipmode"))
 (setq scmde (getvar "cmdecho"))
 (setq sosmode (getvar "osmode"))
 (setq sangbase (getvar "angbase"))
 (setq sangdir (getvar "angdir"))
 (setq saunits (getvar "aunits")) 
 (setvar "blipmode" 0)
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
 (setvar "angbase" 0)
 (setvar "angdir" 0)
 (setvar "aunits" 0) 

 ;  Aufforderung zur Ansichtsfensterwahl
 (setq anz 0 al (ssget '((0 . "VIEWPORT"))))

 (if al (setq anz (sslength al)) (prompt "\n no Viewport selected !"))
 (setq x 0)
 (while (< x anz)
   (setq axl (entget (ssname al x)))
   ;
   ; pruefen ob ansichtsfenster
   ;
   (if (= "VIEWPORT" (cdr (assoc 0 axl)))
       (progn
          (setq zen_af (cdr (assoc 10 axl)))
          (setq zen_af_x (car zen_af))
          (setq zen_af_y (cadr zen_af))
          (setq zen_modw (cdr (assoc 12 axl)))
          (setq zen_mod_xw (car zen_modw))
          (setq zen_mod_yw (cadr zen_modw))
          (setq br_af (cdr (assoc 40 axl)))
          (setq h_af (cdr (assoc 41 axl)))
          (setq h_mod (cdr (assoc 45 axl)))
          (setq affakt (/ h_af h_mod))
          (setq br_mod (/ br_af affakt))
          (setq alpha (cdr (assoc 51 axl)))
          ;
          ;
          ; eckpunkte ansichtsfenster (annahme nicht gedreht)
          ;
          (setq liun_af_x (- zen_af_x (/ br_af 2.)))
          (setq liob_af_x (- zen_af_x (/ br_af 2.)))
          (setq reun_af_x (+ zen_af_x (/ br_af 2.)))
          (setq reob_af_x (+ zen_af_x (/ br_af 2.)))
          (setq liun_af_y (- zen_af_y (/ h_af 2.)))
          (setq liob_af_y (+ zen_af_y (/ h_af 2.)))
          (setq reun_af_y (- zen_af_y (/ h_af 2.)))
          (setq reob_af_y (+ zen_af_y (/ h_af 2.)))
          ;
          ;  OK bis hier, nun Koordinaten der Eckpunkte fuer Modellbereich ermitteln
          ;
          ; dafόr haben wir im lisp forum etwas gefunden
          ;
          (setq element (cdr (assoc -1 axl)))
          ;(SETQ punkte (#VPT_BOX element))
          ; neue Routine soll obige Routine ersetzen
	  (setq Punkte (MSAnsichtsfensterkoordinaten element))
          ;
          ; punkte extrahieren
          ;
          (setq liun_mb (nth 0 punkte))
          (setq reun_mb (nth 1 punkte))
          (setq reob_mb (nth 2 punkte))
          (setq liob_mb (nth 3 punkte))
          (setq liun_mb_x (car liun_mb))
          (setq liun_mb_y (cadr liun_mb))
          (setq liob_mb_x (car liob_mb))
          (setq liob_mb_y (cadr liob_mb))
          (setq reun_mb_x (car reun_mb))
          (setq reun_mb_y (cadr reun_mb))
          (setq reob_mb_x (car reob_mb))
          (setq reob_mb_y (cadr reob_mb))
          ;
          ; Ausgabe Extremwerte und Abfrage Startwerte und Schrittweiten
          ;

          (if (= :vlax-true (vlax-get-property (vlax-ename->vla-object (ssname al x)) "clipped"))
            (prompt "Das Ansichtsfenster besitzt eine Zuschneideumgrenzung, das Ergebnis kann unerwartet ausfallen")
          )
	  (setq viewdir  (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object (ssname al x)) "Direction"))))
          (if (not (and (equal (car  viewdir) 0.0 1.0E-5)
	                (equal (cadr viewdir) 0.0 1.0E-5)
                   )
	      )
            (alert "The Viewport is not in plan. Result will be wrong!")
          )
	  (prompt (strcat "\nViewport Coordinates for " (itoa (1+ x)) ". Viewport"))

          (prompt "\nMinimal- and Maximalvalue of x:")
          (princ (setq minx (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x)))
          (princ "  ")
          (princ "  ")
          (princ (setq maxx (max liun_mb_x liob_mb_x reun_mb_x reob_mb_x)))
          (prompt "\nMinimal- and Maximalvalue of y:")
          (princ (setq miny (min liun_mb_y liob_mb_y reun_mb_y reob_mb_y)))
          (princ "  ")
          (princ "  ")
          (princ (setq maxy (max liun_mb_y liob_mb_y reun_mb_y reob_mb_y)))
          (terpri)
          ; (initget 1)
 
          ;(initget 3)
	  (setq temp (fix (/ (- (max liun_mb_x liob_mb_x reun_mb_x reob_mb_x)
			        (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x)
			     )
			     10 ; 10 Unterteilungen pro Fenster als Vorschlag
			  )
                     )
	  )
	  (setq digits (1- (strlen (itoa temp)))
		temp (* (fix (/ temp (expt 10 digits))) (expt 10 digits))
	  )
	  (if (= 0 temp) (setq temp 1))
	  
	  (If (not (setq delta_l (getint (strcat "Απόσταση μεταξύ των συντεταγμένων <" (itoa temp) ">: "))))
	    (setq delta_l temp)
	  )
	  
	  (setq minx (* (fix (/ minx delta_l)) delta_l)
		miny (* (fix (/ miny delta_l)) delta_l)
	  )
	  (if (not (setq startx (getint (strcat "\nstart coordinates X <" (itoa minx) ">: "))))
	    (setq startx minx)
	  )
          (if (not (setq starty (getint (strcat "\nstart coordinates Y <" (itoa miny) ">: "))))
	    (setq starty miny)
	  )
          (Initget "Inside Outside")
          (if (setq temp (getkword "\n Place coordinates [ Inside / Ι / Outside  Ο] of VP <Outside>:"))
              (setq lraussen  (= temp "Outside"))
              ;else
              (setq lraussen  'T)
          )
          (if (setq temp (getdist (strcat "text distance <" (rtos *AD:LINIENLAENGE*) ">:")))
	    (setq *AD:LINIENLAENGE* temp)
	  )
	  (createunnamedgroupfromelist
            (erzeugeGitterkreuze startx starty maxx maxy delta_l (ssname al x))
	  )

          ; diese 8 Wiederholungen sollten sich doch auch in einer Schleife unterbringen lassen, die nur die
          ; Viewportkoordinaten bekommt
          ; Udo Hόbner 
          
          ;
          ; Werte pruefen und setzen (lassen wir noch offen)
          ;
          ;
          ; jetzt gehts richtig los
          ;
          ; unterer Rand, x werte
          ;
          (setq delta_m (- reun_mb_x liun_mb_x))  ; dargestellte Koord.diff im Modellb.
          (setq delta_a (- reun_af_x liun_af_x))  ; dargestellte Koord.diff im Ansichtsf.
          (setq cy_af liun_af_y)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))  ; Richtg. der Linie in Abh. von Drehung MB in AF
            (setq richtg (- alpha (/ pi 2.)))
            (setq richtg (+ alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))   ; nur Richtung 0 .. 2pi zulaessig
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*) ; vorher Konstant 1
          (if (< richtg (/ pi 2))                 ; Textrichtg. in Abh. von Linienrichtg.
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "_mr" "_ml"))
            ) ; end progn
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "_ml" "_mr"))
            ) ; end progn
          ) ; end if
       	  (if lraussen (setq richtg (+ richtg pi)))
          (setq cx_mb startx)
          (setq minx (min liun_mb_x reun_mb_x))  ; es kann auch in negativer Richtung verlaufen
          (setq maxx (max liun_mb_x reun_mb_x))
          (while (<= cx_mb minx)                 ; ersten auf Rand im MB vorh. Wert ermitteln
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb liun_mb_x))  ; Streckenverhaeltnisse
            (setq cx_af (+ liun_af_x (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb


          ; oberer Rand, x werte
          ;
          (setq delta_m (- reob_mb_x liob_mb_x))
          (setq delta_a (- reob_af_x liob_af_x))
          (setq cy_af liob_af_y)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
            (setq richtg (+ alpha (/ pi 2.)))
            (setq richtg (- alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (if (< richtg (* pi 1.5))
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "_ml" "_mr"))
            ) ; end progn
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "_mr" "_ml"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
          (setq cx_mb startx)
          (setq minx (min liob_mb_x reob_mb_x))
          (setq maxx (max liob_mb_x reob_mb_x))
          (while (<= cx_mb minx)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb liob_mb_x))
            (setq cx_af (+ liob_af_x (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb

          ; linker Rand, x werte
          ;
          (setq delta_m (- liob_mb_x liun_mb_x))
          (setq delta_a (- liob_af_y liun_af_y))
          (setq cx_af liun_af_x)
          (if (> alpha pi)
            (setq richtg (+ alpha (/ pi 2.)))
            (setq richtg (- alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (setq textri (/ (* richtg 180 ) pi))
          (setq textausri (if lraussen "_mr" "_ml"))
      	  (if lraussen (setq richtg (+ richtg pi)))
          (setq cx_mb startx)
          (setq minx (min liob_mb_x liun_mb_x))
          (setq maxx (max liob_mb_x liun_mb_x))
          (while (<= cx_mb minx)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb liun_mb_x))
            (setq cy_af (+ liun_af_y (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb

          ; rechter Rand, x werte
          ;
          (setq delta_m (- reob_mb_x reun_mb_x))
          (setq delta_a (- reob_af_y reun_af_y))
          (setq cx_af reun_af_x)
          (if (< alpha pi)
            (setq richtg (+ alpha (/ pi 2.)))
            (setq richtg (- alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (setq textri (/ (* (- richtg pi) 180 ) pi))
          (setq textausri (if lraussen "_ml" "_mr"))
	  (if lraussen (setq richtg (+ richtg pi)))
         
          (setq cx_mb startx)
          (setq minx (min reob_mb_x reun_mb_x))
          (setq maxx (max reob_mb_x reun_mb_x))
          (while (<= cx_mb minx)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb reun_mb_x))
            (setq cy_af (+ reun_af_y (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb


          ; linker Rand, y werte
          ;
          (setq delta_m (- liob_mb_y liun_mb_y))
          (setq delta_a (- liob_af_y liun_af_y))
          (setq cx_af liun_af_x)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
            (setq richtg (+ pi alpha))
            (setq richtg (+ alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (setq textausri (if lraussen "_mr" "_ml"))
          (setq textri (/ (* richtg 180 ) pi))
	  (if lraussen (setq richtg (+ richtg pi)))
         
          (setq cy_mb starty)
          (setq miny (min liob_mb_y liun_mb_y))
          (setq maxy (max liob_mb_y liun_mb_y))
	 
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb liun_mb_y))
            (setq cy_af (+ liun_af_y (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb


          ; rechter Rand, y werte
          ;
          (setq delta_m (- reob_mb_y reun_mb_y))
          (setq delta_a (- reob_af_y reun_af_y))
          (setq cx_af reun_af_x)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
            (setq richtg (+ alpha))
            (setq richtg (+ pi alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (setq textri (/ (* (- richtg pi) 180 ) pi))
          (setq textausri (if lraussen "_ml" "_mr"))
	  (if lraussen (setq richtg (+ richtg pi)))
         
          (setq cy_mb starty)
          (setq miny (min reun_mb_y reob_mb_y))
          (setq maxy (max reun_mb_y reob_mb_y))
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb reun_mb_y))
            (setq cy_af (+ reun_af_y (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb

          ; unterer Rand, y werte
          ;
          (setq delta_m (- reun_mb_y liun_mb_y))
          (setq delta_a (- reun_af_x liun_af_x))
          (setq cy_af liun_af_y)
          (if (< alpha pi)
            (setq richtg (+ alpha))
            (setq richtg (+ pi alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (if (< richtg (/ pi 2))
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "_mr" "_ml"))
            ) ; end progn
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "_ml" "_mr"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
         
          (setq cy_mb starty)
          (setq miny (min liun_mb_y reun_mb_y))
          (setq maxy (max liun_mb_y reun_mb_y))
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb liun_mb_y))
            (setq cx_af (+ liun_af_x (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb

          ; oberer Rand, y werte
          ;
          (setq delta_m (- reob_mb_y liob_mb_y))
          (setq delta_a (- reob_af_x liob_af_x))
          (setq cy_af liob_af_y)
          (if (< alpha pi)
            (setq richtg (+ pi alpha))
            (setq richtg (+ alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
          (setq textht *AD:TEXTHOEHE*)
          (if (< richtg (* pi 1.5))
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "_ml" "_mr"))
            ) ; end progn
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "_mr" "_ml"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
        
          (setq cy_mb starty)
          (setq miny (min liob_mb_y reob_mb_y))
          (setq maxy (max liob_mb_y reob_mb_y))
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb liob_mb_y))
            (setq cx_af (+ liob_af_x (* (/ delta_m1 delta_m) delta_a)))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))
            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
	    ; Koordinatenbeschiftung anfόgen
	    (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
	 ) ;end progn
   ) ; end if viewport
   (createunnamedgroupfromelist elemlist)
   (setq x (1+ x)
	 elemlist nil
   )
(command "setvar" "clayer" "0") 
 )
  
 ;
 ; Ausgangsbedingungen wieder herstellen
 ;
 (setvar "blipmode" sblip)
 (setvar "cmdecho" scmde)
 (setvar "osmode" sosmode)
 (setvar "angbase" sangbase)
 (setvar "angdir" sangdir)
 (setvar "aunits" saunits) 
 (setq *error* alterror)
 ;(prompt "Koordinaten gesetzt")
 (princ)

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Errorhandling
(defun my_error (msg)
  (print (strcat "Fehler aufgetreten: " msg))
  (command "_undo" "_back")
  (setq *error* alterror)
  (setvar "blipmode" sblip)
  (setvar "cmdecho" scmde)
  (setvar "osmode" sosmode)
  (setvar "angbase" sangbase)
  (setvar "angdir" sangdir)
  (setvar "aunits" saunits) 

  (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ab hier Routinen von Udo Hόbner
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CreateBLockinPaperspace (Blockname InsertionPoint rotationangle value)
(if (not
     (or
      (vl-catch-all-error-p
             (setq BlkObj (vl-catch-all-apply
		              'vla-InsertBlock
		              (list
				(vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
				(vlax-3d-point InsertionPoint)
				Blockname
				1 1 1 rotationangle
	                      )
		   )
             )
       )
       (= :vlax-false (vlax-get-property blkObj "HasAttributes"))
     )
    )
    (foreach Att (vlax-safearray->list (vlax-variant-value (vla-getAttributes BlkObj)))
        (setq tagstring (strcase (vla-get-TagString  Att)))
        (if (= tagstring (strcase "Koordinate"))
           (vla-put-TextString att value)
	)
    )
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun createunnamedgroupfromelist (elist / CNT GROUPNAME SARRAY)
  (setq groupname (vla-add (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))) "*"))
  (if elist
    (progn
      (setq cnt (length elist)
	    sArray (vlax-safearray-fill
		     (vlax-make-safearray vlax-vbobject (cons 0 (1- cnt)))
		     (mapcar 'vlax-ename->vla-object elist)
		   )
      )
      (vlax-invoke-method groupname "AppendItems" sArray)
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun erzeugeGitterkreuze (startx starty maxx maxy delta_l AF
			    / acaddoc y eleliste punktliste
			    AFLISTE AFOBJ BREITE CENAF DREHWINKEL HOEHE MAXAF MINAF
			    )
 (setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
 ; AF einschalten
 (vlax-invoke-Method (setq AFobj (vlax-ename->vla-object AF)) "Display" :vlax-true)
 ; Modellbereich im Ansichtsfenster aktiv schalten 
 (vla-put-mspace acaddoc :vlax-true)
 ; gewδhltes AF aktiv schalten  
 (setvar "CVPORT" (cdr (assoc 69 (setq AFliste (entget AF)))))
 (while (< startx maxx)
   (setq y starty)
   (while (< y maxy)
     (setq punktliste (cons (ms2ps (list startx y) AF) punktliste))
     (setq y (+ y delta_l))
   )
   (setq startx (+ startx delta_l))
 )
 (vla-put-mspace acaddoc :vlax-false) 
 ;jetzt Punkte zeichnen
 (setq cenAf  (cdr (assoc 10 AFliste))
       breite (cdr (assoc 40 AFliste))
       hoehe  (cdr (assoc 41 AFliste))
       minAF  (list  (- (car cenaf) (* 0.5 breite))(- (cadr cenaf) (* 0.5 hoehe)))
       maxAF  (list  (+ (car cenaf) (* 0.5 breite))(+ (cadr cenaf) (* 0.5 hoehe)))
       Drehwinkel (cdr (assoc 51 AFliste))
 )
 (if (not (tblsearch "BLOCK" "Gitterkreuz"))
    (Createblock "Gitterkreuz")
 )
 (foreach punkt punktliste
   (if (and (> (car punkt)(car minAF))   (< (car punkt)(car maxAF))
	    (> (cadr punkt)(cadr minAF)) (< (cadr punkt)(cadr maxAF))
       )					   
     (setq eleliste (cons (insertblock "Gitterkreuz" punkt drehwinkel) eleliste))
   )     
 )   
 eleliste  ; Rόckgabewert
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
(defun ms2ps (point AF)
  (if (and af (= "VIEWPORT" (cdr (assoc 0 (entget AF)))))
    (trans (trans point 0 2) 2 3)
    nil
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
(defun ps2ms (point AF)
  (if (and af (= "VIEWPORT" (cdr (assoc 0 (entget AF)))))
    (trans (trans point 3 2) 2 0)
    nil
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
(defun insertblock (Blockname punkt drehwinkel)
  (entmake (list (cons 0 "INSERT")(cons 2 blockname) (cons 67 0) (cons 410 (getvar "ctab")) (cons 8 (getvar "clayer"))
		  (cons 10 punkt) (cons 41 1.0)(cons 42 1.0)(cons 43 1.0) (cons 50 drehwinkel))
  )	    
  (entlast)
)  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CreateBlock (Blockname)
  (entmake (list (cons 0 "BLOCK")(cons 2 blockname)(cons 70 2)(list 10 0.0 0.0 0.0)))
  (entmake '((0 . "LINE") (67 . 0) (410 . "Model") (8 . "0") (10 -4.0  0.0 0.0)(11 4.0 0.0 0.0)))
  (entmake '((0 . "LINE") (67 . 0) (410 . "Model") (8 . "0") (10  0.0 -4.0 0.0)(11 0.0 4.0 0.0)))  
  (entmake (list (cons 0 "ENDBLK"))) ; Rόckgabewert ist Block-ename
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun MSAnsichtsfensterkoordinaten (AF)
 (setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
 (setq cenAf  (cdr (assoc 10 (setq AFliste (entget AF))))
       breite (cdr (assoc 40 AFliste))
       hoehe  (cdr (assoc 41 AFliste))
       Drehwinkel (cdr (assoc 51 AFliste))
 )
 ; AF einschalten  
 (vlax-invoke-Method (setq AFobj (vlax-ename->vla-object AF)) "Display" :vlax-true)
 ; Modellbereich im Ansichtsfenster aktiv schalten 
 (vla-put-mspace acaddoc :vlax-true)
  
 ; gewδhltes AF aktiv schalten  
 (setvar "CVPORT" (cdr (assoc 69 (setq AFliste (entget AF)))))
 (setq Punktliste
       (list
       (ps2ms (list  (- (car cenaf) (* 0.5 breite))(- (cadr cenaf) (* 0.5 hoehe))) AF) ; minAF
       (ps2ms (list  (+ (car cenaf) (* 0.5 breite))(- (cadr cenaf) (* 0.5 hoehe))) AF) ;
       (ps2ms (list  (+ (car cenaf) (* 0.5 breite))(+ (cadr cenaf) (* 0.5 hoehe))) AF) ; maxAF
       (ps2ms (list  (- (car cenaf) (* 0.5 breite))(+ (cadr cenaf) (* 0.5 hoehe))) AF) ;
       )
 )	
 (vla-put-mspace acaddoc :vlax-false)
 Punktliste
)
				     
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(prin1)

 

Thanks

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...