Code:
Imports System.IO
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.GeometryPublic Class XRef
Private _AcLog As EBL.AcadLogger.AcLog
Private _TryReport As New EBL.Logger.TryCatchReport
Public Sub New(AcLog As EBL.AcadLogger.AcLog)
If Not IsNothing(AcLog) Then _AcLog = AcLog
End Sub
''' <summary>
''' Xref(s) anhängen
''' </summary>
''' <param name="fileNames">Dateinamen</param>
''' <param name="XrefLayer">optional aus welchem Layer ablegen (default:= 0)</param>
''' <param name="InsertPoint">optional Einfügepunkt (default:= nothing ... 0,0,0)</param>
Public Sub attach(ByVal fileNames As String(), Optional XrefLayer As String = "0", Optional InsertPoint As Point3d = Nothing)
Dim Editor As Autodesk.AutoCAD.EditorInput.Editor
Dim acDoc As Autodesk.AutoCAD.ApplicationServices.Document
'--- aus https://www.theswamp.org/index.php?topic=31863.0
acDoc = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim acDb As Database = acDoc.Database
Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor
If IsNothing(InsertPoint) Then ' wenn keiner angegeben wird, dann 0,0,0
InsertPoint = New Point3d(0, 0, 0)
End If
Array.Sort(fileNames)
Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
Dim dimScale As Double = db.Dimscale
For Each fileName As String In fileNames
Try
''Dim options As PromptPointOptions = New PromptPointOptions("Pick insertion point for " & fileName & ": ")
''options.AllowNone = False
''Dim pt As PromptPointResult = Editor.GetPoint(options)
''If pt.Status <> PromptStatus.OK Then Continue For
Dim xrefScale As Double = getDwgScale(fileName)
Dim scaleFactor As Double = dimScale / xrefScale
Using tr As Transaction = Application.DocumentManager.MdiActiveDocument.TransactionManager.StartTransaction()
Dim xrefId As ObjectId = db.AttachXref(fileName, Path.GetFileNameWithoutExtension(fileName))
Dim blockRef As BlockReference = New BlockReference(InsertPoint, xrefId)
Dim layoutBlock As BlockTableRecord = CType(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
blockRef.ScaleFactors = New Scale3d(scaleFactor, scaleFactor, scaleFactor)
blockRef.Layer = XrefLayer
layoutBlock.AppendEntity(blockRef)
tr.AddNewlyCreatedDBObject(blockRef, True)
tr.Commit()
End Using
Catch ex As Exception
_TryReport.Show("unerwarteter Fehler in EBL.Acad > EBL_XREF > attach", "Filename:= " & fileName, ex.ToString, Log:=_AcLog)
End Try
Next
End Sub
Private Function getDwgScale(ByVal fileName As String) As Double
Using db As Database = New Database(False, True)
db.ReadDwgFile(fileName, FileOpenMode.OpenForReadAndAllShare, False, String.Empty)
Return db.Dimscale
End Using
End Function
End Class
Foren auf CAD.de (alle Foren)
| 
