Hi!
i restart my posting of https://forums.autodesk.com/t5/net/vb-net-topobase-draw-area-of-display-model/td-p/7235171 in this Group again.
after add the code of drewbb my code looks like:
Public Sub DrawDM(Document As Autodesk.Map.IM.Forms.Document, Optional ByVal Silent As Boolean = True) Dim DM_Name As String = "O:\Map2015-Darstellungsmodelle\ALKIS 20170125\ALKIS für DWG.tbdm" Dim Msg As String = "" Dim acDocMgr As DocumentCollection = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager Dim acDoc As Autodesk.AutoCAD.ApplicationServices.Document = acDocMgr.MdiActiveDocument Dim extents2d As Autodesk.AutoCAD.DatabaseServices.Extents2d = _AcadSrv.GetCurrentViewBound() If System.IO.File.Exists(DM_Name) = False Then If Silent = False Then MsgBox("Darstellungsmodell nicht gefunden!", MsgBoxStyle.Critical, k_AppName_Vermessung) End If Exit Sub End If If IsNothing(Document) Then If Silent = False Then MsgBox("Es ist kein Dokument zugewiesen!", MsgBoxStyle.Critical, k_AppName_Vermessung) End If Exit Sub End If Dim graphicsGenerator As Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator Try graphicsGenerator = Document.Application.Services.GetService(Of Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator)() 'Bildaufbau Dim filterSetter As IFilterSetter = FilterSetterFactory.Create(graphicsGenerator.DisplayModel) filterSetter.OnlyOnTopobaseLayers = True filterSetter.TransformCoordSysInFilter = True Dim polygon = New Autodesk.Map.IM.Graphic.Polygon() From { _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MinPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MaxPoint.X, extents2d.MinPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MaxPoint.X, extents2d.MaxPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MaxPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MinPoint.Y) _ } filterSetter.ApplyViewport(polygon) Dim displayRepository As Autodesk.Map.IM.Display.DisplayModelManagement.IDisplayModelRepository displayRepository = graphicsGenerator.DisplayModelRepository Dim RepositoryPath As String RepositoryPath = graphicsGenerator.DisplayModelRepository.RepositoryDirectory.ToString() graphicsGenerator.DisplayModel = displayRepository.Load(DM_Name) 'graphicsGenerator.DisplayModel = displayRepository.Load(RepositoryPath + "\" + "MeinDarstellungsmodell.tbdm") graphicsGenerator.ShowProgressBar = True Dim mydocuments As System.Collections.Generic.ICollection(Of Autodesk.Map.IM.Display.GraphicsGeneration.IDocument) 'acDoc As Autodesk.AutoCAD.ApplicationServices.Document Dim docLock As DocumentLock = acDoc.LockDocument Using docLock mydocuments = graphicsGenerator.Draw End Using Catch ex As Exception Dim TryReport As New EBL.Service.TryCatchReport TryReport.Show("unerwarteter Fehler in EBL.Import.SielVerm > VermSielPunktImport", ex.ToString) Finally graphicsGenerator.ShowProgressBar = False End Try End Sub
GetCurrentViewBound is a function to generate the min/max-coord of the current Screen. this works correct.
if i start my function it draw everytime the complete DM ! for the draw-process the screen zoom automatically to limit.
could someone help?
regards Jan
Solved! Go to Solution.
Solved by jan_tappenbeck. Go to Solution.
Dear Robert,
thanks - but i did not understand ... complete -
i try following - but without success !
... Dim graphicsGenerator As Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator Try graphicsGenerator = Document.Application.Services.GetService(Of Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator)() Dim displayRepository As Autodesk.Map.IM.Display.DisplayModelManagement.IDisplayModelRepository displayRepository = graphicsGenerator.DisplayModelRepository Dim RepositoryPath As String RepositoryPath = graphicsGenerator.DisplayModelRepository.RepositoryDirectory.ToString() graphicsGenerator.DisplayModel = displayRepository.Load(DM_Name) 'graphicsGenerator.DisplayModel = displayRepository.Load(RepositoryPath + "\" + "MeinDarstellungsmodell.tbdm") Dim filterSetter As IFilterSetter = FilterSetterFactory.Create(graphicsGenerator.DisplayModel) Select Case SelectionStatus Case Opt_CScreen 'BildSchirm extents2d = _AcadSrv.GetCurrentViewBound() filterSetter.OnlyOnTopobaseLayers = True filterSetter.TransformCoordSysInFilter = True Dim polygon = New Autodesk.Map.IM.Graphic.Polygon() From { _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MinPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MaxPoint.X, extents2d.MinPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MaxPoint.X, extents2d.MaxPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MaxPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MinPoint.Y) _ } filterSetter.ApplyViewport(polygon) ...
i move some lines to more to the top.
(auf gut deutsch - ich hab es nicht ganz verstanden und try&error hat nicht geklappt!)
could you give a tip to me?
regards Jan
hi !
here the complete working source:
Public Sub DrawDM(Document As Autodesk.Map.IM.Forms.Document, Optional ByVal Silent As Boolean = True) Dim DM_Name As String = "O:\Map2015-Darstellungsmodelle\ALKIS 20170125\ALKIS für DWG.tbdm" Dim Msg As String = "" Dim acDocMgr As DocumentCollection = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager Dim SelectionStatus As String = "NONE" Dim Opt_Exit As String = "Ende" Dim Opt_All As String = "Alles" Dim Opt_CScreen As String = "Bildschirm" Dim Opt_Window As String = "Fenster" Dim Opt_Yes As String = "Ja" Dim Opt_No As String = "Nein" Reinit() Dim extents2d As Autodesk.AutoCAD.DatabaseServices.Extents2d = Nothing If System.IO.File.Exists(DM_Name) = False Then If Silent = False Then MsgBox("Darstellungsmodell nicht gefunden!", MsgBoxStyle.Critical, k_AppName_Vermessung) End If Exit Sub End If If IsNothing(Document) Then If Silent = False Then MsgBox("Es ist kein Dokument zugewiesen!", MsgBoxStyle.Critical, k_AppName_Vermessung) End If Exit Sub End If Dim opt0 As New Autodesk.AutoCAD.EditorInput.PromptKeywordOptions(vbLf & "Select an entity:") opt0.AllowNone = True opt0.Keywords.Add(Opt_All) opt0.Keywords.Add(Opt_CScreen) opt0.Keywords.Add(Opt_Window) opt0.Keywords.Add("Ende") opt0.Keywords.[Default] = Opt_Window ' ausblenden einer Option in der []-Liste - index nullbasiert 'opt0.Keywords(2).Visible = False While True Dim res0 As Autodesk.AutoCAD.EditorInput.PromptResult = _Editor.GetKeywords(opt0) If res0.Status = Autodesk.AutoCAD.EditorInput.PromptStatus.OK Then ' hier muss keine Prüfung auf unzulässige Begriffe erfolgen. SelectionStatus = res0.StringResult Exit While Else Exit Sub End If End While ' Nachfrage, wenn aktuell ein Darstellungsmodell gelanden ist. If IsDMLoaded() = True Then Dim opt1 As New Autodesk.AutoCAD.EditorInput.PromptKeywordOptions(vbLf & "Soll das aktuelle Darstellungsmodell gelöscht werden:") opt1.AllowNone = True opt1.Keywords.Add(Opt_Yes) opt1.Keywords.Add(Opt_No) opt1.Keywords.Add(Opt_Exit) opt1.Keywords.[Default] = Opt_Yes Dim res1 As Autodesk.AutoCAD.EditorInput.PromptResult = _Editor.GetKeywords(opt1) If res1.Status = Autodesk.AutoCAD.EditorInput.PromptStatus.OK Then Select Case res1.StringResult Case Opt_Yes MsgBox("Layer löschen") Case Opt_Exit Exit Sub End Select Else Exit Sub End If End If Dim graphicsGenerator As Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator Try Select Case SelectionStatus Case Opt_CScreen 'BildSchirm extents2d = _AcadSrv.GetCurrentViewBound() Case Opt_Window extents2d = _AcadSrv.GetWindowCorner() If IsNothing(extents2d) Then _Editor.WriteMessage(vbCrLf & "KEIN Fenster gewählt! - Funktion wurde abgebrochen.") End If End Select graphicsGenerator = Document.Application.Services.GetService(Of Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator)() Dim displayRepository As Autodesk.Map.IM.Display.DisplayModelManagement.IDisplayModelRepository displayRepository = graphicsGenerator.DisplayModelRepository Dim RepositoryPath As String RepositoryPath = graphicsGenerator.DisplayModelRepository.RepositoryDirectory.ToString() graphicsGenerator.DisplayModel = displayRepository.Load(DM_Name) 'graphicsGenerator.DisplayModel = displayRepository.Load(RepositoryPath + "\" + "MeinDarstellungsmodell.tbdm") If Not IsNothing(extents2d) Then graphicsGenerator = Document.Application.Services.GetService(Of Autodesk.Map.IM.Display.GraphicsGeneration.IGraphicsGenerator)() Dim filterSetter As IFilterSetter = FilterSetterFactory.Create(graphicsGenerator.DisplayModel) filterSetter.OnlyOnTopobaseLayers = True filterSetter.TransformCoordSysInFilter = True Dim polygon = New Autodesk.Map.IM.Graphic.Polygon() From { _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MinPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MaxPoint.X, extents2d.MinPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MaxPoint.X, extents2d.MaxPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MaxPoint.Y), _ New Autodesk.Map.IM.Graphic.LinePoint(extents2d.MinPoint.X, extents2d.MinPoint.Y) _ } filterSetter.ApplyViewport(polygon) End If graphicsGenerator.ShowProgressBar = True Dim mydocuments As System.Collections.Generic.ICollection(Of Autodesk.Map.IM.Display.GraphicsGeneration.IDocument) 'acDoc As Autodesk.AutoCAD.ApplicationServices.Document Dim docLock As DocumentLock = _AcDocument.LockDocument Using docLock mydocuments = graphicsGenerator.Draw End Using _MiscSrv.ZoomVorher() ' Ansicht wiederherstellen Catch ex As Exception Dim TryReport As New EBL.Service.TryCatchReport TryReport.Show("unerwarteter Fehler in EBL.Import.SielVerm > VermSielPunktImport", ex.ToString) Finally graphicsGenerator.ShowProgressBar = False End Try End Sub
Jan
Can't find what you're looking for? Ask the community or share your knowledge.