[VBA]我做的粗糙度，要求高手修改
我试做的一个粗糙度标注，有几个问题，1，不能附着在直线上，人家做的能附着，且拖出直线时会添加一条线，很方便。2，旋转时，当转到下方时，属性会倒放。我也做不起。Public Sub ccd()<BR>Dim blockobj As AcadBlock<BR>Dim pt1(0 To 2) As Double '块的插入点，指定块上的一点，就是符号下面的交点<BR> 产品图.ccd.show<BR>RETRY:<BR> If Err <> 0 Then<BR> Err.Clear<BR> Exit Sub<BR> End If<BR> Dim I As Integer<BR> For I = 0 To ThisDrawing.Blocks.Count - 1<BR> Set blockobj = ThisDrawing.Block<BR> If blockobj.Name = "ccdname" Then<BR> GoTo fff<BR> End If<BR>Next I
<BR>pt1(0) = 0: pt1(1) = 0: pt1(2) = 0<BR>Set blockobj = ThisDrawing.Blocks.add(pt1, "ccdname") '创建块<BR> Dim lineobj As AcadLine '块中要画的直线<BR> Dim startpt(0 To 2) As Double '画线要用的点<BR> Dim endpt(0 To 2) As Double '<BR> Dim dimscal As Double '这个变量用于存放标注的缩放比例<BR> Dim height As Double '块属性的高度<BR> Dim mode As Long '模式<BR> Dim prompt As String '提示<BR> Dim tag As String '标志<BR> Dim value As String '值
Dim insertPt(0 To 2) As Double<BR> dimscal = ActiveDocument.GetVariable("DIMSCALE") '<BR> startpt(0) = -2.8: startpt(1) = 4.8: startpt(2) = 0<BR> endpt(0) = 2.8: endpt(1) = 4.8: endpt(2) = 0<BR> '横线<BR> Set lineobj = blockobj.AddLine(startpt, endpt) '<BR> endpt(0) = 0: endpt(1) = 0: endpt(2) = 0<BR> Set lineobj = blockobj.AddLine(startpt, endpt) '<BR> startpt(0) = 5.6 * dimscal: startpt(1) = 9.6 * dimscal: startpt(2) = 0<BR> Set lineobj = blockobj.AddLine(startpt, endpt) '<BR>'acHorizontalAlignmentLeft 水平左对齐acHorizontalAlignmentCenter 水平中间对齐acHorizontalAlignmentRight水平右对齐<BR>'acHorizontalAlignmentAligned水平分散对齐acHorizontalAlignmentMiddle居中acHorizontalAlignmentFit合适的<BR>'acVerticalAlignmentBaseline垂直基于底线acVerticalAlignmentBottom底部acVerticalAlignmentMiddle中间acVerticalAlignmentTop顶部<BR> Dim attributeObj As AcadAttribute<BR> height = 3.5<BR> mode = acAttributeModeVerify<BR> prompt = "粗糙度"<BR> insertPt(0) = 2: insertPt(1) = 3: insertPt(2) = 0<BR> tag = "粗糙度"<BR> value = ccdz<BR> Set attributeObj = blockobj.AddAttribute(height, mode, prompt, insertPt, tag, value)<BR> 'acAttributeModeInvisible,不可见的；acAttributeModeConstant，常量；acAttributeModeVerify，要验证的；acAttributeModePreset预先设定的<BR> '<BR> attributeObj.HorizontalAlignment = acHorizontalAlignmentRight<BR> attributeObj.VerticalAlignment = acVerticalAlignmentBottom<BR>fff:<BR> Dim pt2 As Variant<BR> Dim angle As Double<BR> pt2 = ThisDrawing.Utility.GetPoint(, "选择插入点")<BR> <BR> Dim blockRefObj As AcadBlockReference<BR> Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(pt2, "ccdname", dimscal, dimscal, dimscal, 0)<BR>angle = ThisDrawing.Utility.GetAngle(pt2, "选择插入的角度")<BR>blockRefObj.Rotate = angle<BR>GoTo RETRY<BR>End Sub 如果需要附着到线上，可在选定点时使用捕捉功能中的最近点。或者使用GetEntity方法在选定对象的同时取得点。<BR>要增加一条线，也就是说如果在选定的线及放的角度超出某个范围角度时，程序需要对角度进行判断，如果超出，则自动提示用户需要放置的位置，然后在程序中给出引出点位置。<BR>注意属性值可以修改其文字属性，如方向、位置、对齐方式等，所以可以判断粗糙度符号的方向来确认是否倒置处理。<BR>看看这个：<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=12844" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=12844</A> 本帖最后由 作者 于 2004-11-29 8:01:11 编辑 <br /><br /> 从我第一天学AutoCAD的二次开发的目的就是为了做一个表面粗糙度标注，因为搞的是机械，肯定是要用到这个功能了，然后就做了许多很是幼稚的表面粗糙度标注程序，现在早弃之不用了。
如果用纯VBA去做，你说的所有功能都能实现，但是，不能实现拖动时，图形就跟着改变，只能点一下，改变一次，我以前也用VBA做过，用起来不方便，所以就没再用了。
不过后来在明经下了一个acadx.arx，如获至宝，可以解决拖动时图形不能跟着改变的情况，做了一个，不过试用了一下，还是有一个缺点，就是在你未点下去之前，如按下了中键，拖动了图形，再点下去，在程序结束后，图形屏幕又会跳到上一个视图去，感觉很不爽。
再后来，发现了Vlisp有个grread的函数(呵呵，之前我全是用VBA做的，对VL是一窍不通了），可以解决acadx.arx的不足，然后就用VL编了一个表面粗糙度标注的程序，也算是我的练手之作了，不过还是有不足，就是不能直接支持捕捉、正交等其他键盘输入，不过用起基本上可行了，这个程序在明经有下，我的个人网站上也有，<A href="http://www.freewebs.com/cag25" target="_blank" >www.freewebs.com/cag25</A>。
现在如果非让我用VBA去做的话，只能跟VL命令相结合去做了，命令行会产生很多的垃圾信息，看起来又很不爽了，但可能这也是我能实现上面楼主所说要求的唯一办法了。
前不久做了一个表面粗糙度标注的预览控件，可以在VBA中使用，这样，当标注样式需改变时，就可实时在该控件中反应出来，克服了VL中用幻灯片的不足，不过该控件在ObjectDCL中可以加载进去，保存也没问题，但在CAD中实际运行时，有该控件的对话框就不能显示 了，就不知是何故了，也没时间去解决，先放着了。该控件在明经下载中心独家下载。
当然，最好的办法就是用VC来做了，我做了一个半成品，感觉VC好难学，又没太多的空闲时间，就又搁着了。
VB:
VL:
VC:
good
页:
[1]