VBA线条图

jakebullet70 · 发表于 2022-7-6 14:50:52

又是我。。。（aCad 2007）

我正在尝试使用VBA绘制一条带有文本块的线，并正在寻找最好的方法来做到这一点。

我正在使用：

这实际上画了一条线。但是如果你看看我上传的图片。该行需要与顶行相似，顶行用箭头高亮显示，顶部有文本块。所以我想问题是：

我怎么得到箭头？
或者我可以保存现有的行和文本块（它们可以一起移动）并重新加载吗？这似乎是个好主意，但我还没有想出如何挽救它。

还是我又错过了那条船？
再次感谢。

CmdrDuh · 发表于 2022-7-6 15:05:46

我有这方面的代码，brb

CmdrDuh · 发表于 2022-7-6 15:12:43

copy

(defun c:dimarr (/ ent entname entguts pt1 pt2 ang revang objtype)
 (setvar "cmdecho" 0)
 (setq layname nil)
 (setq ent T)
 (while ent
   (setq ent   (entsel)
  entname (car ent)
  entguts (entget entname)
  objtype (cdr (assoc 0 entguts))
   )
   (if (= objtype "LINE")
     (progn (setq pt1    (cdr (assoc 10 entguts))
    pt2    (cdr (assoc 11 entguts))
    ang    (angle pt1 pt2)
    revang  (angle pt2 pt1)
    sf    (getvar "dimscale")
    clay    (getvar "clayer")
    entguts (subst (cons 8 clay)
     (assoc 8 entguts)
     entguts
     )
     )
     (entmod entguts)
     (command "-insert" "arrow" pt1 sf sf (r->d revang))
     (setq entname (entlast)
    entguts (entget entname)
    entguts (subst (cons 8 clay)
     (assoc 8 entguts)
     entguts
     )
     )
     (entmod entguts)
     (command "-insert" "arrow" pt2 sf sf (r->d ang))
     (setq entname (entlast)
    entguts (entget entname)
    entguts (subst (cons 8 clay)
     (assoc 8 entguts)
     entguts
     )
     )
     (entmod entguts)
     )
     (command "explode" ent "")
   )
 )
 (setvar "cmdecho" 1)
 (princ)
)

CmdrDuh · 发表于 2022-7-6 15:19:21

这是一个lsp解决方案，应该为您指明正确的方向。如果没有，请告诉我，我会帮你转换

jakebullet70 · 发表于 2022-7-6 15:24:22

对不起，这周我被换了一套不同的任务。希望在我忘记过去几周关于Acad所学到的一切之前，下周再次访问这个网站。

Lee Mac · 发表于 2022-7-6 15:32:09

看起来它缺少了一个子函数Cmdrduh——从外观上看是弧度到度的转换器。

我只是想提醒你一下

Lee Mac · 发表于 2022-7-6 15:42:07

再加上这个，杰克：

copy

CmdrDuh · 发表于 2022-7-6 15:50:49

谢谢我几年前写的代码，在发布之前并没有真正证明它

jakebullet70 · 发表于 2022-7-6 15:51:34

嗯，当然。。。他们更改了我的规格。呵呵。无论如何我现在有一张图纸要插入。我可以使用我的VBA代码并插入它，并添加了一个文本块，这样我就可以放置我需要的文本

我现在要做的是调整左右两侧的大小。我知道总长度，所以这不是一个问题，我已经包括了图纸。

任何帮助都将不胜感激！

谢谢大家！！！
ChairDim。图纸

[编程交流] VBA线条图

发表回复

精选推荐