[VBA]我做的粗糙度，要求高手修改

齿轮设计

我试做的一个粗糙度标注，有几个问题，1，不能附着在直线上，人家做的能附着，且拖出直线时会添加一条线，很方便。2，旋转时，当转到下方时，属性会倒放。我也做不起。 Public Sub ccd()
Dim blockobj As AcadBlock
Dim pt1(0 To 2) As Double '块的插入点，指定块上的一点，就是符号下面的交点
产品图.ccd.show
RETRY:
If Err <> 0 Then
Err.Clear
Exit Sub
End If
Dim I As Integer
For I = 0 To ThisDrawing.Blocks.Count - 1
Set blockobj = ThisDrawing.Block
If blockobj.Name = "ccdname" Then
GoTo fff
End If
Next I
pt1(0) = 0: pt1(1) = 0: pt1(2) = 0
Set blockobj = ThisDrawing.Blocks.add(pt1, "ccdname") '创建块
Dim lineobj As AcadLine '块中要画的直线
Dim startpt(0 To 2) As Double '画线要用的点
Dim endpt(0 To 2) As Double '
Dim dimscal As Double '这个变量用于存放标注的缩放比例
Dim height As Double '块属性的高度
Dim mode As Long '模式
Dim prompt As String '提示
Dim tag As String '标志
Dim value As String '值 Dim insertPt(0 To 2) As Double
dimscal = ActiveDocument.GetVariable("DIMSCALE") '
startpt(0) = -2.8: startpt(1) = 4.8: startpt(2) = 0
endpt(0) = 2.8: endpt(1) = 4.8: endpt(2) = 0
'横线
Set lineobj = blockobj.AddLine(startpt, endpt) '
endpt(0) = 0: endpt(1) = 0: endpt(2) = 0
Set lineobj = blockobj.AddLine(startpt, endpt) '
startpt(0) = 5.6 * dimscal: startpt(1) = 9.6 * dimscal: startpt(2) = 0
Set lineobj = blockobj.AddLine(startpt, endpt) '
'acHorizontalAlignmentLeft 水平左对齐acHorizontalAlignmentCenter 水平中间对齐acHorizontalAlignmentRight水平右对齐
'acHorizontalAlignmentAligned水平分散对齐acHorizontalAlignmentMiddle居中acHorizontalAlignmentFit合适的
'acVerticalAlignmentBaseline垂直基于底线acVerticalAlignmentBottom底部acVerticalAlignmentMiddle中间acVerticalAlignmentTop顶部
Dim attributeObj As AcadAttribute
height = 3.5
mode = acAttributeModeVerify
prompt = "粗糙度"
insertPt(0) = 2: insertPt(1) = 3: insertPt(2) = 0
tag = "粗糙度"
value = ccdz
Set attributeObj = blockobj.AddAttribute(height, mode, prompt, insertPt, tag, value)
'acAttributeModeInvisible,不可见的；acAttributeModeConstant，常量；acAttributeModeVerify，要验证的；acAttributeModePreset预先设定的
'
attributeObj.HorizontalAlignment = acHorizontalAlignmentRight
attributeObj.VerticalAlignment = acVerticalAlignmentBottom
fff:
Dim pt2 As Variant
Dim angle As Double
pt2 = ThisDrawing.Utility.GetPoint(, "选择插入点")

Dim blockRefObj As AcadBlockReference
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(pt2, "ccdname", dimscal, dimscal, dimscal, 0)
angle = ThisDrawing.Utility.GetAngle(pt2, "选择插入的角度")
blockRefObj.Rotate = angle
GoTo RETRY
End Sub

mccad

如果需要附着到线上，可在选定点时使用捕捉功能中的最近点。或者使用GetEntity方法在选定对象的同时取得点。
要增加一条线，也就是说如果在选定的线及放的角度超出某个范围角度时，程序需要对角度进行判断，如果超出，则自动提示用户需要放置的位置，然后在程序中给出引出点位置。
注意属性值可以修改其文字属性，如方向、位置、对齐方式等，所以可以判断粗糙度符号的方向来确认是否倒置处理。
看看这个：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=12844

cag

从我第一天学AutoCAD的二次开发的目的就是为了做一个表面粗糙度标注，因为搞的是机械，肯定是要用到这个功能了，然后就做了许多很是幼稚的表面粗糙度标注程序，现在早弃之不用了。 如果用纯VBA去做，你说的所有功能都能实现，但是，不能实现拖动时，图形就跟着改变，只能点一下，改变一次，我以前也用VBA做过，用起来不方便，所以就没再用了。 不过后来在明经下了一个acadx.arx，如获至宝，可以解决拖动时图形不能跟着改变的情况，做了一个，不过试用了一下，还是有一个缺点，就是在你未点下去之前，如按下了中键，拖动了图形，再点下去，在程序结束后，图形屏幕又会跳到上一个视图去，感觉很不爽。 再后来，发现了Vlisp有个grread的函数(呵呵，之前我全是用VBA做的，对VL是一窍不通了），可以解决acadx.arx的不足，然后就用VL编了一个表面粗糙度标注的程序，也算是我的练手之作了，不过还是有不足，就是不能直接支持捕捉、正交等其他键盘输入，不过用起基本上可行了，这个程序在明经有下，我的个人网站上也有，www.freewebs.com/cag25。 现在如果非让我用VBA去做的话，只能跟VL命令相结合去做了，命令行会产生很多的垃圾信息，看起来又很不爽了，但可能这也是我能实现上面楼主所说要求的唯一办法了。 前不久做了一个表面粗糙度标注的预览控件，可以在VBA中使用，这样，当标注样式需改变时，就可实时在该控件中反应出来，克服了VL中用幻灯片的不足，不过该控件在ObjectDCL中可以加载进去，保存也没问题，但在CAD中实际运行时，有该控件的对话框就不能显示 了，就不知是何故了，也没时间去解决，先放着了。该控件在明经下载中心独家下载。 当然，最好的办法就是用VC来做了，我做了一个半成品，感觉VC好难学，又没太多的空闲时间，就又搁着了。 VB: VL: VC:

neteasy

good