[求助]请高手添加：将计算结果保存至剪贴板

sy100

 

 

下面这段程序由网络收集，感谢原作者！

 

   请求高手在保持原程序功能不变的情况下添加：“将程序计算结果自动复制到剪贴板，按回车或空格键退出”的功能。谢谢！

 

(defun c:jxjs (/ p1 p2 dx dy ox jd fx dcl_1)
  (command "undo" "be")
  (initget 1)
  (setq p1 (getpoint "\n请选择两圆弧交点: "))
  (initget 1)
  (setq p2 (getpoint "\n请选择圆心: "))
　(setq dx (- (car p2) (car p1))
 dy (- (cadr p2) (cadr p1))
 ox (sqrt (+ (* dx dx) (* dy dy)));;;两点间距离
 jd (/ (* (* 2 (- (/ pi 4) (atan ox 25)))180)pi);;;两结构面交线的倾角
 fx (- 90 (* (/ (angle p1 p2 )pi)180));;;两结构面交线倾向
  )
  (if (< fx 0)
    (setq fx (+ 360 fx))
  )
  (setq jd (strcat  (rtos fx 2 1)"°∠" (rtos jd 2 1)"°"))
  (princ "\n两结构面交线的产状: ")
  (princ jd)
 
  (setq dcl_1 (load_dialog "bg_jllx.dcl"))
  (if (not (new_dialog "dcl_bg_cpt" dcl_1))(exit))
  (set_tile "text3" jd)
  (action_tile "accept" " (done_dialog) ")
  (start_dialog)
  (unload_dialog dcl_1)

  (command "undo" "e")
  (princ)
)

sy100

自己顶一下。。。

mccad

用这个函数改造到VBA用就可以。

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=29218

gufeng

[Post=10]

3. (defun c:jxjs (/ p1 p2 dx dy ox jd fx dcl_1 jdt i)
4. (vl-load-com)
5.   (defun PutClipText (str / html result)
6.     (if (= 'STR (type str))
7.       (progn
8. (setq html   (vlax-create-object "htmlfile")
9.        result (vlax-invoke
10.          (vlax-get (vlax-get html 'ParentWindow)
11.      'ClipBoardData
12.          )
13.          'setData
14.          "Text"
15.          str
16.        )
17. )
18. (vlax-release-object html)
19. str
20.       )
21.     )
22.   )
23. ;;;  (command "undo" "be")
24. ;;;  (initget 1)
25.   (setq jdt "")
26.   (setq i 0)
27.   (while (and (setq p1 (getpoint "\n请选择两圆弧交点:<回车或空格键退出> "))
28.        (setq p2 (getpoint "\n请选择圆心: "))
29.   )
30.     (progn
31. ;;;      (initget 1)
32.       (setq dx (- (car p2) (car p1))
33.      dy (- (cadr p2) (cadr p1))
34.      ox (sqrt (+ (* dx dx) (* dy dy)))
35. ;;;两点间距离
36.      jd (/ (* (* 2 (- (/ pi 4) (atan ox 25))) 180) pi)
37. ;;;两结构面交线的倾角
38.      fx (- 90 (* (/ (angle p1 p2) pi) 180))
39. ;;;两结构面交线倾向
40.       )
41.       (if (< fx 0)
42. (setq fx (+ 360 fx))
43.       )
44.       (setq jd (strcat (rtos fx 2 1) "°∠" (rtos jd 2 1) "°"))
45.       (setq jdt (strcat jdt jd "\r\n"))
46.       (princ (strcat "\n两结构面交线的产状: "
47.        jd
48.        "   当前记录:"
49.        (itoa (setq i (1+ i)))
50.       )
51.       )
52.       (PutClipText jdt)
53.     )
54.   )
55. ;;;  (setq dcl_1 (load_dialog "bg_jllx.dcl"))
56. ;;;  (if (not (new_dialog "dcl_bg_cpt" dcl_1))
57. ;;;    (exit)
58. ;;;  )
59. ;;;  (set_tile "text3" jd)
60. ;;;  (action_tile "accept" " (done_dialog) ")
61. ;;;  (start_dialog)
62. ;;;  (unload_dialog dcl_1)
63. ;;;  (command "undo" "e")
64.   (princ)
65. )

(defun c:jxjs (/ p1 p2 dx dy ox jd fx dcl_1 jdt i) (vl-load-com)   (defun PutClipText (str / html result)     (if (= 'STR (type str))       (progn (setq html   (vlax-create-object "htmlfile")        result (vlax-invoke          (vlax-get (vlax-get html 'ParentWindow)      'ClipBoardData          )          'setData          "Text"          str        ) ) (vlax-release-object html) str       )     )   ) ;;;  (command "undo" "be") ;;;  (initget 1)   (setq jdt "")   (setq i 0)   (while (and (setq p1 (getpoint "\n请选择两圆弧交点:<回车或空格键退出> "))        (setq p2 (getpoint "\n请选择圆心: "))   )     (progn ;;;      (initget 1)       (setq dx (- (car p2) (car p1))      dy (- (cadr p2) (cadr p1))      ox (sqrt (+ (* dx dx) (* dy dy))) ;;;两点间距离      jd (/ (* (* 2 (- (/ pi 4) (atan ox 25))) 180) pi) ;;;两结构面交线的倾角      fx (- 90 (* (/ (angle p1 p2) pi) 180)) ;;;两结构面交线倾向       )       (if (< fx 0) (setq fx (+ 360 fx))       )       (setq jd (strcat (rtos fx 2 1) "°∠" (rtos jd 2 1) "°"))       (setq jdt (strcat jdt jd "\r\n"))       (princ (strcat "\n两结构面交线的产状: "        jd        "   当前记录:"        (itoa (setq i (1+ i)))       )       )       (PutClipText jdt)     )   ) ;;;  (setq dcl_1 (load_dialog "bg_jllx.dcl")) ;;;  (if (not (new_dialog "dcl_bg_cpt" dcl_1)) ;;;    (exit) ;;;  ) ;;;  (set_tile "text3" jd) ;;;  (action_tile "accept" " (done_dialog) ") ;;;  (start_dialog) ;;;  (unload_dialog dcl_1) ;;;  (command "undo" "e")   (princ) )

[/Post]

sy100

完全达到应用要求，衷心感谢给予帮助的好心人！！

qyming

好，正需要