乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 ☆ ☆ ☆ 尊重版权，从我做起，拒绝盗版，拒绝倒卖 ☆ ☆ ☆ 签到、发布资源、邀请好友注册，可以获得银币 ☆ ☆ ☆ 请注意保管好自己的密码，避免账户资金被盗
查看： 2|回复： 2

[编程交流] 视口网格lisp帮助

[复制链接]
prodromosm

107

主题

615

帖子

575

银币

中流砥柱

Rank: 25

铜币
521
发表于 2022-7-5 19:58:53 | 显示全部楼层 |阅读模式
您好，我正在为vieport网格使用此lisp。我想改变坐标文本在X轴上的旋转，就像附加照片一样（上下）。
 
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; Koordinatenbeschriftung fόr Ansichtsfenster.lsp   V1.2                                            ;;;
  3. ;;; entstanden aus cvp.lsp                                                                        ;;;
  4. ;;; Erweitert und όberarbeitet von Udo Hόbner - www.CAD-Huebner.de fόr Autodesk                       ;;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;;; Lisp-Datei zum Zeichnen von Koordinaten an Layout-Ansichtsfenster                                 ;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;  erstellt 12/03  Th.J.
  9. ;           06/07  einfaches Errorhandling hinzugefuegt
  10. ;           06/07  Fehler bei Abweichung von Koordinatenrichtung und Winkeleinheiten beseitigt
  11. ;
  12. ;           07/07  Udo Hόbner / Vorgabewerte neu berechnet, Unterfunkion fόr Koordinatenanschrieb
  13. ;                             / Gruppierung des Anschriebs
  14. ;           16.07.07 Gitterkreuze zusδtzlich einfόgen
  15. ;           09/07  Auswahl, ob Anschreiben innen oder aussen vom AF
  16. ;           10/07 Voreinstellung der Textgrφίe auf Textsize (wenn nicht fix im Stil)
  17. ;                 Benutzung einer neuen Funktion statt #VPT_BOX
  18. ;           12/07 Viewdirbestimmung zur Erkennung von nicht "Normalen" WKS Ansichten
  19. ;                 und Ausgabwe eines Hinweises
  21. ;           Mφgliche Erweiterungen: Reaktor am AF, bei F Δnderung Neuerstellung der Beschriftung
  22. ;           Koordinatenkreuze
  24. ;  Vorhaben: waehle Ansichtsfenter und zeichne im Plotbereich an das AF die Koordinaten (Linien und Werte)
  25. ;            des dargestellten (Lage)planausschnittes
  26. ;
  27. ;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.      
  30. (vl-load-com) 
  31. (prompt "\nKoordinatenanschrieb fόr Ansichtsfenster fόr AutoCAD Civil 3D - Start mit CVP")
  33. ;
  34. ; Hauptprogramm
  35. ;
  36. (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
  37.             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
  38.             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
  39.             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
  40.             richtg textht textri textausri cx_mb minx maxx delta_m1 cx_af ctext p1 p2 pt cy_mb miny maxy
  41.             elemlist temp digits viewdir
  42.                )
  43.  (setq alterror *error*)
  44.  (setq *error* my_error)
  45.  (command "_undo" "_mark")
  48.  ; globale Variablen
  50. (setq  *AD:TEXTHOEHE* (GETVAR "TEXTSIZE")
  51.       *AD:LINIENLAENGE* (* 3.0 *AD:TEXTHOEHE*)
  52. )       
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54. ;;; Unterprogramme
  55. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56.  (defun createCvp (p1 p2 textausri pt textht textri ctext / elelist)
  57.            (command "_LINE" p1 p2 "")
  58.            (setq elelist (list (entlast)))
  59.            (if (> (cdr (assoc 40 (tblsearch "Style" (getvar "textstyle")))) 0.0); wenn aktueller Textstil keine feste Texthφhe
  60.       (command "_TEXT" "_Justify" textausri pt textri ctext)
  61.              (command "_TEXT" "_Justify" textausri pt *AD:TEXTHOEHE* textri ctext)
  62.     )
  63.            (setq elelist (cons (entlast) elelist)) ; Rόckgabe er Liste
  64.                ;(COMMAND "_-INSERT" "CVP" p1 1.0  (angtos richtg) (itoa cx_mb))
  65.     ;(CreateBLockinPaperspace "CVPRECHTS" p1 richtg (itoa cx_mb))
  66.  )
  68. (prompt "\nCoordinate Labeling for Viewports")
  69. ;
  70. ; Sichern und Setzen einiger Systremvariable
  71. ;
  72. (setq sblip (getvar "blipmode"))
  73. (setq scmde (getvar "cmdecho"))
  74. (setq sosmode (getvar "osmode"))
  75. (setq sangbase (getvar "angbase"))
  76. (setq sangdir (getvar "angdir"))
  77. (setq saunits (getvar "aunits")) 
  78. (setvar "blipmode" 0)
  79. (setvar "cmdecho" 0)
  80. (setvar "osmode" 0)
  81. (setvar "angbase" 0)
  82. (setvar "angdir" 0)
  83. (setvar "aunits" 0) 
  85. ;  Aufforderung zur Ansichtsfensterwahl
  86. (setq anz 0 al (ssget '((0 . "VIEWPORT"))))
  88. (if al (setq anz (sslength al)) (prompt "\nNo Viewport selected !"))
  89. (setq x 0)
  90. (while (< x anz)
  91.   (setq axl (entget (ssname al x)))
  92.   ;
  93.   ; pruefen ob ansichtsfenster
  94.   ;
  95.   (if (= "VIEWPORT" (cdr (assoc 0 axl)))
  96.       (progn
  97.          (setq zen_af (cdr (assoc 10 axl)))
  98.          (setq zen_af_x (car zen_af))
  99.          (setq zen_af_y (cadr zen_af))
  100.          (setq zen_modw (cdr (assoc 12 axl)))
  101.          (setq zen_mod_xw (car zen_modw))
  102.          (setq zen_mod_yw (cadr zen_modw))
  103.          (setq br_af (cdr (assoc 40 axl)))
  104.          (setq h_af (cdr (assoc 41 axl)))
  105.          (setq h_mod (cdr (assoc 45 axl)))
  106.          (setq affakt (/ h_af h_mod))
  107.          (setq br_mod (/ br_af affakt))
  108.          (setq alpha (cdr (assoc 51 axl)))
  109.          ;
  110.          ;
  111.          ; eckpunkte ansichtsfenster (annahme nicht gedreht)
  112.          ;
  113.          (setq liun_af_x (- zen_af_x (/ br_af 2.)))
  114.          (setq liob_af_x (- zen_af_x (/ br_af 2.)))
  115.          (setq reun_af_x (+ zen_af_x (/ br_af 2.)))
  116.          (setq reob_af_x (+ zen_af_x (/ br_af 2.)))
  117.          (setq liun_af_y (- zen_af_y (/ h_af 2.)))
  118.          (setq liob_af_y (+ zen_af_y (/ h_af 2.)))
  119.          (setq reun_af_y (- zen_af_y (/ h_af 2.)))
  120.          (setq reob_af_y (+ zen_af_y (/ h_af 2.)))
  121.          ;
  122.          ;  OK bis hier, nun Koordinaten der Eckpunkte fuer Modellbereich ermitteln
  123.          ;
  124.          ; dafόr haben wir im lisp forum etwas gefunden
  125.          ;
  126.          (setq element (cdr (assoc -1 axl)))
  127.          ;(SETQ punkte (#VPT_BOX element))
  128.          ; neue Routine soll obige Routine ersetzen
  129.   (setq Punkte (MSAnsichtsfensterkoordinaten element))
  130.          ;
  131.          ; punkte extrahieren
  132.          ;
  133.          (setq liun_mb (nth 0 punkte))
  134.          (setq reun_mb (nth 1 punkte))
  135.          (setq reob_mb (nth 2 punkte))
  136.          (setq liob_mb (nth 3 punkte))
  137.          (setq liun_mb_x (car liun_mb))
  138.          (setq liun_mb_y (cadr liun_mb))
  139.          (setq liob_mb_x (car liob_mb))
  140.          (setq liob_mb_y (cadr liob_mb))
  141.          (setq reun_mb_x (car reun_mb))
  142.          (setq reun_mb_y (cadr reun_mb))
  143.          (setq reob_mb_x (car reob_mb))
  144.          (setq reob_mb_y (cadr reob_mb))
  145.          ;
  146.          ; Ausgabe Extremwerte und Abfrage Startwerte und Schrittweiten
  147.          ;
  149.          (if (= :vlax-true (vlax-get-property (vlax-ename->vla-object (ssname al x)) "clipped"))
  150.            (prompt "Das Ansichtsfenster besitzt eine Zuschneideumgrenzung, das Ergebnis kann unerwartet ausfallen")
  151.          )
  152.   (setq viewdir  (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object (ssname al x)) "Direction"))))
  153.          (if (not (and (equal (car  viewdir) 0.0 1.0E-5)
  154.                 (equal (cadr viewdir) 0.0 1.0E-5)
  155.                   )
  156.       )
  157.            (alert "The Viewport is not in plan. Result will be wrong!")
  158.          )
  159.   (prompt (strcat "\nViewport Coordinates for " (itoa (1+ x)) ". Viewport"))
  161.          (prompt "\nMinimal- and Maximalvalue of x:")
  162.          (princ (setq minx (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x)))
  163.          (princ "  ")
  164.          (princ "  ")
  165.          (princ (setq maxx (max liun_mb_x liob_mb_x reun_mb_x reob_mb_x)))
  166.          (prompt "\nMinimal- and Maximalvalue of y:")
  167.          (princ (setq miny (min liun_mb_y liob_mb_y reun_mb_y reob_mb_y)))
  168.          (princ "  ")
  169.          (princ "  ")
  170.          (princ (setq maxy (max liun_mb_y liob_mb_y reun_mb_y reob_mb_y)))
  171.          (terpri)
  172.          ; (initget 1)
  174.          ;(initget 3)
  175.   (setq temp (fix (/ (- (max liun_mb_x liob_mb_x reun_mb_x reob_mb_x)
  176.                         (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x)
  177.                      )
  178.                      10 ; 10 Unterteilungen pro Fenster als Vorschlag
  179.                   )
  180.                     )
  181.   )
  182.   (setq digits (1- (strlen (itoa temp)))
  183.         temp (* (fix (/ temp (expt 10 digits))) (expt 10 digits))
  184.   )
  185.   (if (= 0 temp) (setq temp 1))
  186.   
  187.   (If (not (setq delta_l (getint (strcat "Distance between Coordinates <" (itoa temp) ">: "))))
  188.     (setq delta_l temp)
  189.   )
  190.   
  191.   (setq minx (* (fix (/ minx delta_l)) delta_l)
  192.         miny (* (fix (/ miny delta_l)) delta_l)
  193.   )
  194.   (if (not (setq startx (getint (strcat "\nStartvalue for X-Coordinates <" (itoa minx) ">: "))))
  195.     (setq startx minx)
  196.   )
  197.          (if (not (setq starty (getint (strcat "\nStartvalue for Y-Coordinates <" (itoa miny) ">: "))))
  198.     (setq starty miny)
  199.   )
  200.          (Initget "Inside Outside")
  201.          (if (setq temp (getkword "\nCoordinate Labels [inside/Outside] of VP <Outside>:"))
  202.              (setq lraussen  (= temp "Outside"))
  203.              ;else
  204.              (setq lraussen  'T)
  205.          )
  206.          (if (setq temp (getdist (strcat "Length of line <" (rtos *AD:LINIENLAENGE*) ">:")))
  207.     (setq *AD:LINIENLAENGE* temp)
  208.   )
  209.   (createunnamedgroupfromelist
  210.            (erzeugeGitterkreuze startx starty maxx maxy delta_l (ssname al x))
  211.   )
  213.          ; diese 8 Wiederholungen sollten sich doch auch in einer Schleife unterbringen lassen, die nur die
  214.          ; Viewportkoordinaten bekommt
  215.          ; Udo Hόbner 
  216.          
  217.          ;
  218.          ; Werte pruefen und setzen (lassen wir noch offen)
  219.          ;
  220.          ;
  221.          ; jetzt gehts richtig los
  222.          ;
  223.          ; unterer Rand, x werte
  224.          ;
  225.          (setq delta_m (- reun_mb_x liun_mb_x))  ; dargestellte Koord.diff im Modellb.
  226.          (setq delta_a (- reun_af_x liun_af_x))  ; dargestellte Koord.diff im Ansichtsf.
  227.          (setq cy_af liun_af_y)
  228.          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))  ; Richtg. der Linie in Abh. von Drehung MB in AF
  229.            (setq richtg (- alpha (/ pi 2.)))
  230.            (setq richtg (+ alpha (/ pi 2.)))
  231.          ) ; end if 
  232.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))   ; nur Richtung 0 .. 2pi zulaessig
  233.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  234.          (setq textht *AD:TEXTHOEHE*) ; vorher Konstant 1
  235.          (if (< richtg (/ pi 2))                 ; Textrichtg. in Abh. von Linienrichtg.
  236.            (progn (setq textri (/ (* richtg 180 ) pi))
  237.                   (setq textausri (if lraussen "_mr" "_ml"))
  238.            ) ; end progn
  239.            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
  240.                   (setq textausri (if lraussen "_ml" "_mr"))
  241.            ) ; end progn
  242.          ) ; end if
  243.                 (if lraussen (setq richtg (+ richtg pi)))
  244.          (setq cx_mb startx)
  245.          (setq minx (min liun_mb_x reun_mb_x))  ; es kann auch in negativer Richtung verlaufen
  246.          (setq maxx (max liun_mb_x reun_mb_x))
  247.          (while (<= cx_mb minx)                 ; ersten auf Rand im MB vorh. Wert ermitteln
  248.            (setq cx_mb (+ cx_mb delta_l))
  249.          ) ; end while cx_mb
  250.          (while (< cx_mb maxx)
  251.            (setq delta_m1 (- cx_mb liun_mb_x))  ; Streckenverhaeltnisse
  252.            (setq cx_af (+ liun_af_x (* (/ delta_m1 delta_m) delta_a)))
  253.            (setq ctext (rtos cx_mb 2 0))
  254.            (setq p1 (list cx_af cy_af))
  255.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  256.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  257.     ; Koordinatenbeschiftung anfόgen
  258.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  259.            (setq cx_mb (+ cx_mb delta_l))
  260.          ) ; end while cx_mb
  263.          ; oberer Rand, x werte
  264.          ;
  265.          (setq delta_m (- reob_mb_x liob_mb_x))
  266.          (setq delta_a (- reob_af_x liob_af_x))
  267.          (setq cy_af liob_af_y)
  268.          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
  269.            (setq richtg (+ alpha (/ pi 2.)))
  270.            (setq richtg (- alpha (/ pi 2.)))
  271.          ) ; end if 
  272.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  273.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  274.          (setq textht *AD:TEXTHOEHE*)
  275.          (if (< richtg (* pi 1.5))
  276.            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
  277.                   (setq textausri (if lraussen "_ml" "_mr"))
  278.            ) ; end progn
  279.            (progn (setq textri (/ (* richtg 180 ) pi))
  280.                   (setq textausri (if lraussen "_mr" "_ml"))
  281.            ) ; end progn
  282.          ) ; end if
  283.   (if lraussen (setq richtg (+ richtg pi)))
  284.          (setq cx_mb startx)
  285.          (setq minx (min liob_mb_x reob_mb_x))
  286.          (setq maxx (max liob_mb_x reob_mb_x))
  287.          (while (<= cx_mb minx)
  288.            (setq cx_mb (+ cx_mb delta_l))
  289.          ) ; end while cx_mb
  290.          (while (< cx_mb maxx)
  291.            (setq delta_m1 (- cx_mb liob_mb_x))
  292.            (setq cx_af (+ liob_af_x (* (/ delta_m1 delta_m) delta_a)))
  293.            (setq ctext (rtos cx_mb 2 0))
  294.            (setq p1 (list cx_af cy_af))
  295.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  296.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  297.     ; Koordinatenbeschiftung anfόgen
  298.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  299.            (setq cx_mb (+ cx_mb delta_l))
  300.          ) ; end while cx_mb
  302.          ; linker Rand, x werte
  303.          ;
  304.          (setq delta_m (- liob_mb_x liun_mb_x))
  305.          (setq delta_a (- liob_af_y liun_af_y))
  306.          (setq cx_af liun_af_x)
  307.          (if (> alpha pi)
  308.            (setq richtg (+ alpha (/ pi 2.)))
  309.            (setq richtg (- alpha (/ pi 2.)))
  310.          ) ; end if 
  311.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  312.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  313.          (setq textht *AD:TEXTHOEHE*)
  314.          (setq textri (/ (* richtg 180 ) pi))
  315.          (setq textausri (if lraussen "_mr" "_ml"))
  316.                (if lraussen (setq richtg (+ richtg pi)))
  317.          (setq cx_mb startx)
  318.          (setq minx (min liob_mb_x liun_mb_x))
  319.          (setq maxx (max liob_mb_x liun_mb_x))
  320.          (while (<= cx_mb minx)
  321.            (setq cx_mb (+ cx_mb delta_l))
  322.          ) ; end while cx_mb
  323.          (while (< cx_mb maxx)
  324.            (setq delta_m1 (- cx_mb liun_mb_x))
  325.            (setq cy_af (+ liun_af_y (* (/ delta_m1 delta_m) delta_a)))
  326.            (setq ctext (rtos cx_mb 2 0))
  327.            (setq p1 (list cx_af cy_af))
  328.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  329.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  330.     ; Koordinatenbeschiftung anfόgen
  331.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  332.            (setq cx_mb (+ cx_mb delta_l))
  333.          ) ; end while cx_mb
  335.          ; rechter Rand, x werte
  336.          ;
  337.          (setq delta_m (- reob_mb_x reun_mb_x))
  338.          (setq delta_a (- reob_af_y reun_af_y))
  339.          (setq cx_af reun_af_x)
  340.          (if (< alpha pi)
  341.            (setq richtg (+ alpha (/ pi 2.)))
  342.            (setq richtg (- alpha (/ pi 2.)))
  343.          ) ; end if 
  344.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  345.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  346.          (setq textht *AD:TEXTHOEHE*)
  347.          (setq textri (/ (* (- richtg pi) 180 ) pi))
  348.          (setq textausri (if lraussen "_ml" "_mr"))
  349.   (if lraussen (setq richtg (+ richtg pi)))
  350.         
  351.          (setq cx_mb startx)
  352.          (setq minx (min reob_mb_x reun_mb_x))
  353.          (setq maxx (max reob_mb_x reun_mb_x))
  354.          (while (<= cx_mb minx)
  355.            (setq cx_mb (+ cx_mb delta_l))
  356.          ) ; end while cx_mb
  357.          (while (< cx_mb maxx)
  358.            (setq delta_m1 (- cx_mb reun_mb_x))
  359.            (setq cy_af (+ reun_af_y (* (/ delta_m1 delta_m) delta_a)))
  360.            (setq ctext (rtos cx_mb 2 0))
  361.            (setq p1 (list cx_af cy_af))
  362.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  363.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  364.     ; Koordinatenbeschiftung anfόgen
  365.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  366.            (setq cx_mb (+ cx_mb delta_l))
  367.          ) ; end while cx_mb
  370.          ; linker Rand, y werte
  371.          ;
  372.          (setq delta_m (- liob_mb_y liun_mb_y))
  373.          (setq delta_a (- liob_af_y liun_af_y))
  374.          (setq cx_af liun_af_x)
  375.          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
  376.            (setq richtg (+ pi alpha))
  377.            (setq richtg (+ alpha))
  378.          ) ; end if 
  379.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  380.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  381.          (setq textht *AD:TEXTHOEHE*)
  382.          (setq textausri (if lraussen "_mr" "_ml"))
  383.          (setq textri (/ (* richtg 180 ) pi))
  384.   (if lraussen (setq richtg (+ richtg pi)))
  385.         
  386.          (setq cy_mb starty)
  387.          (setq miny (min liob_mb_y liun_mb_y))
  388.          (setq maxy (max liob_mb_y liun_mb_y))
  389.  
  390.          (while (<= cy_mb miny)
  391.            (setq cy_mb (+ cy_mb delta_l))
  392.          ) ; end while cy_mb
  393.          (while (< cy_mb maxy)
  394.            (setq delta_m1 (- cy_mb liun_mb_y))
  395.            (setq cy_af (+ liun_af_y (* (/ delta_m1 delta_m) delta_a)))
  396.            (setq ctext (rtos cy_mb 2 0))
  397.            (setq p1 (list cx_af cy_af))
  398.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  399.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  400.     ; Koordinatenbeschiftung anfόgen
  401.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  402.            (setq cy_mb (+ cy_mb delta_l))
  403.          ) ; end while cy_mb
  406.          ; rechter Rand, y werte
  407.          ;
  408.          (setq delta_m (- reob_mb_y reun_mb_y))
  409.          (setq delta_a (- reob_af_y reun_af_y))
  410.          (setq cx_af reun_af_x)
  411.          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
  412.            (setq richtg (+ alpha))
  413.            (setq richtg (+ pi alpha))
  414.          ) ; end if 
  415.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  416.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  417.          (setq textht *AD:TEXTHOEHE*)
  418.          (setq textri (/ (* (- richtg pi) 180 ) pi))
  419.          (setq textausri (if lraussen "_ml" "_mr"))
  420.   (if lraussen (setq richtg (+ richtg pi)))
  421.         
  422.          (setq cy_mb starty)
  423.          (setq miny (min reun_mb_y reob_mb_y))
  424.          (setq maxy (max reun_mb_y reob_mb_y))
  425.          (while (<= cy_mb miny)
  426.            (setq cy_mb (+ cy_mb delta_l))
  427.          ) ; end while cy_mb
  428.          (while (< cy_mb maxy)
  429.            (setq delta_m1 (- cy_mb reun_mb_y))
  430.            (setq cy_af (+ reun_af_y (* (/ delta_m1 delta_m) delta_a)))
  431.            (setq ctext (rtos cy_mb 2 0))
  432.            (setq p1 (list cx_af cy_af))
  433.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  434.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  435.     ; Koordinatenbeschiftung anfόgen
  436.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  437.            (setq cy_mb (+ cy_mb delta_l))
  438.          ) ; end while cy_mb
  440.          ; unterer Rand, y werte
  441.          ;
  442.          (setq delta_m (- reun_mb_y liun_mb_y))
  443.          (setq delta_a (- reun_af_x liun_af_x))
  444.          (setq cy_af liun_af_y)
  445.          (if (< alpha pi)
  446.            (setq richtg (+ alpha))
  447.            (setq richtg (+ pi alpha))
  448.          ) ; end if 
  449.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  450.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  451.          (setq textht *AD:TEXTHOEHE*)
  452.          (if (< richtg (/ pi 2))
  453.            (progn (setq textri (/ (* richtg 180 ) pi))
  454.                   (setq textausri (if lraussen "_mr" "_ml"))
  455.            ) ; end progn
  456.            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
  457.                   (setq textausri (if lraussen "_ml" "_mr"))
  458.            ) ; end progn
  459.          ) ; end if
  460.   (if lraussen (setq richtg (+ richtg pi)))
  461.         
  462.          (setq cy_mb starty)
  463.          (setq miny (min liun_mb_y reun_mb_y))
  464.          (setq maxy (max liun_mb_y reun_mb_y))
  465.          (while (<= cy_mb miny)
  466.            (setq cy_mb (+ cy_mb delta_l))
  467.          ) ; end while cy_mb
  468.          (while (< cy_mb maxy)
  469.            (setq delta_m1 (- cy_mb liun_mb_y))
  470.            (setq cx_af (+ liun_af_x (* (/ delta_m1 delta_m) delta_a)))
  471.            (setq ctext (rtos cy_mb 2 0))
  472.            (setq p1 (list cx_af cy_af))
  473.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  474.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  475.     ; Koordinatenbeschiftung anfόgen
  476.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  477.            (setq cy_mb (+ cy_mb delta_l))
  478.          ) ; end while cy_mb
  480.          ; oberer Rand, y werte
  481.          ;
  482.          (setq delta_m (- reob_mb_y liob_mb_y))
  483.          (setq delta_a (- reob_af_x liob_af_x))
  484.          (setq cy_af liob_af_y)
  485.          (if (< alpha pi)
  486.            (setq richtg (+ pi alpha))
  487.            (setq richtg (+ alpha))
  488.          ) ; end if 
  489.          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
  490.          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
  491.          (setq textht *AD:TEXTHOEHE*)
  492.          (if (< richtg (* pi 1.5))
  493.            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
  494.                   (setq textausri (if lraussen "_ml" "_mr"))
  495.            ) ; end progn
  496.            (progn (setq textri (/ (* richtg 180 ) pi))
  497.                   (setq textausri (if lraussen "_mr" "_ml"))
  498.            ) ; end progn
  499.          ) ; end if
  500.   (if lraussen (setq richtg (+ richtg pi)))
  501.        
  502.          (setq cy_mb starty)
  503.          (setq miny (min liob_mb_y reob_mb_y))
  504.          (setq maxy (max liob_mb_y reob_mb_y))
  505.          (while (<= cy_mb miny)
  506.            (setq cy_mb (+ cy_mb delta_l))
  507.          ) ; end while cy_mb
  508.          (while (< cy_mb maxy)
  509.            (setq delta_m1 (- cy_mb liob_mb_y))
  510.            (setq cx_af (+ liob_af_x (* (/ delta_m1 delta_m) delta_a)))
  511.            (setq ctext (rtos cy_mb 2 0))
  512.            (setq p1 (list cx_af cy_af))
  513.            (setq p2 (polar p1 richtg *AD:LINIENLAENGE*))
  514.            (setq pt (polar p1 richtg (1+ *AD:LINIENLAENGE*)))
  515.     ; Koordinatenbeschiftung anfόgen
  516.     (setq elemlist (append elemlist (createCvp p1 p2 textausri pt textht textri ctext)))
  517.            (setq cy_mb (+ cy_mb delta_l))
  518.          ) ; end while cy_mb
  519.  ) ;end progn
  520.   ) ; end if viewport
  521.   (createunnamedgroupfromelist elemlist)
  522.   (setq x (1+ x)
  523.  elemlist nil
  524.   )
  525. )
  526.  
  527. ;
  528. ; Ausgangsbedingungen wieder herstellen
  529. ;
  530. (setvar "blipmode" sblip)
  531. (setvar "cmdecho" scmde)
  532. (setvar "osmode" sosmode)
  533. (setvar "angbase" sangbase)
  534. (setvar "angdir" sangdir)
  535. (setvar "aunits" saunits) 
  536. (setq *error* alterror)
  537. ;(prompt "Koordinaten gesetzt")
  538. (princ)
  540. )
  542. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Errorhandling
  543. (defun my_error (msg)
  544.  (print (strcat "Fehler aufgetreten: " msg))
  545.  (command "_undo" "_back")
  546.  (setq *error* alterror)
  547.  (setvar "blipmode" sblip)
  548.  (setvar "cmdecho" scmde)
  549.  (setvar "osmode" sosmode)
  550.  (setvar "angbase" sangbase)
  551.  (setvar "angdir" sangdir)
  552.  (setvar "aunits" saunits) 
  554.  (princ)
  555. )
  557. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  558. ;;; Ab hier Routinen von Udo Hόbner
  559. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  560. (defun CreateBLockinPaperspace (Blockname InsertionPoint rotationangle value)
  561. (if (not
  562.     (or
  563.      (vl-catch-all-error-p
  564.             (setq BlkObj (vl-catch-all-apply
  565.                       'vla-InsertBlock
  566.                       (list
  567.                         (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
  568.                         (vlax-3d-point InsertionPoint)
  569.                         Blockname
  570.                         1 1 1 rotationangle
  571.                       )
  572.            )
  573.             )
  574.       )
  575.       (= :vlax-false (vlax-get-property blkObj "HasAttributes"))
  576.     )
  577.    )
  578.    (foreach Att (vlax-safearray->list (vlax-variant-value (vla-getAttributes BlkObj)))
  579.        (setq tagstring (strcase (vla-get-TagString  Att)))
  580.        (if (= tagstring (strcase "Koordinate"))
  581.           (vla-put-TextString att value)
  582. )
  583.    )
  584. )
  585. )
  586. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  587. (defun createunnamedgroupfromelist (elist / CNT GROUPNAME SARRAY)
  588.  (setq groupname (vla-add (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))) "*"))
  589.  (if elist
  590.    (progn
  591.      (setq cnt (length elist)
  592.     sArray (vlax-safearray-fill
  593.              (vlax-make-safearray vlax-vbobject (cons 0 (1- cnt)))
  594.              (mapcar 'vlax-ename->vla-object elist)
  595.            )
  596.      )
  597.      (vlax-invoke-method groupname "AppendItems" sArray)
  598.    )
  599.  )
  600. )
  601. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  602. (defun erzeugeGitterkreuze (startx starty maxx maxy delta_l AF
  603.                     / acaddoc y eleliste punktliste
  604.                     AFLISTE AFOBJ BREITE CENAF DREHWINKEL HOEHE MAXAF MINAF
  605.                     )
  606. (setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
  607. ; AF einschalten
  608. (vlax-invoke-Method (setq AFobj (vlax-ename->vla-object AF)) "Display" :vlax-true)
  609. ; Modellbereich im Ansichtsfenster aktiv schalten 
  610. (vla-put-mspace acaddoc :vlax-true)
  611. ; gewδhltes AF aktiv schalten  
  612. (setvar "CVPORT" (cdr (assoc 69 (setq AFliste (entget AF)))))
  613. (while (< startx maxx)
  614.   (setq y starty)
  615.   (while (< y maxy)
  616.     (setq punktliste (cons (ms2ps (list startx y) AF) punktliste))
  617.     (setq y (+ y delta_l))
  618.   )
  619.   (setq startx (+ startx delta_l))
  620. )
  621. (vla-put-mspace acaddoc :vlax-false) 
  622. ;jetzt Punkte zeichnen
  623. (setq cenAf  (cdr (assoc 10 AFliste))
  624.       breite (cdr (assoc 40 AFliste))
  625.       hoehe  (cdr (assoc 41 AFliste))
  626.       minAF  (list  (- (car cenaf) (* 0.5 breite))(- (cadr cenaf) (* 0.5 hoehe)))
  627.       maxAF  (list  (+ (car cenaf) (* 0.5 breite))(+ (cadr cenaf) (* 0.5 hoehe)))
  628.       Drehwinkel (cdr (assoc 51 AFliste))
  629. )
  630. (if (not (tblsearch "BLOCK" "Gitterkreuz"))
  631.    (Createblock "Gitterkreuz")
  632. )
  633. (foreach punkt punktliste
  634.   (if (and (> (car punkt)(car minAF))   (< (car punkt)(car maxAF))
  635.     (> (cadr punkt)(cadr minAF)) (< (cadr punkt)(cadr maxAF))
  636.       )                                           
  637.     (setq eleliste (cons (insertblock "Gitterkreuz" punkt drehwinkel) eleliste))
  638.   )     
  639. )   
  640. eleliste  ; Rόckgabewert
  641. )
  642. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
  643. (defun ms2ps (point AF)
  644.  (if (and af (= "VIEWPORT" (cdr (assoc 0 (entget AF)))))
  645.    (trans (trans point 0 2) 2 3)
  646.    nil
  647.  )
  648. )
  649. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
  650. (defun ps2ms (point AF)
  651.  (if (and af (= "VIEWPORT" (cdr (assoc 0 (entget AF)))))
  652.    (trans (trans point 3 2) 2 0)
  653.    nil
  654.  )
  655. )
  656. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
  657. (defun insertblock (Blockname punkt drehwinkel)
  658.  (entmake (list (cons 0 "INSERT")(cons 2 blockname) (cons 67 0) (cons 410 (getvar "ctab")) (cons 8 (getvar "clayer"))
  659.           (cons 10 punkt) (cons 41 1.0)(cons 42 1.0)(cons 43 1.0) (cons 50 drehwinkel))
  660.  )            
  661.  (entlast)
  662. )  
  663. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  664. (defun CreateBlock (Blockname)
  665.  (entmake (list (cons 0 "BLOCK")(cons 2 blockname)(cons 70 2)(list 10 0.0 0.0 0.0)))
  666.  (entmake '((0 . "LINE") (67 . 0) (410 . "Model") (8 . "0") (10 -4.0  0.0 0.0)(11 4.0 0.0 0.0)))
  667.  (entmake '((0 . "LINE") (67 . 0) (410 . "Model") (8 . "0") (10  0.0 -4.0 0.0)(11 0.0 4.0 0.0)))  
  668.  (entmake (list (cons 0 "ENDBLK"))) ; Rόckgabewert ist Block-ename
  669. )
  670. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  671. (defun MSAnsichtsfensterkoordinaten (AF)
  672. (setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
  673. (setq cenAf  (cdr (assoc 10 (setq AFliste (entget AF))))
  674.       breite (cdr (assoc 40 AFliste))
  675.       hoehe  (cdr (assoc 41 AFliste))
  676.       Drehwinkel (cdr (assoc 51 AFliste))
  677. )
  678. ; AF einschalten  
  679. (vlax-invoke-Method (setq AFobj (vlax-ename->vla-object AF)) "Display" :vlax-true)
  680. ; Modellbereich im Ansichtsfenster aktiv schalten 
  681. (vla-put-mspace acaddoc :vlax-true)
  682.  
  683. ; gewδhltes AF aktiv schalten  
  684. (setvar "CVPORT" (cdr (assoc 69 (setq AFliste (entget AF)))))
  685. (setq Punktliste
  686.       (list
  687.       (ps2ms (list  (- (car cenaf) (* 0.5 breite))(- (cadr cenaf) (* 0.5 hoehe))) AF) ; minAF
  688.       (ps2ms (list  (+ (car cenaf) (* 0.5 breite))(- (cadr cenaf) (* 0.5 hoehe))) AF) ;
  689.       (ps2ms (list  (+ (car cenaf) (* 0.5 breite))(+ (cadr cenaf) (* 0.5 hoehe))) AF) ; maxAF
  690.       (ps2ms (list  (- (car cenaf) (* 0.5 breite))(+ (cadr cenaf) (* 0.5 hoehe))) AF) ;
  691.       )
  692. )        
  693. (vla-put-mspace acaddoc :vlax-false)
  694. Punktliste
  695. )
  696.                              
  697. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  698. (prin1)

 
谢谢
205855t8w8ckzgw4g2ccle.jpg
回复

使用道具 举报

Commandobill

12

主题

395

帖子

384

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
60
发表于 2022-7-5 20:31:51 | 显示全部楼层
你可以使用“torient”，选择所有文本并点击“可读性最强”的文本
回复

使用道具 举报

prodromosm

107

主题

615

帖子

575

银币

中流砥柱

Rank: 25

铜币
521
发表于 2022-7-5 21:02:21 | 显示全部楼层
嗨，Commandobill。我能帮你更新代码吗？
 
谢谢
回复

使用道具 举报

返回列表 发帖

发表回复

高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

精选推荐

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-12 00:57 , Processed in 0.511183 second(s), 72 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表