[编程申请]：绘制箭头程序

duzeman

请编一程序用于绘制箭头，要求可输入箭头大小、箭头起点、箭头终点。

tuger

2. 
   
3. (defun c:zxjt (/ ang h2 jtl oldcm oldos pt1 pt2 pt3 scale)
   
4. 
   
5.   (setq oldcm (getvar "cmdecho"))
   
6.   (setq oldos (getvar "osmode"))
   
7.   (setvar "cmdecho" 0)
   
8.   (setvar "osmode" 0)
   
9.   (setq scale (getreal "\n请输入比例<100>:"))
   
10.   (if (= scale nil)
    
11.     (setq scale 100)
    
12.   )
    
13.   (setq h2 (* 0.8 scale)
    
14.         jtl (* 4 scale)
    
15.   )
    
16.   (setq pt1 (getpoint "\n请输入第一点:"))
    
17.   (setq pt3 (getpoint pt1 "\n请输入第二点:"))
    
18.   (setq ang (angle pt1 pt3))
    
19.   (setq pt2 (polar pt1 ang jtl))
    
20.   (command "pline" pt1 "w" 0 h2 pt2 "w" 0 0 pt3)
    
21.   (setvar "cmdecho" oldcm)
    
22.   (setvar "osmode" oldos)
    
23.   (princ "\n  ")
    
24.   (princ "\n继续使用pline命令")
    
25.   (princ)
    
26. )
    
27. 
    

<br /> (defun c:zxjt (/ ang h2 jtl oldcm oldos pt1 pt2 pt3 scale)<br /> <br />   (setq oldcm (getvar "cmdecho"))<br />   (setq oldos (getvar "osmode"))<br />   (setvar "cmdecho" 0)<br />   (setvar "osmode" 0)<br />   (setq scale (getreal "\n请输入比例<100>:"))<br />   (if (= scale nil)<br />     (setq scale 100)<br />   )<br />   (setq h2 (* 0.8 scale)<br />         jtl (* 4 scale)<br />   )<br />   (setq pt1 (getpoint "\n请输入第一点:"))<br />   (setq pt3 (getpoint pt1 "\n请输入第二点:"))<br />   (setq ang (angle pt1 pt3))<br />   (setq pt2 (polar pt1 ang jtl))<br />   (command "pline" pt1 "w" 0 h2 pt2 "w" 0 0 pt3)<br />   (setvar "cmdecho" oldcm)<br />   (setvar "osmode" oldos)<br />   (princ "\n  ")<br />   (princ "\n继续使用pline命令")<br />   (princ)<br /> )<br /> <br />

晓东工具箱 0.27 完整安装版
http://www.xdcad.net/down/show.php?id=227
我的工具箱下载地址http://www.xdcad.net/forum/showt ... y=&pagenumber=3

yicol

这些代码放在哪里才行呀

tuger

将上述代码存为hjt.lsp然后在cad中加载即可

luob72

有没有不用spline线绘箭头啊，一但改变线宽箭头也变了

zxq0220

最初由 luob72 发布
[B]有没有不用spline线绘箭头啊，一但改变线宽箭头也变了 [/B]

您可以用LEADER命令画单箭头。
箭头的大小由尺寸标注变量控制。
1、为简化使用，也可以用下面的小程序画单箭头。
[php]
(DEFUN C:MLEADER ()
(COMMAND "LEADER" PAUSE PAUSE "" "" "N")
(PRINC)
)
[/php]
2、或用下面的小程序画双箭头。
[php]
(DEFUN C:DLEADER ()
(IF (SETQ PT1 (GETPOINT "\nFirst extension line origin :"))
  (IF (SETQ PT2 (GETPOINT PT1 "\nSecond extension line origin :")) (PROGN
   (SETQ OLDSE1 (GETVAR "DIMSE1")
         OLDSE2 (GETVAR "DIMSE2"))
   (SETVAR "DIMSE1" 1)
   (SETVAR "DIMSE2" 1)
   (COMMAND "DIMALIGNED" PT1 PT2 "T" " " PT2)
   (SETVAR "DIMSE1" OLDSE1)
   (SETVAR "DIMSE2" OLDSE2)
  ))
)
(PRINC)
)
[/php]

xxming

;可选择线段的顶点绘制箭头
(defun ureal (bit kwd msg def / inp)

(if def

(setq msg (strcat "\n" msg "<" (rtos def) ">: ")

bit (* 2 (fix (/ bit 2)))

)

(if (= " " (substr msg (strlen msg) 1))

(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))

(setq msg (strcat "\n" msg ": "))

)

)

(initget bit kwd)

(setq inp (getreal msg))

(if inp inp def)

)


(defun upoint (bit kwd msg def bpt / inp)

(if def

(setq pts (strcat

(rtos (car def))

","

(rtos (cadr def))

(if

(and (caddr def) (= 0 (getvar "FLATLAND")))

(strcat "," (rtos (caddr def)))

""

)

)

msg (strcat "\n" msg "<" pts ">: ")

bit (* 2 (fix (/ bit 2)))

)

(if (= " " (substr msg (strlen msg) 1))

(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))

(setq msg (strcat "\n" msg ": "))

)

)

(initget bit kwd)

(setq inp

(if bpt

(getpoint msg bpt)

(getpoint msg)

)

)

(if inp inp def)

)

(setq cm(getvar "cmdecho"))

(setvar "cmdecho" 0)


(defun C:AR ( / #dwgsc w v pt1 pt2 pt3 )

(if(= arscl nil)(setq arscl 0.1875))

(setq #dwgsc(getvar "DIMSCALE")

W(getvar "PLINEWID")

V(getvar "OSMODE")

L(getvar "CLAYER"))

(setq arscl(ureal 7 "" "请输入箭头长度" arscl))

(setvar "OSMODE" 1)

(setq pt1 (upoint 1 "" "指定箭头顶点" nil nil))

(setvar "OSMODE" 512)


(setq PT(entsel "\n选择直线上要画箭头一端的任意一点"))

(setq PT2(cadr PT))

(setq ED(entget(car PT)))

(setq PT3 (polar PT1 (angle PT1 PT2) (* #dwgsc arscl)))

(command "PLINE" pt1 "w" "0" (* #dwgsc (/ arscl 3)) pt3 "")

(setvar "OSMODE" V)

(setvar "CLAYER" L)

(setvar "plinewid" W)

(princ)

)

(setvar "cmdecho" cm)

(princ)

fwkkun

用命令"PL"可以的,不知行不行?

xyp1964

先画线，后画箭头：
[php]
;;;加载通用函数
;;;下载：http://www.xdcad.net/forum/showthread.php?s=&threadid=325268
(load "xyp_lib")

(defun c:test ()
  (cmdla0)
  (setbl)
  (setq        wide (* 200 sc)
        leng (* 500 sc)
        mode 1
  )
  (while (not (setq pt1 (getpoint "\n请输入起点 : "))))
  (while (not (setq pt2 (getpoint pt1 "\n请输入下一点 : "))))
  (grvecs (list 1 pt1 pt2))
  (command "pline" pt1)
  (while mode
    (setq pt3 (getpoint pt2 "\n请输入下一点<退出> : "))
    (if        pt3
      (progn
        (command pt2)
        (grvecs (list 1 pt2 pt3))
        (setq pt1 pt2
              pt2 pt3
        )
      )
      (setq mode nil)
    )
  )
  (setq        ang  (angle pt1 pt2)
        dist (distance pt1 pt2)
        pt0  (polar pt1 ang (- dist leng))
  )
  (command pt0)
  (command "w" wide 0 pt2)
  (command "")
  (redraw)
  (cmdla1)
)
[/php]

dabingrain

(vl-load-com)
(defun c:ad( / ss sum ent i )
(setq ss (ssget '((0 . "lwpolyline,polyline,line"))))
(setq sum 0)
(setq i 0)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq ent (vlax-ename->vla-object ent))
(setq sum (+ sum (vlax-curve-getDistAtPoint ent (vlax-curve-getEndPoint ent))))
(setq i (1+ i))
)   
  (prompt "\n选定的直线根数： " )
(prin1 i)  
   (prompt "\n选定的直线总长： " )
(prin1 sum)
   (prompt "\n选定的直线平均长： " )
(/ sum i)  
)

以上内容与主题有何关系？by xyp1964[/COLOR]