AnsweredAssumed Answered

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

Question asked by balparmak on Feb 3, 2012
Latest reply on Feb 15, 2012 by balparmak
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

Outcomes