Set the extent to features on the table of content then export it to jpeg/gif

[OsmanSABAN]

Hi all,

I want to export a multiple feature layer by zoom into it then export it as jpeg/gif file then loop through all feature listed on the table of contents. I need to select the feature then zoom into its extent and then export it as jpeg/gif but all the the feature are NTS sheets so all the other features has to be unselected when exporting one of them as jpeg/gif. And then unselect the one just exported then move to next one, select, zoom, export, unselect, etc for rest of the list.

I found below code online from http://www.cartotalk.com. what it does is that select each record in polygon attribute table, zoom to the extent of that polygon, then export the layout to a jpeg at whatever res you want. Then it moves on the next one.

I dont want to zoom into each features attribute table, I want to zoom into whole feature itself extent.

Please help me about this,

Thank you.


Option Explicit
Private m_pMxDoc As IMxDocument
Private m_pPageLayout As IPageLayout
Private m_pGContainer As IGraphicsContainer

Private Sub AddElement(AnElement As IElement, PagePosition As IGeometry)
    Set m_pMxDoc = ThisDocument
    Set m_pPageLayout = m_pMxDoc.PageLayout
    AnElement.geometry = PagePosition
    Set m_pGContainer = m_pPageLayout
    m_pGContainer.AddElement AnElement, 0
    m_pMxDoc.ActiveView.Refresh
   
End Sub

Public Sub DeleteElement(AnElement As IElement, PagePosition As IGeometry)
    Set m_pMxDoc = ThisDocument
    Set m_pPageLayout = m_pMxDoc.PageLayout
    AnElement.geometry = PagePosition
    Set m_pGContainer = m_pPageLayout
    m_pGContainer.DeleteElement AnElement
    m_pMxDoc.ActiveView.Refresh
   
End Sub

Public Sub ExportLayout(Format As String, FileName As String, dpi As Integer)

    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
   
    Dim pLayout As IActiveView
    Set pLayout = pMxDoc.PageLayout
   
    Dim rectOut As tagRECT
    rectOut = pLayout.exportFrame

    Dim pEnv As IEnvelope
    Set pEnv = New envelope
    pEnv.PutCoords rectOut.Left, rectOut.Top, rectOut.Right, rectOut.bottom

    Dim pExporter As IExporter
    If Format = "GIF" Then
        Set pExporter = New JpegExporter
    Else
        Set pExporter = New PDFExporter
    End If

    pExporter.ExportFileName = FileName
    pExporter.PixelBounds = pEnv
    pExporter.Resolution = dpi
    'Recalc the export frame to handle the increased number of pixels
    Set pEnv = pExporter.PixelBounds

    Dim xMin As Double, yMin As Double
    Dim xMax As Double, yMax As Double
    pEnv.QueryCoords xMin, yMin, xMax, yMax

    rectOut.Left = xMin
    rectOut.Top = yMin
    rectOut.Right = xMax
    rectOut.bottom = yMax

    'Do the export
    Dim hdc As Long
    hdc = pExporter.StartExporting

    pLayout.Output hdc, dpi, rectOut, Nothing, Nothing
    pExporter.FinishExporting
   
    'MsgBox "Export complete!", vbInformation
   
End Sub

Public Sub PanZoomTitleExportWatersheds()

    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
   
    Dim strImageName As String
   
    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap
   
    Dim pPageLayout As IPageLayout
    Set pPageLayout = pMxDoc.PageLayout
   
    Dim pActiveView As IActiveView
   
    Set pActiveView = pMxDoc.FocusMap   ' Set to FocusMap, allows zoom to work in page layout or data view
   
    Dim pFeatureLayer As IFeatureLayer
    Set pFeatureLayer = pMap.layer(0)   ' First layer in map
   
    Dim pFeatureClass As IFeatureClass
    Set pFeatureClass = pFeatureLayer.featureClass
   
    Dim pFeatureCursor As IFeatureCursor
    Set pFeatureCursor = pFeatureClass.Search(Nothing, False)   ' Set QF to Nothing, get all features
   
    Dim pFeature As IFeature
    Dim Counter As Integer
    Dim pEnvelope As IEnvelope
    Dim pLayer As IFeatureLayer
       
    Set pFeature = pFeatureCursor.NextFeature  ' clear it, get the first feature
   
    Do Until pFeature Is Nothing
        Counter = Counter + 1
       
        ' Create image file name from attributes
        strImageName = ReplaceMultiple(pFeature.Value(5), "_", " ", ",", "-", ".") & "_" & pFeature.Value(9) 'ReplaceMultiple gets rid of spaces/special characters in names
        ' Zoom
        pActiveView.Extent = pFeature.Shape.envelope
        ' Set the extent to that of the active view
        Set pEnvelope = pActiveView.Extent
            ' Expand out a little bit
            If (pFeature.Shape.envelope.width / pFeature.Shape.envelope.height) < 0.3 Then
                pEnvelope.Expand 2, 2, True
            Else
                pEnvelope.Expand 1.25, 1.25, True
            End If
        ' Center
        pActiveView.Extent = pEnvelope
        ' Refresh after zoom
        pActiveView.Refresh
        'MsgBox strImageName
        ' Call ExportLayout, export the current layout
        ExportLayout "GIF", "C:\Users\osaban\Desktop\Datasets-In Process\Canada Land Inventory (150 000) - Land Capability for Agriculture\Alberta\" & strImageName & ".gif", 175
        ' Refresh after deletion
        pActiveView.Refresh
        ' Go to next
        Set pFeature = pFeatureCursor.NextFeature
    Loop
   
End Sub

Public Function ReplaceMultiple(ByVal OrigString As String, _
     ByVal ReplaceString As String, ParamArray FindChars()) _
     As String

    '*********************************************************
    'PURPOSE: Replaces multiple substrings in a string with the
    'character or string specified by ReplaceString
   
    'PARAMETERS: OrigString -- The string to replace characters in
    '            ReplaceString -- The replacement string
    '            FindChars -- comma-delimited list of
    '                 strings to replace with ReplaceString
    '
    'RETURNS:    The String with all instances of all the strings
    '            in FindChars replaced with Replace String
    'EXAMPLE:    s= ReplaceMultiple("H;*()ello", "", ";", ",", "*", "(", ")") -
                 'Returns Hello
    'CAUTIONS:   'Overlap Between Characters in ReplaceString and
    '             FindChars Will cause this function to behave
    '             incorrectly unless you are careful about the
    '             order of strings in FindChars
    '***************************************************************
   
    Dim lLBound As Long
    Dim lUBound As Long
    Dim lCtr As Long
    Dim sAns As String
   
    lLBound = LBound(FindChars)
    lUBound = UBound(FindChars)
   
    sAns = OrigString
   
    For lCtr = lLBound To lUBound
        sAns = Replace(sAns, CStr(FindChars(lCtr)), ReplaceString)
    Next
   
    ReplaceMultiple = sAns
       

End Function

Public Function MakeGifFileName(strHucName As String, strHucNumber As String) As String
   
    If Trim(strHucName) = "" Then
        MakeGifFileName = Trim(strHucNumber)
    Else
        MakeGifFileName = Trim(strHucNumber) & "_" & ReplaceMultiple(ReplaceMultiple(strHucName, "_", " ", "-"), "", "'", ".", ",")
    End If

End Function

[MLowry]

Any reason you're not using Python for this workflow?

[OsmanSABAN]

i dont have any reason to use python. That's what I found for what I needed. do you have any suggestions?

please help

Thanks

[OsmanSABAN]

Hi all,

Please help me about this

Thank you

[KenBuja]

Which version of ArcGIS are you using?

[OsmanSABAN]

Which version of ArcGIS are you using?

I am using ArcGIS 10.

[KenBuja]

I'm having difficulty in trying to understand your goals. Can you provide an illustration of what you're trying to achieve?

[OsmanSABAN]

I am sending some images to clear things little bit.

In image NTS Sheet, that is what I have as dataset in the data frame window, each of of them is a different shape file adjacent to each other. I want to go through table of content layers then zoom into first one and export it as jpg or gif while the adjacent nts sheets are turned off.

The final product should look like 083H120_1, not like as in 083H120.

I hope this helps to clear it out.

Thank you

[KenBuja]

Here is some code written in VB.NET ( so you'll have to do some slight modifications for VBA) that will loop through the table of contents three times. The code first gets the original extent of the activeview. The first loop will turn off all the layers. The second loop will turn on a layer and zoom to its extent, pops up a message box to pause the operation, then turns the layer off. The third loop turns the layers back on once again. Finally, the activeview is set back to the original extent.

            Dim activeView As ESRI.ArcGIS.Carto.IActiveView
            activeView = pMxDoc.ActiveView

            Dim extent As ESRI.ArcGIS.Geometry.IEnvelope
            extent = activeView.Extent

            Dim pMap As ESRI.ArcGIS.Carto.IMap
            pMap = pMxDoc.FocusMap

            Dim enumLayer As ESRI.ArcGIS.Carto.IEnumLayer
            enumLayer = pMap.Layers
            enumLayer.Reset()

            Dim layer As ESRI.ArcGIS.Carto.ILayer
            layer = enumLayer.Next

            Do While Not (layer Is Nothing)
                layer.Visible = False
                layer = enumLayer.Next
            Loop

            enumLayer.Reset()
            layer = enumLayer.Next
            Do While Not (layer Is Nothing)
                If TypeOf layer Is ESRI.ArcGIS.Carto.IFeatureLayer Then
                    layer.Visible = True
                    activeView.Extent = layer.AreaOfInterest
                    activeView.Refresh()
                    System.Windows.Forms.MessageBox.Show(layer.Name)
                    layer.Visible = False
                End If
                layer = enumLayer.Next
            Loop

            enumLayer.Reset()
            layer = enumLayer.Next
            Do While Not (layer Is Nothing)
                layer.Visible = True
                layer = enumLayer.Next
            Loop
            activeView.Extent = extent
            activeView.Refresh()

[OsmanSABAN]

Thank you Ken, I dont know how to integrate this into VBA but i will try it out.