利用VB写的随鼠标移动的图形乐筑天下

scs5999 发表于 2008-1-24 11:25:00

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

Imports Autodesk..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
_
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 发表于 2008-1-27 09:59:00

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

scs5999 发表于 2008-1-28 21:08:00

重新修改为利用块移动
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
_
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 发表于 2008-3-5 09:57:00

十分感谢！！
学习一下

houlinbo 发表于 2008-3-28 11:34:00

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

sieben 发表于 2008-3-29 11:38:00

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

claotlaot 发表于 2008-6-29 17:04:00

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

tbeahgl 发表于 2008-9-20 11:17:00

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

lihezhou 发表于 2015-1-7 18:32:00

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

页: [1]

乐筑天下's Archiver

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