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

[KenBuja]

Most of it will go over directly. You'll have to add in "Set" to some of the statements and you won't need the fully qualified declarations (Dim activeView As IActiveView instead of Dim activeView As ESRI.ArcGIS.Carto.IActiveView, for example).

[OsmanSABAN]

Thank you again Ken,

I made some changes you mentioned and add some Public sub to setup the path to save the gif files and it works perfectly.

Now, another thing is that how can I do the same thing for spatial image files?

Any help?

Thank you


Private Sub ExportToGIF()

            Dim pActiveView As IActiveView
            Dim pRaster As IRaster
           
            Dim pMxDoc As IMxDocument
            Set pMxDoc = ThisDocument
           
            Dim pMap As IMap
            Set pMap = pMxDoc.FocusMap
           
            Set pActiveView = pMxDoc.activeView

            Dim pExtent As IEnvelope
            Set pExtent = pActiveView.extent

            Dim pEnumLayer As IEnumLayer
            Set pEnumLayer = pMap.Layers
            pEnumLayer.Reset

            Dim pLayer As ILayer
            Set pLayer = pEnumLayer.Next

            Do While Not (pLayer Is Nothing)
                pLayer.Visible = False
                Set pLayer = pEnumLayer.Next
            Loop

            pEnumLayer.Reset
            Set pLayer = pEnumLayer.Next
            Do While Not (pLayer Is Nothing)
                If TypeOf pLayer Is IFeatureLayer Then
                    pLayer.Visible = True
                    pActiveView.extent = pLayer.AreaOfInterest
                    pActiveView.Refresh
                    ExportLayout "GIF", "C:\Users\Desktop\" & pLayer.Name & ".gif", 175
                    'System.Windows.Forms.MessageBox.Show (pLayer.Name)
                   
                    pLayer.Visible = False
                End If
               
                Set pLayer = pEnumLayer.Next
            Loop

            pEnumLayer.Reset
            Set pLayer = pEnumLayer.Next
            Do While Not (pLayer Is Nothing)
                pLayer.Visible = True
                Set pLayer = pEnumLayer.Next
            Loop
            Set pExtent = pActiveView.extent '= pExtent
            pActiveView.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

[KenBuja · Accepted solution]

You'd just have to comment out where it checks if the layer is a Feature Layer

Do While Not (pLayer Is Nothing)   'If TypeOf pLayer Is IFeatureLayer Then   pLayer.Visible = True   pActiveView.extent = pLayer.AreaOfInterest   pActiveView.Refresh   ExportLayout "GIF", "C:\Users\Desktop\" & pLayer.Name & ".gif", 175   'System.Windows.Forms.MessageBox.Show (pLayer.Name)                        pLayer.Visible = False   'End If                    Set pLayer = pEnumLayer.Next Loop

Don't forget to mark the answer as correct and/or helpful

[OsmanSABAN]

Thank you Ken, I did mark it.

I am really appreciated with your help a lot.

Thank you again