[编程交流] [vb.net]UCS问题

Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Public Class STSCCommands
   <CommandMethod("BTM")> _
   Public Sub Tester()
       Dim strBlkName As String = "Arrow_E" 'change to suit
       Dim strBlkPath As String = "C:\STCustomCommon\Arrow_E.dwg" 'change to suit
       If Block2Mid(strBlkName, strBlkPath) Then
           Application.DocumentManager.MdiActiveDocument.Editor.WriteMessage(vbCr & "Block insertion successful.")
       End If
   End Sub
   Public Function Block2Mid(ByVal strBlkName As String, ByVal strBlkPath As String) As Boolean
       Dim db As Database = HostApplicationServices.WorkingDatabase
       Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
       Dim ucsMat As Matrix3d = ed.CurrentUserCoordinateSystem
       Dim bt As BlockTable
       Dim btr As BlockTableRecord
       Dim btrSpace As BlockTableRecord
       Dim entBref As BlockReference
       Dim ppo As PromptPointOptions = New PromptPointOptions("Select first point: ")
       ppo.AllowNone = False
       ppo.AllowArbitraryInput = False
       Dim ppr As PromptPointResult = ed.GetPoint(ppo)
       If ppr.Status = PromptStatus.Cancel Or ppr.Status = PromptStatus.Error Then Exit Function
       Dim p3d1 As Point3d = ppr.Value
       ppo.UseBasePoint = True
       ppo.BasePoint = p3d1
       ppo.Message = vbCr & "Select second point: "
       ppr = ed.GetPoint(ppo)
       If ppr.Status = PromptStatus.Cancel Or ppr.Status = PromptStatus.Error Then Exit Function
       Dim p3d2 As Point3d = ppr.Value
       Dim v3d1 As Vector3d = p3d1.GetAsVector()
       Dim v3d2 As Vector3d = p3d2.GetAsVector()
       v3d2 = v3d2 - v3d1
       v3d2 = v3d1 + (v3d2 / 2.0)
       Dim midPt As Point3d = New Point3d(v3d2.ToArray())
       p3d1 = p3d1.TransformBy(ucsMat)
       p3d2 = p3d2.TransformBy(ucsMat)
       midPt = midPt.TransformBy(ucsMat)
       Dim entLine As Line = New Line(p3d1, p3d2)
       Using tr As Transaction = db.TransactionManager.StartTransaction()
           bt = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
           If bt.Has(strBlkName) Then
               btr = tr.GetObject(bt.Item(strBlkName), OpenMode.ForRead)
           Else
               btr = RtrvBlk(strBlkName, strBlkPath, ed, db)
               If btr = Nothing Then
                   Block2Mid = False
                   Exit Function
               End If
           End If
           Try
               btrSpace = tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite)
               btrSpace.AppendEntity(entLine)
               entBref = New BlockReference(midPt, btr.ObjectId)
               entBref.Normal = ucsMat.CoordinateSystem3d.Zaxis
               entBref.Position = midPt 'requires re-positioning after Normal mod
               btrSpace.AppendEntity(entBref)
               tr.AddNewlyCreatedDBObject(entLine, True)
               tr.AddNewlyCreatedDBObject(entBref, True)
               tr.Commit()
           Catch ex As System.Exception
               ed.WriteMessage(ex.Message)
               Block2Mid = False
           End Try
           Block2Mid = True
       End Using
   End Function
   Public Function RtrvBlk(ByVal strBlkName As String, ByVal strBlkPath As String, ByRef ed As Editor, ByRef db As Database) As BlockTableRecord
       Dim bt As BlockTable
       Dim btr As BlockTableRecord = Nothing
       Dim id As ObjectId
       Dim actDoc As Document = Application.DocumentManager.MdiActiveDocument
       Using tr As Transaction = db.TransactionManager.StartTransaction()
           Try
               bt = tr.GetObject(db.BlockTableId, OpenMode.ForWrite)
               Using importDb As Database = New Database(False, False)
                   Try
                       importDb.ReadDwgFile(strBlkPath, IO.FileShare.Read, True, "")
                       id = db.Insert(strBlkPath, importDb, True)
                       btr = tr.GetObject(id, OpenMode.ForWrite)
                       btr.Name = strBlkName
                       btr.DowngradeOpen()
                   Catch ex As System.Exception
                       ed.WriteMessage(ex.Message)
                       Return Nothing
                       Exit Function
                   Finally
                       importDb.Dispose()
                   End Try
               End Using
               tr.Commit()
           Catch ex As System.Exception
               ed.WriteMessage(ex.Message)
           End Try
       End Using
       Return btr
   End Function
End Class