vb.net - Topobase - draw area of display-model

[jan_tappenbeck]

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

[Anonymous]

Hi Jan,

just a guess - load the DM before you apply the filter.

Rob

[jan_tappenbeck]

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

[jan_tappenbeck · Accepted solution]

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