利用VB写的随鼠标移动的图形

scs5999

Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Interop
Imports Autodesk.AutoCAD.Interop.Common

Public Class Class1

    <CommandMethod("mtest")> _
    Public Sub test()

        Dim ed As Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor
        Dim sd As New MotionalMousePoint
        AddHandler ed.PointFilter, AddressOf sd.GetMousePoint
        Dim pro As PromptPointOptions = New PromptPointOptions("请选择插入点...")
        ed.GetPoint(pro)
        RemoveHandler ed.PointFilter, AddressOf sd.GetMousePoint

    End Sub
End Class

Public Class MotionalMousePoint

    Private MousePoint As Point3d = New Point3d(0, 0, 0) '保存当前鼠标位置      
    ''动态获取鼠标位置   
    Public Sub GetMousePoint(ByVal sender As Object, ByVal e As PointFilterEventArgs)

        MousePoint = e.Context.ComputedPoint
        Dim m_ed As Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor

        DelegateTest(MousePoint, AddressOf ObjectMove2Mouse)

    End Sub

    Delegate Sub MathOperator(ByVal pt As Point3d)

    Sub DelegateTest(ByVal pt As Point3d, ByVal op As MathOperator)

        op.Invoke(pt)

    End Sub

    Public Sub ObjectMove2Mouse(ByVal pt As Point3d)

        Dim acadApp As AcadApplication = CType(Application.AcadApplication, AcadApplication)
        Dim acadDoc As AcadDocument = acadApp.ActiveDocument
        Try
            Static blnFirst As Boolean = False
            Static blnFst As Boolean = False
            Static objTem(2) As AcadObject

            Dim cirObj As AcadCircle
            Dim center(2) As Double
            Dim radius As Double
            Dim lineObj As AcadLine
            Dim sPnt(2), ePnt(2) As Double
            Dim textObj As AcadText
            Dim istPoint(2) As Double

            center(0) = pt(0) + 0 : center(1) = pt(1) + 0 : center(2) = pt(2) + 0 : radius = 50
            sPnt(0) = center(0) : sPnt(1) = center(1) : sPnt(2) = 0
            ePnt(0) = center(0) + 100 : ePnt(1) = center(1) + 100 : ePnt(2) = 0
            istPoint(0) = center(0) : istPoint(1) = center(1) : istPoint(2) = center(2)

            If blnFirst = True Then
                For i As Integer = 0 To 2
                    objTem(i).Delete()    '删除上次绘制的对象
                Next
                cirObj = acadDoc.ModelSpace.AddCircle(center, radius)  '创建一个圆对象
                cirObj.color = ACAD_COLOR.acRed                     '将圆的颜色设为红色
                lineObj = acadDoc.ModelSpace.AddLine(sPnt, ePnt)   '创建一条直线
                lineObj.Lineweight = ACAD_LWEIGHT.acLnWt060
                textObj = acadDoc.ModelSpace.AddText("哈！成了。", istPoint, 15) '创建单行文字
                textObj.color = ACAD_COLOR.acWhite

                objTem(0) = cirObj
                objTem(1) = lineObj
                objTem(2) = textObj
            Else

                cirObj = acadDoc.ModelSpace.AddCircle(center, radius)    '创建一个圆对象
                cirObj.color = ACAD_COLOR.acRed                      '将圆的颜色设为红色               
                lineObj = acadDoc.ModelSpace.AddLine(sPnt, ePnt)    '创建一条直线
                lineObj.Lineweight = ACAD_LWEIGHT.acLnWt060
                textObj = acadDoc.ModelSpace.AddText("哈！成了。", istPoint, 15) '创建单行文字
                textObj.color = ACAD_COLOR.acWhite

                objTem(0) = cirObj
                objTem(1) = lineObj
                objTem(2) = textObj
                blnFirst = True

            End If

        Catch ex As Exception

        End Try

    End Sub

End Class

azbd

加入鼠标事件方法值得借鉴，但采用不断加入数据库对象、再不断删除的方法来实现动态显示的方法不可取

scs5999

重新修改为利用块移动

Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Interop
Imports Autodesk.AutoCAD.Interop.Common

Public Class Class1

    <CommandMethod("mtest")> _
    Public Sub test()

        Dim ed As Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor
        Dim sd As New MotionalMousePoint
        AddHandler ed.PointFilter, AddressOf sd.GetMousePoint
        Dim pro As PromptPointOptions = New PromptPointOptions("请选择插入点...")
        ed.GetPoint(pro)

        RemoveHandler ed.PointFilter, AddressOf sd.GetMousePoint

    End Sub
End Class

Public Class MotionalMousePoint

    Private MousePoint As Point3d = New Point3d(0, 0, 0) '保存当前鼠标位置      
    ''动态获取鼠标位置   
    Public Sub GetMousePoint(ByVal sender As Object, ByVal e As PointFilterEventArgs)

        MousePoint = e.Context.ComputedPoint
        Dim m_ed As Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor

        DelegateTest(MousePoint, AddressOf Move2Mouse)

    End Sub

    Delegate Sub MathOperator(ByVal pt As Point3d)

    Sub DelegateTest(ByVal pt As Point3d, ByVal op As MathOperator)
        op.Invoke(pt)
    End Sub

    Public Sub Move2Mouse(ByVal pt As Point3d)

        Dim acadApp As AcadApplication = CType(Application.AcadApplication, AcadApplication)
        Dim acaddoc As AcadDocument = acadApp.ActiveDocument

        Try
            Static blnFirst As Boolean = False
            Static basePoint As Object

            Static blkRefObj As AcadBlockReference
            Dim insertPnt(2) As Double

            insertPnt(0) = pt(0) + 0 : insertPnt(1) = pt(1) + 0 : insertPnt(2) = pt(2) + 0    '指定模型空间的插入点

            Dim blkObject As AcadBlock
            Dim blkName As String = ""
            Dim blk As New CreateBlock

            For Each blkObject In acaddoc.Blocks()
                If blkObject.Name = "TestBlock1" And blnFirst = False Then
                    blkName = blkObject.Name
                    blkRefObj = acaddoc.ModelSpace.InsertBlock(insertPnt, blkName, 1.0#, 1.0#, 1.0#, 0.0#)    '插入图块
                    basePoint = blkRefObj.InsertionPoint
                    blnFirst = True
                    Exit For
                End If
            Next

            If blnFirst = True Then
                blkRefObj.Move(basePoint, insertPnt)
                basePoint = blkRefObj.InsertionPoint
            Else
                blkRefObj = blk.CreateBlock()
                blkRefObj.Delete()
                'blkRefObj.Update()
                'acaddoc.Regen(AcRegenType.acActiveViewport)
            End If
        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

End Class

Public Class CreateBlock

    Public Function CreateBlock() As AcadBlockReference
        Dim acadApp As AcadApplication = CType(Application.AcadApplication, AcadApplication)
        Dim acaddoc As AcadDocument = acadApp.ActiveDocument

        Dim blkObj As AcadBlock
        Dim insPnt(2) As Double
        Dim blkRefObj As AcadBlockReference
        Dim insertPnt(2) As Double

        insPnt(0) = 0 : insPnt(1) = 0 : insPnt(2) = 0
        insertPnt(0) = 0 : insertPnt(1) = 0 : insertPnt(2) = 0    '指定模型空间的插入点

        blkObj = acaddoc.Blocks.Add(insPnt, "TestBlock1") '在Blocks集合中创建名为TestBlock1的块对象

        '本段代码将在TestBlock1块对象中创建2个图元对象
        Dim cirObj As AcadCircle
        Dim center(0 To 2) As Double
        Dim radius As Double
        center(0) = 0 : center(1) = 0 : center(2) = 0 : radius = 38

        Dim lineObj As AcadLine
        Dim sPnt(2), ePnt(2) As Double
        sPnt(0) = center(0) : sPnt(1) = center(1) : sPnt(2) = 0
        ePnt(0) = center(0) + 60 : ePnt(1) = center(1) + 80 : ePnt(2) = 0

        cirObj = blkObj.AddCircle(center, radius)    '创建一个圆对象
        cirObj.color = ACAD_COLOR.acRed          '将圆的颜色设为红色
        lineObj = blkObj.AddLine(sPnt, ePnt)     '创建一条直线

        blkRefObj = acaddoc.ModelSpace.InsertBlock(insertPnt, "TestBlock1", 1.0#, 1.0#, 1.0#, 0.0#)    '插入图块
        Return blkRefObj
    End Function
End Class

lysgyx

十分感谢！！

学习一下

houlinbo

我现在也用的是这种方法，但还是有一些缺点：
1.需要删除添回循环；
2.移动过的地方都会留下对象捕捉点，使CAD中的对象捕捉功能不能很好利用；
3.不能像CAD中移动功能一样移动

sieben

没有详细看！只是这类问题不能利用Jig类吗？

claotlaot

收藏下来了，有时间学习学习

tbeahgl

我赞成SIEBEN的想法,我利用EntityJig类已编出代码,也比较好用.网上有关于这方面的资料.

lihezhou

这个只能说明是一个例子。实际应用是采用这样的方便是下策！