flyfox1047 发表于 2022-7-5 23:51:42

帮我把这个口齿不清写得像t


 
我有两个类似的程序，图片有差异，有人帮我改一下吧非常感谢。
 
带箭头的引线端点
十、 Y值必须有加号或减号
 
谢谢
bzx。lsp
BZ。LSP

flyfox1047 发表于 2022-7-6 00:05:02

有人帮我换吗非常感谢！

ymg3 发表于 2022-7-6 00:09:41

flyfox1047，
 
对于bz。lsp只需添加以下内容即可获得加号（if（minusp（car p1））“”“+”）
 
ymg公司
 
修订代码如下：
 
 

(VL-LOAD-COM)
(or copy_reactor
   (setq copy_reactor (vlr-command-reactor "copy_reactor" '((:vlr-commandEnded . copy_1))))
)
(setvar "copymode" 1)
(defun C:bz (/ p1 p2 pt1 pt2 pts mSpace Mtextobj)
(setq mSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq p1 (getpoint "\nÑ¡ÔñÒª±ê×¢µÄµã:"))
(setq p2 (getpoint p1 "\nÑ¡Ôñ±ê×¢ÎÄ×ÖλÖÃ:"))
(setq pt2 (vlax-3D-point p2))
(setq Mtextobj (vla-addMtext
                  mSpace
                  pt2
                  0.0
                  (strcat "X=" (if (minusp (car p1)) "" "+" )(rtos (car p1) 2 1) "\nY=" (if (minusp (cadr p1)) "" "+" )(rtos (cadr p1) 2 1))
                )
)
(setq MtextH (* (getvar "DIMSCALE") (getvar "DIMTXT"))) ;ÎÄ×ָ߶ÈΪµ±Ç°±êÖùÑùʽÎÄ×ָ߶È*È«¾Ö±ÈÀý
(vlax-put-property Mtextobj 'Height MtextH)
(vlax-put-property Mtextobj 'LineSpacingDistance (+ MtextH 1))
(if (> (car p1) (car p2))
   (vlax-put-property Mtextobj 'AttachmentPoint 9)
   (vlax-put-property Mtextobj 'AttachmentPoint 7)
)
(vlax-put-property Mtextobj 'InsertionPoint pt2)
(setq pts (vlax-make-safearray vlax-vbDouble '(0 . 5)))
(vlax-safearray-fill
   pts
   (list (car p1) (cadr p1) (caddr p1) (car p2) (cadr p2) (caddr p2))
)
(setq leaderobj (vla-Addleader mSpace pts Mtextobj acLineWithArrow))
(setq vlr-objgx (vlr-object-reactor (list leaderobj) "" '((:vlr-modified . gx))))
(setq vlr-objcopy (vlr-object-reactor (list leaderobj) "" '((:vlr-copied . copy_2))))
(princ)
)

(defun copy_2 (obj vlrobj data)
(if (/= (car data) 0)
   (setq newename (car data))
)
)

(defun copy_1 (vlrobj data)
(if (wcmatch (strcase (car data)) "*COPY*")
   (progn (setq newobj (vlax-ename->vla-object newename))
          (setq vlr-objgx (vlr-object-reactor (list newobj) "" '((:vlr-modified . gx))))
          (setq vlr-objcopy (vlr-object-reactor (list newobj) "" '((:vlr-copied . copy_2))))
          (princ)
   )
)
)

(defun gx (obj vlrobj data / p1 pt1 Aobj)
(if (and (not (vlax-erased-p obj)) (setq Aobj (vlax-get-property obj 'Annotation))) ;Åж϶ÔÏóÊÇ·ñ±»É¾³ý
   (progn (setq pt1 (vlax-get-property obj 'Coordinate 0))
          (setq p1 (vlax-safearray->list (vlax-variant-value pt1)))
          (vlax-put-property
            Aobj
            'TextString
            (strcat "X=" (if (minusp (car p1)) "" "+" )(rtos (car p1) 2 1) "\nY=" (if (minusp (car p1)) "" "+" )(rtos (cadr p1) 2 1))
          )
   )
)
)


flyfox1047 发表于 2022-7-6 00:12:32

您好，ymg3，谢谢您的帮助，appload-始终显示：无函数定义：COPY\u 1，现在我使用autocad 2007

ymg3 发表于 2022-7-6 00:23:27

这是为加号修改的第二个。
 
现在，为了我的生活，你为什么要使用这样过时的惯例。
这一个实际上是画了一条线和一个十字架，有点模仿
领导者。
 
这就是您应该使用“LEADER”来完成该任务的内容。
 
ymg公司
 

(defun C:bz (/ AcadObject AcadDocument mSpace h1 len inp kflag obj1 p1 p2 x y anglel inpx inpy lasp olay tx ty)
(princ "\n×ø±ê±ê×¢V1.10£¬Ö´ÐÐÃüÁbz")
(setq olay (getvar "clayer"))
(setvar "cmdecho" 0)
;;;ÉèÖÃActiveXµÄ¹¤×÷»·¾³‰äÁ¿
(VL-LOAD-COM)
(setq AcadObject   (vlax-get-acad-object)
       AcadDocument (vla-get-ActiveDocument Acadobject)
       mSpace       (vla-get-ModelSpace Acaddocument)
)
(setvar "cmdecho" 0)
(setq kflag t)
(while kflag
   (chklay)
   (initget "S")
   (if (not h)
   (setq h '1.5)
   )
   (setq
   p (getpoint (strcat "\nÖ¸¶¨Æðµã/¡¾S¡¿ÉèÖÃ×Ö¸ß[<" (rtos h) ">]"))
   )
   (if (= p "S")
   (setq h1 (getreal (strcat "\nÊäÈëÐÂ×Ö¸ß<" (rtos h) ">")))
   )
   (if h1
   (setq h h1)
   )
   (if (and (/= p "S") p)
   (progn
       (drawcross p) ;ÔÚ´æÔÚpµÄÇé¿öÏ»*Ê®×Ö¹â±ê
       (prompt "\nÖ¸¶¨ÏÂÒ»µã£º")
       (command "line" p (getdist p) "")
       (setq obj1 (vlax-ename->vla-object (entlast)))
       (if (= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
         (setq p1 (vlax-get obj1 'startpoint))
         (setq p2 (vlax-get obj1 'endpoint))
         (setq x (strcat "X=" (if (minusp (car p1)) "" "+" ) (rtos (car p1) 2 3)))
         (setq y (strcat "Y=" (if (minusp (cadr p1)) "" "+" ) (rtos (cadr p1) 2 3)))
         (setq len (max (strlen x) (strlen y)))
         (setq anglel (vlax-get obj1 'Angle))
         (if (and (> anglel (/ pi 2)) (< anglel (/ (* pi 1.5))))
             ;;ÔÚµÚ¶þ¡¢ÈýÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 (angtof "180") (* (* 0.6 h) len)))
               (setq inp (polar lasp '0 (* 0.2 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (setq tx (vla-AddText mSpace x (vlax-3d-point inpx) h))
               (setq ty (vla-AddText mSpace y (vlax-3d-point inpy) h))
             ) ;progn
             ;;ÔÚµÚÒ»¡¢ËÄÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 '0 (* (* 0.7 h) len)))
               (setq inp (polar p2 '0 (* 0.3 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (vla-AddText mSpace x (vlax-3d-point inpx) h)
               (vla-AddText mSpace y (vlax-3d-point inpy) h)
             ) ;progn
         )
         )
       ) ;if
       (if (/= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
         (princ "\nÏ߶λæÖÆ´íÎó£¬ÖØлæÖÆ»ò<Í˳ö>")
         (command "_.erase" (entlast) "")
         )
       )
   )
   (if (/= p "S")
       (setq kflag nil) ;ÊäÈëSºó²»ÔÊÐíÌÓÀëÑ*»·
   )
   )
) ;while
(setvar "clayer" olay)
)

(defun chklay (/ layflag)
(setq layflag (tblsearch "layer" "×ø±ê±ê×¢"))
(if (not layflag)
   (command "_layer" "m" "×ø±ê±ê×¢" "c" "3" "" "")
)
(setvar "clayer" "×ø±ê±ê×¢")
)

(defun drawcross (p / px1 px2 py1 py2)
(setq eflag (tblsearch "block" "×ø±êÊ®×Ö±ê¼Ç")) ;¿é´æÔÚ±ê¼Ç
(if (not eflag) ;²»´æÔÚÊ®×Ö±ê¼ÇµÄ¿é£¬Ôò°´ÈçÏ´´½¨
   (progn
   (setq px1 (polar p (angtof "180") 1.5) ;×ó×ø±ê
         px2 (polar p '0 '1.5) ;ÓÒ×ø±ê
         py1 (polar p (angtof "90") '1.5) ;ÉÏ×ø±ê
         py2 (polar p (angtof "270") '1.5) ;ÏÂ×ø±ê
   )
   (entmake (list
                (cons 0 "BLOCK")
                (cons 2 "×ø±êÊ®×Ö±ê¼Ç")
                (cons 70 0)
                (cons 10 p)
            )
   )
   (entmake (list
                (cons 0 "LINE")
                (cons 10 px1)
                (cons 11 px2)
            )
   )
   (entmake (list
                (cons 0 "LINE")
                (cons 10 py1)
                (cons 11 py2)
            )
   )
   (entmake '((0 . "endblk")))
   ) ;progn
) ;if
(command "_insert" "×ø±êÊ®×Ö±ê¼Ç" p (/ h 3.5) (/ h 3.5) "0")
)


ymg3 发表于 2022-7-6 00:29:10

flyfox1047，
 
像下面这样简单的事情实际上和你想要的差不多，
同时保持风格定义的优势。
 
ymg公司
 

(defun c:lb (/ p x y str)
(while (setq p (getpoint "\nPick Point: "))
    (setq   x (strcat "X = " (if (minusp (car p)) """+" ) (rtos (car   p))))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadrp))))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p))))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
)
)

flyfox1047 发表于 2022-7-6 00:35:52


(defun C:bz (/ AcadObject AcadDocument mSpace h1 len inp kflag obj1 p1 p2 x y anglel inpx inpy lasp olay tx ty)
(princ "\n×ø±ê±ê×¢V1.10£¬Ö´ÐÐÃüÁbz")
(setq olay (getvar "clayer"))
(setvar "cmdecho" 0)
;;;ÉèÖÃActiveXµÄ¹¤×÷»·¾³‰äÁ¿
(VL-LOAD-COM)
(setq AcadObject   (vlax-get-acad-object)
       AcadDocument (vla-get-ActiveDocument Acadobject)
       mSpace       (vla-get-ModelSpace Acaddocument)
)
(setvar "cmdecho" 0)
(setq kflag t)
(while kflag
   (chklay)
   (initget "S")
   (if (not h)
   (setq h '1.5)
   )
   (setq
   p (getpoint (strcat "\nÖ¸¶¨Æðµã/¡¾S¡¿ÉèÖÃ×Ö¸ß[<" (rtos h) ">]"))
   )
   (if (= p "S")
   (setq h1 (getreal (strcat "\nÊäÈëÐÂ×Ö¸ß<" (rtos h) ">")))
   )
   (if h1
   (setq h h1)
   )
   (if (and (/= p "S") p)
   (progn
       (drawcross p) ;ÔÚ´æÔÚpµÄÇé¿öÏ»*Ê®×Ö¹â±ê
       (prompt "\nÖ¸¶¨ÏÂÒ»µã£º")
       (command "line" p (getdist p) "")
       (setq obj1 (vlax-ename->vla-object (entlast)))
       (if (= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
         (setq p1 (vlax-get obj1 'startpoint))
         (setq p2 (vlax-get obj1 'endpoint))
         (setq x (strcat "X=" (if (minusp (car p1)) "" "+" ) (rtos (car p1) 2 3)))
         (setq y (strcat "Y=" (if (minusp (cadr p1)) "" "+" ) (rtos (cadr p1) 2 3)))
         (setq len (max (strlen x) (strlen y)))
         (setq anglel (vlax-get obj1 'Angle))
         (if (and (> anglel (/ pi 2)) (< anglel (/ (* pi 1.5))))
             ;;ÔÚµÚ¶þ¡¢ÈýÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 (angtof "180") (* (* 0.6 h) len)))
               (setq inp (polar lasp '0 (* 0.2 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (setq tx (vla-AddText mSpace x (vlax-3d-point inpx) h))
               (setq ty (vla-AddText mSpace y (vlax-3d-point inpy) h))
             ) ;progn
             ;;ÔÚµÚÒ»¡¢ËÄÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 '0 (* (* 0.7 h) len)))
               (setq inp (polar p2 '0 (* 0.3 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (vla-AddText mSpace x (vlax-3d-point inpx) h)
               (vla-AddText mSpace y (vlax-3d-point inpy) h)
             ) ;progn
         )
         )
       ) ;if
       (if (/= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
         (princ "\nÏ߶λæÖÆ´íÎó£¬ÖØлæÖÆ»ò<Í˳ö>")
         (command "_.erase" (entlast) "")
         )
       )
   )
   (if (/= p "S")
       (setq kflag nil) ;ÊäÈëSºó²»ÔÊÐíÌÓÀëÑ*»·
   )
   )
) ;while
(setvar "clayer" olay)
)

(defun chklay (/ layflag)
(setq layflag (tblsearch "layer" "×ø±ê±ê×¢"))
(if (not layflag)
   (command "_layer" "m" "×ø±ê±ê×¢" "c" "3" "" "")
)
(setvar "clayer" "×ø±ê±ê×¢")
)

(defun drawcross (p / px1 px2 py1 py2)
(setq eflag (tblsearch "block" "×ø±êÊ®×Ö±ê¼Ç")) ;¿é´æÔÚ±ê¼Ç
(if (not eflag) ;²»´æÔÚÊ®×Ö±ê¼ÇµÄ¿é£¬Ôò°´ÈçÏ´´½¨
   (progn
   (setq px1 (polar p (angtof "180") 1.5) ;×ó×ø±ê
         px2 (polar p '0 '1.5) ;ÓÒ×ø±ê
         py1 (polar p (angtof "90") '1.5) ;ÉÏ×ø±ê
         py2 (polar p (angtof "270") '1.5) ;ÏÂ×ø±ê
   )
   (entmake (list
                (cons 0 "BLOCK")
                (cons 2 "×ø±êÊ®×Ö±ê¼Ç")
                (cons 70 0)
                (cons 10 p)
            )
   )
   (entmake (list
                (cons 0 "LINE")
                (cons 10 px1)
                (cons 11 px2)
            )
   )
   (entmake (list
                (cons 0 "LINE")
                (cons 10 py1)
                (cons 11 py2)
            )
   )
   (entmake '((0 . "endblk")))
   ) ;progn
) ;if
(command "_insert" "×ø±êÊ®×Ö±ê¼Ç" p (/ h 3.5) (/ h 3.5) "0")
)



 
嗨，ymg，谢谢你！我不知道为什么文字会乱码，不能正常工作

flyfox1047 发表于 2022-7-6 00:42:31


(defun c:lb (/ p x y str)
(while (setq p (getpoint "\nPick Point: "))
    (setq   x (strcat "X = " (if (minusp (car p)) """+" ) (rtos (car   p))))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadrp))))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p))))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
)
)

 
这个代码很好！简洁，再次感谢你能帮我在这段代码中创建一个暗层，层的颜色是绿色的，把dimleader放入暗层，暗精度保留两位小数吗

marko_ribar 发表于 2022-7-6 00:51:01


(defun c:lb ( / p x y str )
(if (not (tblsearch "LAYER" "dim"))
   (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "dim") (70 . 0) (62 . 3) (6 . "Continuous")))
   (prompt "\nLayer : \"dim\" already exist - setting it to current and proceeding with routine...")
)
(setvar 'clayer "dim")
(while (setq p (getpoint "\nPick Point - ENTER to finish: "))
    (setq   x (strcat "X = " (if (minusp (car p)) """+" ) (rtos (car p) 2 2)))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadr p) 2 2)))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p) 2 2)))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
)
(princ)
)

flyfox1047 发表于 2022-7-6 00:54:23

 
很不错的！marko_ribar，谢谢！
页: [1]
查看完整版本: 帮我把这个Lisp程序写得像t