乐筑天下

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

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

[复制链接]

4

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
35
发表于 2004-11-27 09:28:00 | 显示全部楼层 |阅读模式
我试做的一个粗糙度标注,有几个问题,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
回复

使用道具 举报

158

主题

2315

帖子

10

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2951
发表于 2004-11-27 20:40:00 | 显示全部楼层
如果需要附着到线上,可在选定点时使用捕捉功能中的最近点。或者使用GetEntity方法在选定对象的同时取得点。
要增加一条线,也就是说如果在选定的线及放的角度超出某个范围角度时,程序需要对角度进行判断,如果超出,则自动提示用户需要放置的位置,然后在程序中给出引出点位置。
注意属性值可以修改其文字属性,如方向、位置、对齐方式等,所以可以判断粗糙度符号的方向来确认是否倒置处理。
看看这个:
回复

使用道具 举报

cag

87

主题

265

帖子

10

银币

中流砥柱

Rank: 25

铜币
613
发表于 2004-11-28 20:37:00 | 显示全部楼层

从我第一天学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:

xtf5whu1wh4.GIF

xtf5whu1wh4.GIF

VL:

ed35uhua4xw.GIF

ed35uhua4xw.GIF

VC:

hx2pmrf1cyn.GIF

hx2pmrf1cyn.GIF

回复

使用道具 举报

46

主题

252

帖子

8

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
436
发表于 2004-11-29 21:11:00 | 显示全部楼层
good
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

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

GMT+8, 2025-3-16 15:05 , Processed in 0.458674 second(s), 63 queries .

© 2020-2025 乐筑天下

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