Archived Forums

Private Sub ConvertIndexPolygonGraphicToShape()

    ' adds all the selected Polygon Elements to the current edit layer

    Dim pFeatureLayer As IFeatureLayer
    Dim pMxDocument As IMxDocument

        Set pMxDocument = ThisDocument
        Set pFeatureLayer = pMxDocument.FocusMap.Layer(0)

    StartEditingMapExtentPolygon
    
    Dim pElementCollection As IElementCollection
        Set pElementCollection = GetElements(pMxDocument.FocusMap)
            
        If pElementCollection.Count > 0 Then
                pEditor.StartOperation
            Dim pEditLayers As IEditLayers
                Set pEditLayers = pEditor
                WriteElements pEditLayers.CurrentLayer.FeatureClass, pElementCollection
                pEditor.StopOperation "AddGraphics2FeatClass"
                DeleteElements pMxDocument.FocusMap, pElementCollection
        End If
' Stop the Editing session
        'StopEditingMapExtentPolygon
End Sub

Function GetElements(pGraphicsContainerSelect As IGraphicsContainerSelect) As IElementCollection

    Set GetElements = New ElementCollection
    Dim l As Long
    For l = 0 To pGraphicsContainerSelect.ElementSelectionCount - 1
        If TypeOf pGraphicsContainerSelect.SelectedElement(l) Is IPolygonElement Then
            GetElements.Add pGraphicsContainerSelect.SelectedElement(l)
        End If
    Next l
End Function

Sub DeleteElements(pGraphicsContainer As IGraphicsContainer, pElementCollection As IElementCollection)

    Dim pActiveView As IActiveView
    Set pActiveView = pGraphicsContainer
    
    ' for refresh envelope
    Dim d As Double
    d = pActiveView.ScreenDisplay.DisplayTransformation.FittedBounds.Width / 20#
    
    Dim l As Long
    Dim pElement As IElement
    Dim pEnvelope As IEnvelope
    
    For l = 0 To pElementCollection.Count - 1
        pElementCollection.QueryItem l, pElement
        pGraphicsContainer.DeleteElement pElement
        Set pEnvelope = pElement.Geometry.Envelope
        pEnvelope.Expand d, d, False
        pActiveView.PartialRefresh esriViewGraphics + esriViewGeography, Nothing, pEnvelope
    Next l
End Sub

Sub WriteElements(pFeatureClass As IFeatureClass, pElementCollection As IElementCollection)

    Dim pFeatureCursor As IFeatureCursor
        Set pFeatureCursor = pFeatureClass.Insert(True)
    Dim pFeatureBuffer As IFeatureBuffer
        Set pFeatureBuffer = pFeatureClass.CreateFeatureBuffer
    Dim l As Long
    Dim pElement As IElement
        
        If pFeatureClass.ShapeType = esriGeometryPolygon Then
                For l = 0 To pElementCollection.Count - 1
                    pElementCollection.QueryItem l, pElement
                Set pFeatureBuffer.Shape = pElement.Geometry
                    pFeatureCursor.InsertFeature pFeatureBuffer
                Next l
            pFeatureCursor.Flush
        End If
End Sub

Private Sub ConvertIndexPolygonGraphicToShape(pFeatureLayer As IFeatureLayer)

    ' adds all the selected Polygon Elements to the current edit layer

    'Dim pFeatureLayer As IFeatureLayer
    Dim pMxDocument As IMxDocument

        Set pMxDocument = ThisDocument
        'Set pFeatureLayer = pMxDocument.FocusMap.Layer(0)
        'Set pFeatureLayer = pMxDocument.PageLayout

    StartEditingMapExtentPolygon
    
    Dim pElementementCollection As IElementCollection
        Set pElementementCollection = GetElements(pMxDocument.PageLayout)
            
        If pElementementCollection.Count > 0 Then
                pEditor.StartOperation
            Dim pEditLayers As IEditLayers
                Set pEditLayers = pEditor
                WriteElements pEditLayers.CurrentLayer.FeatureClass, pElementementCollection
                pEditor.StopOperation "AddGraphics2FeatClass"
                DeleteElements pMxDocument.FocusMap, pElementementCollection
        End If
' Stop the Editing session
        StopEditingMapExtentPolygon
End Sub

Function GetElements(pGraphicsContainerSelect As IGraphicsContainerSelect) As IElementCollection

    Set GetElements = New ElementCollection
    Dim l As Long
    For l = 0 To pGraphicsContainerSelect.ElementSelectionCount - 1
        If TypeOf pGraphicsContainerSelect.SelectedElement(l) Is IPolygonElement Then
            GetElements.Add pGraphicsContainerSelect.SelectedElement(l)
        End If
    Next l
End Function

Function GetElements(pGraphicsContainerSelect As IGraphicsContainerSelect) As IElementCollection

    Set GetElements = New ElementCollection
    Dim l As Long
    For l = 0 To pGraphicsContainerSelect.ElementSelectionCount - 1
        If TypeOf pGraphicsContainerSelect.SelectedElement(l).Geometry Is IPolygon Then
            GetElements.Add pGraphicsContainerSelect.SelectedElement(l)
        End If
    Next l
End Function

Function GetElements(pGraphicsContainerSelect As IGraphicsContainerSelect) As IElementCollection

    Set GetElements = New ElementCollection
    Dim l As Long
    For l = 0 To pGraphicsContainerSelect.ElementSelectionCount - 1
        If TypeOf pGraphicsContainerSelect.SelectedElement(l) Is IFillShapeElement Then
            GetElements.Add pGraphicsContainerSelect.SelectedElement(l)
        End If
    Next l
End Function

Public Sub CreateIndexElement()
    
    Dim pMxDocument As IMxDocument
        Set pMxDocument = ThisDocument
    
    Dim pRectangleElement As IElement
    
    Dim pGraphicsContainer As IGraphicsContainer
        Set pGraphicsContainer = pMxDocument.PageLayout

        pGraphicsContainer.Reset
    
    Dim pElement As IElement
        Set pElement = pGraphicsContainer.Next
        
    
    Dim OffSwitch As Boolean
        OffSwitch = False
            
            Do While OffSwitch = False
                If TypeOf pElement Is IMapFrame Then
                    Set pRectangleElement = New RectangleElement
                    pRectangleElement.Geometry = pElement.Geometry
                    OffSwitch = True
                End If
            Set pElement = pGraphicsContainer.Next
            Loop
      
    Dim pLayoutView As IActiveView
    Dim pMapView As IActiveView
    Dim pMap As IMap
        Set pMap = pMxDocument.FocusMap
        Set pLayoutView = pMxDocument.PageLayout

        Set pMapView = pMap
        Set pMxDocument.ActiveView = pLayoutView
  
  'Get the display transformations
    Dim pPageTransformation As IDisplayTransformation
    Dim pMapTransformation As IDisplayTransformation
        Set pPageTransformation = pLayoutView.ScreenDisplay.DisplayTransformation
        Set pMapTransformation = pMapView.ScreenDisplay.DisplayTransformation
        
  'Transform envelope from page to map coordinates
    Dim Rect As tagRECT
    Dim pEnv As IEnvelope
        Set pEnv = pRectangleElement.Geometry.Envelope
    'Transform from Page units to Device units
        pPageTransformation.TransformRect pEnv, Rect, esriTransformToDevice + esriTransformPosition + esriTransformSize
    'Transform from Device units to Map units
        pMapTransformation.TransformRect pEnv, Rect, esriTransformToMap + esriTransformPosition

    Dim pPointCollection As IPointCollection
        Set pPointCollection = New Polygon
            With pPointCollection
                .AddPoint pEnv.LowerLeft
                .AddPoint pEnv.UpperLeft
                .AddPoint pEnv.UpperRight
                .AddPoint pEnv.LowerRight
            End With
    
    'Query interface to IPolygon to close the geometry
    Dim pPolygon As IPolygon
        Set pPolygon = pPointCollection
    Dim pNewElement As IElement
        Set pNewElement = New PolygonElement
        pNewElement.Geometry = pPolygon

     
    Dim pGraphicsContainer2 As IGraphicsContainer
        Set pGraphicsContainer2 = pMxDocument.FocusMap
        pGraphicsContainer2.AddElement pNewElement, 0

        'Select the Polygon element
    Dim pGraphicsContainerSelect As IGraphicsContainerSelect
        Set pGraphicsContainerSelect = pGraphicsContainer2
        pGraphicsContainerSelect.SelectElement pNewElement
        
        Set pMxDocument.ActiveView = pMapView
        pMxDocument.ActiveView.Refresh

End Sub