乐筑天下

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

[编程交流] OutlineObjects LISP - Retain C

[复制链接]
ctrlaltdel

13

主题

57

帖子

45

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
70
发表于 2022-7-5 17:08:08 | 显示全部楼层 |阅读模式
I have used this outlineobjects from LeeMac to mainly combine revision clouds.
Recently the clouds are now in Calligraphy style. When using the lisp, the Calligraphy style lines becomes normal thin lines. Can advise how to make it outline but retain Calligraphy style.
 
Cheers
 
http://lee-mac.com/outlineobjects.html
 
  1.  [list=1]
  2. [*];;-----------------------=={ Outline Objects  }==-----------------------;;
  3. [*];;                                                                      ;;
  4. [*];;  This program enables the user to generate one or more closed        ;;
  5. [*];;  polylines or regions outlining all objects in a selection.          ;;
  6. [*];;                                                                      ;;
  7. [*];;  Following a valid selection, the program calculates the overall     ;;
  8. [*];;  rectangular extents of all selected objects and constructs a        ;;
  9. [*];;  temporary rectangular polyline offset outside of such extents.      ;;
  10. [*];;                                                                      ;;
  11. [*];;  Using a point located within the offset margin between the extents  ;;
  12. [*];;  of the selection and temporary rectangular frame, the program then  ;;
  13. [*];;  leverages the standard AutoCAD BOUNDARY command to construct        ;;
  14. [*];;  polylines and/or regions surrounding all 'islands' within the       ;;
  15. [*];;  temporary bounding frame.                                           ;;
  16. [*];;                                                                      ;;
  17. [*];;----------------------------------------------------------------------;;
  18. [*];;  Author:  Lee Mac, Copyright © 2014  -  www.lee-mac.com              ;;
  19. [*];;----------------------------------------------------------------------;;
  20. [*];;  Version 1.0    -    2014-11-30                                      ;;
  21. [*];;                                                                      ;;
  22. [*];;  - First release.                                                    ;;
  23. [*];;----------------------------------------------------------------------;;
  24. [*];;  Version 1.1    -    2016-01-23                                      ;;
  25. [*];;                                                                      ;;
  26. [*];;  - Added option to erase original objects.                           ;;
  27. [*];;----------------------------------------------------------------------;;
  28. [*](defun c:outline ( / *error* idx sel )
  29. [*]    (defun *error* ( msg )
  30. [*]        (LM:endundo (LM:acdoc))
  31. [*]        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
  32. [*]            (princ (strcat "\nError: " msg))
  33. [*]        )
  34. [*]        (princ)
  35. [*]    )
  36. [*]    (if (setq sel (ssget))
  37. [*]        (progn
  38. [*]            (LM:startundo (LM:acdoc))
  39. [*]            (LM:outline sel)
  40. [*]            (initget "Yes No")
  41. [*]            (if (/= "No" (getkword "\nErase original objects? [Yes/No] : "))
  42. [*]                (repeat  (setq idx (sslength sel))
  43. [*]                    (entdel (ssname sel (setq idx (1- idx))))
  44. [*]                )
  45. [*]            )
  46. [*]            (LM:endundo (LM:acdoc))
  47. [*]        )
  48. [*]    )
  49. [*]    (princ)
  50. [*])
  51. [*];; Outline Objects  -  Lee Mac
  52. [*];; Attempts to generate a polyline outlining the selected objects.
  53. [*];; sel - [sel] Selection Set to outline
  54. [*];; Returns: [sel] A selection set of all objects created
  55. [*](defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
  56. [*]    (if (setq box (LM:ssboundingbox sel))
  57. [*]        (progn
  58. [*]            (setq app (vlax-get-acad-object)
  59. [*]                  dis (/ (apply 'distance box) 20.0)
  60. [*]                  lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
  61. [*]                  are (apply '* (apply 'mapcar (cons '- (reverse lst))))
  62. [*]                  dis (* dis 1.5)
  63. [*]                  ent
  64. [*]                (entmakex
  65. [*]                    (append
  66. [*]                       '(   (000 . "LWPOLYLINE")
  67. [*]                            (100 . "AcDbEntity")
  68. [*]                            (100 . "AcDbPolyline")
  69. [*]                            (090 . 4)
  70. [*]                            (070 . 1)
  71. [*]                        )
  72. [*]                        (mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
  73. [*]                           '(   (caar   cadar)
  74. [*]                                (caadr  cadar)
  75. [*]                                (caadr cadadr)
  76. [*]                                (caar  cadadr)
  77. [*]                            )
  78. [*]                        )
  79. [*]                    )
  80. [*]                )
  81. [*]            )
  82. [*]            (apply 'vlax-invoke
  83. [*]                (vl-list* app 'zoomwindow
  84. [*]                    (mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
  85. [*]                )
  86. [*]            )
  87. [*]            (setq cmd (getvar 'cmdecho)
  88. [*]                  enl (entlast)
  89. [*]                  rtn (ssadd)
  90. [*]            )
  91. [*]            (while (setq tmp (entnext enl)) (setq enl tmp))
  92. [*]            (setvar 'cmdecho 0)
  93. [*]            (command
  94. [*]                "_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
  95. [*]                (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
  96. [*]            )
  97. [*]            (while (< 0 (getvar 'cmdactive)) (command ""))
  98. [*]            (entdel ent)
  99. [*]            (while (setq enl (entnext enl))
  100. [*]                (if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
  101. [*]                         (equal (vla-get-area obj) are 1e-4)
  102. [*]                    )
  103. [*]                    (entdel enl)
  104. [*]                    (ssadd  enl rtn)
  105. [*]                )
  106. [*]            )
  107. [*]            (vla-zoomprevious app)
  108. [*]            (setvar 'cmdecho cmd)
  109. [*]            rtn
  110. [*]        )
  111. [*]    )
  112. [*])
  113. [*];; Selection Set Bounding Box  -  Lee Mac
  114. [*];; Returns a list of the lower-left and upper-right WCS coordinates of a
  115. [*];; rectangular frame bounding all objects in a supplied selection set.
  116. [*];; s - [sel] Selection set for which to return bounding box
  117. [*](defun LM:ssboundingbox ( s / a b i m n o )
  118. [*]    (repeat (setq i (sslength s))
  119. [*]        (if
  120. [*]            (and
  121. [*]                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
  122. [*]                (vlax-method-applicable-p o 'getboundingbox)
  123. [*]                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
  124. [*]            )
  125. [*]            (setq m (cons (vlax-safearray->list a) m)
  126. [*]                  n (cons (vlax-safearray->list b) n)
  127. [*]            )
  128. [*]        )
  129. [*]    )
  130. [*]    (if (and m n)
  131. [*]        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
  132. [*]    )
  133. [*])
  134. [*];; Start Undo  -  Lee Mac
  135. [*];; Opens an Undo Group.
  136. [*](defun LM:startundo ( doc )
  137. [*]    (LM:endundo doc)
  138. [*]    (vla-startundomark doc)
  139. [*])
  140. [*];; End Undo  -  Lee Mac
  141. [*];; Closes an Undo Group.
  142. [*](defun LM:endundo ( doc )
  143. [*]    (while (= 8 (logand 8 (getvar 'undoctl)))
  144. [*]        (vla-endundomark doc)
  145. [*]    )
  146. [*])
  147. [*];; Active Document  -  Lee Mac
  148. [*];; Returns the VLA Active Document Object
  149. [*](defun LM:acdoc nil
  150. [*]    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
  151. [*]    (LM:acdoc)
  152. [*])
  153. [*](vl-load-com) (princ)
  154. [*];;----------------------------------------------------------------------;;
  155. [*];;                             End of File                              ;;
  156. [*];;----------------------------------------------------------------------;;
  157. [/list]
回复

使用道具 举报

ctrlaltdel

13

主题

57

帖子

45

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
70
发表于 2022-7-5 17:51:16 | 显示全部楼层
Can say how to  make it outline but retain Calligraphy style?
回复

使用道具 举报

ctrlaltdel

13

主题

57

帖子

45

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
70
发表于 2022-7-5 18:31:26 | 显示全部楼层
Bumpz........
回复

使用道具 举报

返回列表 发帖

发表回复

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

本版积分规则

精选推荐

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

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

GMT+8, 2025-3-13 09:03 , Processed in 0.533487 second(s), 58 queries .

© 2020-2025 乐筑天下

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