Visual Basic与AutoCAD二次开发

friend136

源代码：
Option Explicit
Dim daoju3d As Acad3DSolid
Private Sub Command1_Click()
On Error Resume Next
   '生成三维模型前先将上次运行完毕的文件关闭
   'chicad.ActiveDocument.Close
   chicad.Documents.Add   '新建一文件
   
    Dim CZ, CM, CA, CR, CRb, CRA, CRF, CSB, UMAX, U, B
    Dim th(3)
    Dim i
   
    CZ = Me.Text1                             '齿数
    CM = Me.Text2                             '模数
    CA = Me.Text3 * 3.1416 / 180              '压力角
   
    '设置三维视点
    Dim newdirection(0 To 2) As Double
    newdirection(0) = 1: newdirection(1) = 0.5: newdirection(2) = 0.5
    chicad.ActiveDocument.ActiveViewport.Direction = newdirection
    chicad.ActiveDocument.ActiveViewport = chicad.ActiveDocument.ActiveViewport
    chicad.ActiveDocument.Layers(0).Color = acRed
   chicad.ActiveDocument.SendCommand "_shademode" + vbCr + "_g" + vbCr   '着色
    '齿轮毛配造型
    '
    CR = CM * CZ / 2               '齿轮分度圆半径
    CRF = (CR - 1.25 * CM)         '齿轮根圆半径
    CRb = CR * Cos(CA)             '齿轮基圆半径
    CRA = CR + CM                  '齿轮顶圆半径
    Dim chi3d As Acad3DSolid
   ' Dim chi3d As Acad3DSolid
    Dim centerpoint(0 To 2) As Double
    centerpoint(0) = 0#: centerpoint(1) = 0#: centerpoint(2) = 0#
    Dim height As Double
    height = CRA / 3
    Set chi3d = chicad.ActiveDocument.ModelSpace.AddCylinder(centerpoint, CRA, height)
   
   
    '创建齿轮中间的轴孔
    Dim zhoukong As Acad3DSolid
    '轴孔直径为齿轮的1/3
    Set zhoukong = chicad.ActiveDocument.ModelSpace.AddLeader(centerpoint, CRA / 3, height)
    chi3d.Boolean acSubtraction, zhoukong
    chi3d.Color = acGreen
    ZoomAll
   
    '刀具造型
    '
    Dim plineobj(0) As AcadLWPolyline
    '齿轮基圆齿厚
    CSB = Cos(CA) * (3.1416 * CM / 2 + CM * CZ * (Tan(CA) - (CA)))
    th(1) = (3.1416 * CM * Cos(CA) - CSB) / (2 * CRb)
    th(0) = th(1) / 3
    th(2) = th(1) + Tan(CA) - CA
    'acos：反余弦，自定义函数
    th(3) = th(1) + Tan(acos(CRb / CRA)) - acos(CRb / CRA)
   
    Dim curves(0 To 5) As AcadEntity
    Dim points0(0 To 5) As Double
    Dim points1(0 To 8) As Double
    Dim points2(0 To 5) As Double
   
    points0(0) = 0: points0(1) = CRF '第0点
    points0(2) = CRF * Sin(th(0)): points0(3) = CRF * Cos(th(0)) '第一点
    points0(4) = CRb * Sin(th(1)): points0(5) = CRb * Cos(th(1))
   
    Dim starttan(0 To 2) As Double
    Dim endtan(0 To 2) As Double
    starttan(0) = 0: starttan(1) = 0: starttan(2) = 0
    endtan(0) = 0.5: endtan(1) = 0.5: endtan(2) = 0
   
    '第2点
    points1(0) = points0(4): points1(1) = points0(5): points1(2) = 0
    '第3点
    points1(3) = CR * Sin(th(2)): points1(4) = CR * Cos(th(2)): points1(5) = 0
    '第4点
    points1(6) = CRA * Sin(th(3)): points1(7) = CRA * Cos(th(3)): points1(8) = 0
   
    points2(0) = points1(6): points2(1) = points1(7)  '第4点
    points2(2) = points1(6): points2(3) = points1(7) + 2.2 * CM '第5点
    points2(4) = 0:          points2(5) = points2(3) '第6点
   
    '当基圆小于根圆，调整第1、第2点坐标，得到近似值
    If CRb < CRF Then
         '第1点
         points0(2) = points1(3) * 0.2: points0(3) = points0(1) + 0.25 * CM * 0.03
         '第2点
         points0(4) = points1(3) * 0.7: points0(5) = points0(1) + 0.25 * CM * 0.8
         ''第2点
         points1(0) = points0(4): points1(1) = points0(5): points1(2) = 0
        End If
        
        '创建刀具右部线段
    Set curves(0) = chicad.ActiveDocument.ModelSpace.AddLightWeightPolyline(points0) '由0,1,2,点组成
         curves(0).setbulge1 , 0.2 '第一点凸度为0.2
    Set curves(1) = chicad.ActiveDocument.ModelSpace.AddSpline(points1, starttan, endtan) '由2,3,4点组成
    Set curves(2) = chicad.ActiveDocument.ModelSpace.AddLightWeightPolyline(points2) '由4,5,6点组成
   
    Dim point1(0 To 2) As Double
    Dim point2(0 To 2) As Double
    point1(0) = 0: point1(1) = 0: point1(2) = 0
    point2(0) = 0: point2(1) = 1: point2(2) = 0
    '镜像刀具右部线段，得到刀具左部线段
   
    Set curves(3) = curves(2).Mirror(point1, point2)
    Set curves(4) = curves(1).Mirror(point1, point2)
    Set curves(5) = curves(0).Mirror(point1, point2)
   
    Dim daoju As Variant
    daoju = chicad.ActiveDocument.ModelSpace.AddRegion(curves)
   
    '将刀具（面域）旋转得到三位刀具实体
    Dim axispt(0 To 2) As Double
    Dim axisdir(0 To 2) As Double
    Dim angle As Double
    axispt(0) = 0: axispt(1) = points2(5) + 2 * CM: axispt(2) = 0
    axisdir(0) = 1: axisdir(1) = 0: axisdir(2) = 0
    angle = 6.29 '360'
   
    'Dim daoju3d As Acad3DSolid
    Set daoju3d = chicad.ActiveDocument.ModelSpace.AddRevolvedSolid(daoju(0), axispt, axisdir, angle)
    ZoomAll
   
    Dim boxobj As Acad3DSolid
    Dim center(0 To 2) As Double
    Dim taperangle As Double
    taperangle = 0
   
    center(0) = 0: center(1) = CRF: center(2) = 0
    Set boxobj = chicad.ActiveDocument.ModelSpace.AddBox(center, CM / 2, 4 * CM, points2(0) * 2)
   
    Dim retobj As Variant
    retobj = boxobj.ArrayPolar(20, 6.28, daoju3d.Centroid)
    For i = 0 To 20 - 2 '刀具齿数为19
         retobj(i).Rotate3D center, centerpoint, 3.14 / 2
         retobj(i).Update
         daoju3d.Boolean acSubtraction, retobj(i)
    Next i
      Dim daojubool As Acad3DSolid
      Set daojubool = chicad.ActiveDocument.ModelSpace.AddExtrudedSolid(daoju(0), height + 20, taperangle)
      axispt(0) = daojubool.Centroid(0)
      axispt(1) = daojubool.Centroid(1)
      axispt(2) = 0
      
      daojubool.Move daojubool.Centroid, axispt
      
      daojubool.Visible = False
      axispt(0) = daoju3d.Centroid(0) + 10
      axispt(1) = daoju3d.Centroid(1)
      axispt(2) = daoju3d.Centroid(2)
      point1(0) = daoju3d.Centroid(0)
      point1(1) = daoju3d.Centroid(1)
      point1(2) = daoju3d.Centroid(2) + height
      '---------------------------------------自添加
      Dim point5(2) As Double
      point5(0) = daoju3d.Centroid(0): point5(1) = daoju3d.Centroid(1) + 12: point5(2) = daoju3d.Centroid(2) '刀具退出点
      '---------------------------------------
      daoju3d.Move daoju3d.Centroid, point1
      
      '-------------------------------
      '删除“齿轮3d”、刀具3d、与刀具bool之外的所有实体
      '------------------------
      Dim entry As AcadEntity
      '对模型空间的每个成员作一次迭代
      For Each entry In chicad.ActiveDocument.ModelSpace
         If entry.ObjectID <> chi3d.ObjectID And entry.ObjectID <> daoju3d.ObjectID And entry.ObjectID <> daojubool.ObjectID Then
             entry.Delete
         End If
            
      Next
      
      '''======================
      '动作
      '-----------------------
      Dim daojucopy As Acad3DSolid
      Dim k
      i = 0
      Dim daoju3dz As Double
      daoju3dz = daoju3d.Centroid
      Dim centerpoint2(0 To 2) As Double
      
      centerpoint2(0) = 0: centerpoint2(1) = 1: centerpoint2(2) = 0
      chi3d.Rotate3D centerpoint, centerpoint2, 30 * 3.1416 / 180 '齿轮毛胚旋转一次角度
      Do Until i > 360           '转一圈
         For k = daoju3dz To daoju3dz - height Step -height / 3
              point1(2) = k
              daoju3d.Move daoju3d.Centroid, point1
              daoju3d.Update
              
              axispt(2) = daoju3d.Centroid(2)
              '刀具旋转
              daoju3d.Rotate3D daoju3d.Centroid, axispt, 360 / 30 * 3.1416 / 180
              'daoju3d.Update
          Next k
         
                Set daojucopy = daojubool.Copy
                chi3d.Boolean acSubtraction, daojucopy '布尔减
                chi3d.Update
               
                point1(2) = point1(2) + height
                 daoju3d.Move daoju3d.Centroid, point1
                 daoju3d.Update
                 Dim centerpoint3(0 To 2) As Double
                 centerpoint3(0) = 0.5: centerpoint3(1) = 0: centerpoint3(2) = 0.866
                 chi3d.Rotate3D centerpoint, centerpoint3, -360 / CZ * 3.1416 / 180 '齿轮毛胚旋转
                 chi3d.Color = acGreen
                 chi3d.Update
                 i = 360 / CZ + i
                 daoju3d.Move daoju3d.Centroid, point5
                 daoju3d.Update
       Loop
      'chicad = Nothing
      chi3d = Nothing
      zhoukong = Nothing
      curves(0) = Nothing
      curves(1) = Nothing
      curves(2) = Nothing
      curves(3) = Nothing
      curves(4) = Nothing
      curves(5) = Nothing
      'daoju = Nothing
      daoju3d = Nothing
      boxobj = Nothing
      daojubool = Nothing
      'daoju3dz = Nothing
      daojucopy = Nothing
      
End Sub

Private Sub Command2_Click()
Me.Text1 = 18
Me.Text2 = 5
Me.Text3 = 20
End Sub

Private Sub Command3_Click()
Dim ss As AcadSelectionSet
'Set ss = chicad.ActiveDocument.SelectionSets.Add("daoju3d")
If ss.Count > 0 Then
    Dim i As Integer
   For i = 0 To ss.Count - 1
       ss.Item(i).Delete
   Next
End If
'ss.Erase
'ss.Delete
End Sub

Private Sub Form_Load()
Me.Caption = "齿轮加工"
Me.Left = (Screen.Width - Me.Width)
Me.Top = 0
Me.Label1 = "齿数"
Me.Label2 = "模数"
Me.Label3 = "压力角"
Me.Command1.Caption = "确定"
Me.Command2.Caption = "取消"
'赋初值
Me.Text1 = 18
Me.Text2 = 5
Me.Text3 = 20

'连接cad
'将变量“齿轮CAD设置为AUTOCAD应用程序对象”
'齿轮CAD已在module中定义为全局变量

On Error Resume Next
Set chicad = GetObject(, "AutoCAD.Application")
If Err Then
    Err.Clear
    Set chicad = CreateObject("AutoCAD.Application")
    If Err Then
    MsgBox (Err.Description)
    Unload Me
    Exit Sub
    End If
End If
chicad.WindowState = acMax

End Sub

1561720203

编译错误:无法使用Me关键字

friend136

1561720203 发表于 2012-5-15 10:20

                               
登录/注册后可看大图

编译错误:无法使用Me关键字

直接当前窗口。text就可以解决