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

分享到： QQ空间 新浪微博 腾讯微博 微信 更多

发表评论 - 不要忘了输入验证码哦！
作者：	用户：  密码：   注册？ 验证：  防止恶意留言请输入问题答案：1*6=?
评论： 禁止表情 禁止UBB 禁止图片 识别链接 识别关键字	表  情