form1.vb

基于vb.net的autocad二次开发凸轮模型反求与3D动画模拟根据凸轮扫描位图反求3d模型模拟凸轮运动显示凸轮位移曲线。

        OutlineDone = True '必须先单击外轮廓
        Numcurves = 0 '外轮廓为第一条曲线
    End Sub

    Sub 求内轮廓点坐标()
        Dim FistX, FistY '第一点
        Dim myPen As New Pen(Color.Red)

        Mpoints = -1
        For I = YMouseDown To 0 Step -1
            If myBitmap.GetPixel(XMouseDown, I).ToArgb <> MouseDownpointsColor.ToArgb Then
                Mpoints = Mpoints + 1
                ReDim Preserve Xp(Mpoints), Yp(Mpoints)
                FistX = XMouseDown
                FistY = I
                Xp(Mpoints) = XMouseDown
                Yp(Mpoints) = I
                '用红色描已经辨别出来的外轮廓
                Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
                Exit For
            End If
        Next I

        Do
            Call 搜寻轮廓边沿坐标()
            '当搜寻到与第一点坐标相同点时停止搜寻
        Loop Until FistX = Xp(Mpoints) And (FistY = Yp(Mpoints) Or FistY = Yp(Mpoints) + 1 Or FistY = Yp(Mpoints) - 1)


    End Sub


    Sub 搜寻轮廓边沿坐标()

        Dim myPen As New Pen(Color.Red)
        '1点
        If myBitmap.GetPixel(Xp(Mpoints) + 1, Yp(Mpoints)).ToArgb = MouseDownpointsColor.ToArgb And _
           myBitmap.GetPixel(Xp(Mpoints) + 1, Yp(Mpoints) - 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) + 1
            Yp(Mpoints) = Yp(Mpoints - 1)
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
            '2点
        ElseIf myBitmap.GetPixel(Xp(Mpoints) + 1, Yp(Mpoints) + 1).ToArgb = MouseDownpointsColor.ToArgb And _
             myBitmap.GetPixel(Xp(Mpoints) + 1, Yp(Mpoints) - 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) + 1
            Yp(Mpoints) = Yp(Mpoints - 1) + 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
            '3点
        ElseIf myBitmap.GetPixel(Xp(Mpoints), Yp(Mpoints) + 1).ToArgb = MouseDownpointsColor.ToArgb And _
              myBitmap.GetPixel(Xp(Mpoints) + 1, Yp(Mpoints) + 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1)
            Yp(Mpoints) = Yp(Mpoints - 1) + 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
            '4点
        ElseIf myBitmap.GetPixel(Xp(Mpoints) - 1, Yp(Mpoints) + 1).ToArgb = MouseDownpointsColor.ToArgb And _
          myBitmap.GetPixel(Xp(Mpoints), Yp(Mpoints) + 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) - 1
            Yp(Mpoints) = Yp(Mpoints - 1) + 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
            '5点
        ElseIf myBitmap.GetPixel(Xp(Mpoints) - 1, Yp(Mpoints)).ToArgb = MouseDownpointsColor.ToArgb And _
         myBitmap.GetPixel(Xp(Mpoints) - 1, Yp(Mpoints) + 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) - 1
            Yp(Mpoints) = Yp(Mpoints - 1)
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
            '6点
        ElseIf myBitmap.GetPixel(Xp(Mpoints) - 1, Yp(Mpoints) - 1).ToArgb = MouseDownpointsColor.ToArgb And _
           myBitmap.GetPixel(Xp(Mpoints) - 1, Yp(Mpoints)).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) - 1
            Yp(Mpoints) = Yp(Mpoints - 1) - 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)

            '7点

        ElseIf myBitmap.GetPixel(Xp(Mpoints), Yp(Mpoints) - 1).ToArgb = MouseDownpointsColor.ToArgb And _
              myBitmap.GetPixel(Xp(Mpoints) - 1, Yp(Mpoints) - 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1)
            Yp(Mpoints) = Yp(Mpoints - 1) - 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
            '8点
        ElseIf myBitmap.GetPixel(Xp(Mpoints) + 1, Yp(Mpoints) - 1).ToArgb = MouseDownpointsColor.ToArgb And _
              myBitmap.GetPixel(Xp(Mpoints), Yp(Mpoints) - 1).ToArgb <> MouseDownpointsColor.ToArgb Then
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) + 1
            Yp(Mpoints) = Yp(Mpoints - 1) - 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
        Else
            Mpoints = Mpoints + 1
            ReDim Preserve Xp(Mpoints), Yp(Mpoints)
            Xp(Mpoints) = Xp(Mpoints - 1) + 1
            Yp(Mpoints) = Yp(Mpoints - 1) + 1
            Me.PictureBox1.CreateGraphics.DrawEllipse(myPen, Xp(Mpoints), Yp(Mpoints), 1, 1)
        End If
    End Sub
    Sub 造型()

        Dim startTan(2) As Double
        Dim endTan(2) As Double
        Dim fitPoints() As Double

        startTan(0) = 0 : startTan(1) = 0 : startTan(2) = 0
        endTan(0) = 0 : endTan(1) = 0 : endTan(2) = 0

        Dim Stp, K

        '步长,越小精度越高
        Stp = Val(Me.TextBox1.Text)
        K = 0

        '非均匀有理B样条曲线拟合
        If Me.RadioButton1.Checked Then

            For I = 0 To Mpoints - Stp Step Stp
                ReDim Preserve fitPoints(3 * K + 2)
                fitPoints(3 * K) = Xp(I) : fitPoints(3 * K + 1) = -Yp(I) : fitPoints(3 * K + 2) = 0
                K = K + 1
            Next I

            ReDim Preserve fitPoints(3 * K + 2)
            fitPoints(3 * K) = Xp(0) : fitPoints(3 * K + 1) = -Yp(0) : fitPoints(3 * K + 2) = 0


            ReDim Preserve splineObj(Numcurves)
            splineObj(Numcurves) = Acadapp.ActiveDocument.ModelSpace.AddSpline(fitPoints, startTan, endTan)

            '多义线拟合
        ElseIf Me.RadioButton2.Checked Then
            For I = 0 To Mpoints - Stp Step Stp
                ReDim Preserve fitPoints(2 * K + 1)
                fitPoints(2 * K) = Xp(I) : fitPoints(2 * K + 1) = -Yp(I)
                K = K + 1
            Next I
            ReDim Preserve fitPoints(2 * K + 1)
            fitPoints(2 * K) = Xp(0) : fitPoints(2 * K + 1) = -Yp(0)
            ReDim Preserve splineObj(Numcurves)
            splineObj(Numcurves) = Acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(fitPoints)
        End If


        '可以根据实际情况用鼠标拖动曲线上的拟合点进行修改
        MsgBox("请整理曲线")

        '将轮廓曲线创建为面域
        Dim regionObj As Object
        regionObj = Acadapp.ActiveDocument.ModelSpace.AddRegion(splineObj)

        '将面域拉伸为3D实体
        ReDim Preserve solidObj(Numcurves)
        solidObj(Numcurves) = Acadapp.ActiveDocument.ModelSpace.AddExtrudedSolid(regionObj(0), 44, 0)
        solidObj(Numcurves).Color = AutoCAD.ACAD_COLOR.acRed
        solidObj(Numcurves).Update()

        Numcurves = Numcurves + 1


    End Sub

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

        '清除3D实体以外的其他实体
        Dim Obj As AutoCAD.AcadEntity
        For Each Obj In Acadapp.ActiveDocument.ModelSpace
            If Obj.ObjectName <> "AcDb3dSolid" Then Obj.Delete()
        Next

        '布尔减运算，外轮廓实体减去所有内轮廓实体
        For I = 1 To Numcurves - 1
            solidObj(0).Boolean(AutoCAD.AcBooleanType.acSubtraction, solidObj(I))
        Next I
        OutlineDone = False
        AppActivate(Acadapp.Caption)
    End Sub



    '"图形增强处理（可选）"按钮
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        Dim i, j

        '将图形颜色变为纯色
        For i = 0 To Me.myBitmap.Width - 1
            For j = 0 To Me.myBitmap.Height - 1
                If myBitmap.GetPixel(i, j).ToArgb <> myBitmap.GetPixel(0, 0).ToArgb Then
                    myBitmap.SetPixel(i - 1, j - 1, Color.Blue)
                    myBitmap.SetPixel(i, j - 1, Color.Blue)
                    myBitmap.SetPixel(i - 1, j, Color.Blue)
                End If
            Next
        Next
        Me.PictureBox1.Refresh() '显示刷新图片
    End Sub

    Sub 连接AutoCAD()
        On Error Resume Next
        Acadapp = GetObject(, "AutoCAD.Application")
        If Err.Number Then
            Err.Clear()
            Acadapp = CreateObject("AutoCAD.Application")
            If Err.Number Then
                MsgBox("不能运行AutoCAD,请检查是否安装了AutoCAD")
                Exit Sub
            End If
        End If
        Acadapp.Visible = True '界面可视
        Acadapp.WindowState = AutoCAD.AcWindowState.acMax '界面最大化
        AppActivate(Acadapp.Caption) '显示AutoCAD界面
    End Sub

    '加载滚子图形
    Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click

        myBitmap = Bitmap.FromFile(Application.StartupPath + "\滚子.bmp")
        '装载图片
        Me.PictureBox1.Image = myBitmap

        solidObjT = solidObj(0) '凸轮实体

    End Sub

    Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button4.Click
        Call 生成数据()
        Call 动画()
    End Sub

    Sub 生成数据()
        Dim InterferenceObj As AutoCAD.Acad3DSolid '定义滚子与凸轮的干涉体
        Dim j
        Dim center(2) As Double
        On Error Resume Next

        AppActivate(Acadapp.Caption) '显示AutoCAD界面


        '绘制显示滚子位移曲线的坐标轴
        center(0) = TCenter(0) + 400 : center(1) = TCenter(1) + 300 : center(2) = 0
        Xzhou = Acadapp.ActiveDocument.ModelSpace.AddCylinder(center, 2, 380)
        Dim point1(2), point2(2) As Double
        point1(0) = Xzhou.Centroid(0) : point1(1) = Xzhou.Centroid(1) + 1 : point1(2) = Xzhou.Centroid(2)
        Xzhou.Rotate3D(Xzhou.Centroid, point1, 3.14159 / 2)
        Xzhou.Color = AutoCAD.ACAD_COLOR.acBlue
        Xzhou.Update()

        Yzhou = Xzhou.Copy
        point1(0) = Xzhou.Centroid(0) - 190 : point1(1) = Xzhou.Centroid(1) : point1(2) = Xzhou.Centroid(2)
        point2(0) = Xzhou.Centroid(0) - 190 : point2(1) = Xzhou.Centroid(1) : point2(2) = Xzhou.Centroid(2) + 1
        Yzhou.Rotate3D(point1, point2, 3.14159 / 2)

        Yzhou.Color = AutoCAD.ACAD_COLOR.acBlue
        Yzhou.Update()
  
        '滚子移动
        center(0) = TCenter(0) + Val(Me.TextBox2.Text) : center(1) = Me.PictureBox1.Height / 2 : center(2) = solidObj(0).Centroid(2)
        solidObj(0).Move(solidObj(0).Centroid, center)
        solidObj(0).Update()

        Acadapp.ZoomExtents()

        jg = Val(Me.TextBox3.Text) '凸轮转动间隔角度


        '如果滚子与凸轮接触，记录滚子中心坐标
        For j = 0 To 360 Step jg
            solidObjT.Rotate(TCenter, 3.14159 / 180 * jg) '凸轮转动
            center(1) = Me.PictureBox1.Height / 2
            solidObj(0).Move(solidObj(0).Centroid, center) '滚子移动
            solidObj(0).Update()
            solidObjT.Update()

            '滚子向下移动，至与凸轮干涉为止
            For I = solidObj(0).Centroid(1) To 0 Step -2
                center(1) = I
                solidObj(0).Move(solidObj(0).Centroid, center)
                InterferenceObj = solidObjT.CheckInterference(solidObj(0), True)
                InterferenceObj.Delete()

                '如果滚子与凸轮干涉、接触，记录滚子中心坐标
                If Err.Number = 0 Then
                    gCenterY(j) = I + 1
                    solidObj(0).Update()
                    solidObjT.Update()

                    '绘制凸轮位移曲线
                    point1(0) = Xzhou.Centroid(0) - 190 + j
                    point1(1) = Xzhou.Centroid(1) + (gCenterY(j) - gCenterY(0)) * 5 '放大
                    point1(2) = Xzhou.Centroid(2)
                    Acadapp.ActiveDocument.ModelSpace.AddSphere(point1, 2)

                    Exit For
                End If
                Err.Clear()
            Next
        Next
        InterferenceObj = Nothing

    End Sub


    Sub 动画()

        AppActivate(Acadapp.Caption)

        Dim center(2) As Double

        Dim starpoint(2), endpoint(2) As Double
        Dim myLine As AutoCAD.AcadLine

        center(0) = TCenter(0) + Val(Me.TextBox2.Text) : center(2) = solidObj(0).Centroid(2)

        '绘制凸轮动画
        For I = 0 To 360 Step jg
            solidObjT.Rotate(TCenter, 3.14159 / 180 * jg) '凸轮转动
            center(1) = gCenterY(I)
            solidObj(0).Move(solidObj(0).Centroid, center) '推杆移动
            solidObjT.Update()
            solidObj(0).Update()


            '绘制坐标上的移动线
            starpoint(0) = Xzhou.Centroid(0) - 190 + I
            starpoint(1) = Xzhou.Centroid(1)
            starpoint(2) = Xzhou.Centroid(2)

            endpoint(0) = starpoint(0)
            endpoint(1) = Xzhou.Centroid(1) + (gCenterY(I) - gCenterY(0)) * 5  '放大
            endpoint(2) = starpoint(2)

            myLine = Acadapp.ActiveDocument.ModelSpace.AddLine(starpoint, endpoint)
            myLine.Update()

            myLine.Delete()

        Next


    End Sub

    Private Sub Button5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button5.Click
        Call 动画()
    End Sub

    Private Sub Button6_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button6.Click
        End
    End Sub
End Class