|
|
发表于 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
|
|
置顶卡
