田草博客
日志搜索


 标题   内容 评论


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件
-电信用户-|-网通用户-
-博客论坛-|-软件下载-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2020 - 6 48
 123456
78910111213
14151617181920
21222324252627
282930


站点统计

最新评论



vb.net注册AutoCAD双击事件 游戏 水果忍着 PC版
未知 vba在AutoCAD中绘制螺栓   [ 日期:2011-08-28 ]   [ 来自:本站原创 ]  HTML
Option Explicit
Const Pi As Double = 3.1415926

'多段线转换为面域的函数
Sub CreateBolt()
    '栓头部分的建模*****************************************************************
    Dim objBoltT As Acad3DSolid, objCone As Acad3DSolid, objCylinder As Acad3DSolid
    
    '创建正六边形(多段线)
    Dim objPline As AcadLWPolyline
    Dim ptCen(0 To 2) As Double
    ptCen(0) = 0: ptCen(1) = 0: ptCen(2) = 0
    '  以点(0,0,0)为中心,正6边形,外接圆半径7.5
    Set objPline = AddPolygon(ptCen, 6, 7.5)
    
    '正六边形转成面域
    Dim objRegion As AcadRegion
    Set objRegion = PlToRegion(objPline)
    '面域拉伸成棱柱体
    '  参数(面域,高度,侧壁倾斜角)
    Set objBoltT = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion, 8, 0)
    '删除面域
    objRegion.Delete
'    Dim ptTemp(0 To 2) As Double
'    ptTemp(0) = 20: ptTemp(1) = 0: ptTemp(2) = 0
'    objBoltT.Rotate3D ptCen, ptTemp, -PI / 2
'    ThisDrawing.ModelSpace.AddLine ptCen, ptTemp
    
    '创建圆锥体(楔形实体)(原点是形体的中心,而不是底面的中心)
    Dim ptTo(0 To 2) As Double
    ptTo(0) = 0: ptTo(1) = 0: ptTo(2) = 7.5
    '  参数(底面中心,底面半径,椎体高度)
    Set objCone = ThisDrawing.ModelSpace.AddCone(ptCen, 12, 15)
    objCone.Move ptCen, ptTo    '确保三个实体的正确位置
        
    '创建圆柱体
    ptTo(0) = 0: ptTo(1) = 0: ptTo(2) = 10
    Set objCylinder = ThisDrawing.ModelSpace.AddCylinder(ptCen, 15, 20)
    objCylinder.Move ptCen, ptTo
    
    '布尔运算的第一步:圆柱体减去圆锥体
    objCylinder.Boolean acSubtraction, objCone
    '布尔运算的第二步:六棱柱减去上一步得到的对象
    objBoltT.Boolean acSubtraction, objCylinder
    
    '螺杆部分的建模*****************************************************************
    '创建螺纹部分的多段线
    Dim ptArr1(0 To 61)  As Double
    Dim i As Integer
    For i = 0 To 61
        If i Mod 4 = 0 Then
            ptArr1(i) = 2 * i / 4 + 10  '10为非螺纹段的长度
        ElseIf i Mod 4 = 1 Then
            ptArr1(i) = 5
        ElseIf i Mod 4 = 2 Then
            ptArr1(i) = 2 * (i - 2) / 4 + 10 + 1
        ElseIf i Mod 4 = 3 Then
            ptArr1(i) = 2
        End If
    Next i
    Dim objPl(0 To 1) As AcadLWPolyline
    Set objPl(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr1)
    
    '非螺纹部分的多段线
    Dim ptArr2(0 To 9) As Double
    ptArr2(0) = 10: ptArr2(1) = 5: ptArr2(2) = 0: ptArr2(3) = 5
    ptArr2(4) = 0: ptArr2(5) = 0: ptArr2(6) = 40: ptArr2(7) = 0
    ptArr2(8) = 40: ptArr2(9) = 5
    Set objPl(1) = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr2)
    
    '创建截面图形
    Dim objRegion1 As Variant
    objRegion1 = ThisDrawing.ModelSpace.AddRegion(objPl)
    objPl(0).Delete
    objPl(1).Delete
    
    '创建实体模型
    ptTo(0) = 0: ptTo(1) = -10: ptTo(2) = 0
    objRegion1(0).Rotate3D ptTo, ptCen, Pi / 2
    ptTo(0) = 0: ptTo(1) = 0: ptTo(2) = 10
    Dim objBoltB As Acad3DSolid
    
    '这里不能使用近似的PI值,因此使用了精确值
    Set objBoltB = ThisDrawing.ModelSpace.AddRevolvedSolid(objRegion1(0), ptCen, ptTo, 2 * Atn(1) * 4)
    objRegion1(0).Delete
    
    '两部分的合并*******************************************************************
    objBoltT.Boolean acUnion, objBoltB
    
End Sub


'创建正多边形
'  ptCen 多边形中心
'  number边数
'  radius多边形外接圆半径
'  width 线宽(可选参数)
'  angle 第一条边与x正轴方向角度
Public Function AddPolygon(ByVal ptCen As Variant, ByVal number As Integer, ByVal radius As Double, _
    Optional width As Double = 0, Optional angle As Double = 0) As AcadLWPolyline
    '定义动态数组
    Dim objPline As AcadLWPolyline
    Dim ptArr() As Double
    '顶点的个数为number,需要2*number个元素来表示
    ReDim ptArr(2 * number - 1)
    
    '每条边对应的角度
    Dim ang As Double
    Dim Pi As Double
    Pi = Math.Atn(1) * 4
    ang = 2 * Pi / number
    
    '为点的坐标数组赋值
    Dim i As Integer
    For i = 0 To 2 * number - 1
        If i Mod 2 = 0 Then
            ptArr(i) = ptCen(0) + radius * Cos((i \ 2) * ang)
        ElseIf i Mod 2 <> 0 Then
            ptArr(i) = ptCen(1) + radius * Sin((i \ 2) * ang)
        End If
    Next i
    
    '创建多段线,并调整其特性
    Set objPline = AddLWPline(ptArr, width)
    objPline.Closed = True
    objPline.Rotate ptCen, angle
    objPline.Update
    
    Set AddPolygon = objPline
End Function


'*******************************************************************************************************
'转换闭合多段线为面域的函数
Public Function PlToRegion(ByVal objPline As AcadLWPolyline) As AcadRegion
    '确保多段线闭合
    If objPline.Closed = False Then
        MsgBox "多段线不闭合,无法创建面域!", vbCritical
        Exit Function
    End If
    
    '定义边界对象
    Dim objList(0) As AcadEntity
    Set objList(0) = objPline
    
    '创建面域
    Dim objRegion As Variant
    objRegion = ThisDrawing.ModelSpace.AddRegion(objList)
    
    '删除原来的多段线,函数返回
    objPline.Delete
    Set PlToRegion = objRegion(0)
End Function


'使用点数组创建轻量多段线
Public Function AddLWPline(ByRef pt() As Double, ByVal width As Double) As AcadLWPolyline
    Dim objPline As AcadLWPolyline
    
    If (UBound(pt) + 1) Mod 2 <> 0 Then
        MsgBox "数组元素个数必须为偶数!"
        Exit Function
    End If
    
    Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    objPline.ConstantWidth = width
    objPline.Update
    
    Set AddLWPline = objPline
End Function

http://tiancao.net/bbs/ShowPost.asp?ThreadID=2





暂时没有评论
发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*8=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©