5 replies to this topic

[benbakelaar]

Basically, the same idea as this ESRI Support forum post:
http://forums.esri.c...t=170182#501259

In my case, I want to be able to do a selection of states (or all states if selection is too tricky) as a batch process. I understand what I'm basically asking is how to run a batch zoom/export script on a selected bunch of polygons, or all polygons in a layer.

[paul]

Basically, the same idea as this ESRI Support forum post:
http://forums.esri.c...t=170182#501259

In my case, I want to be able to do a selection of states (or all states if selection is too tricky) as a batch process. I understand what I'm basically asking is how to run a batch zoom/export script on a selected bunch of polygons, or all polygons in a layer.

How familiar are you with VBA and ArcObjects? I've made a vba script that does this exact thing with map sheets and exporting to .pdf. It will batch export an entire map atlas based on the sheet range the user inputs. The same principles and code would apply to what you want to do, it would just have to be tweaked a bit to work. If you want, I can upload or email it to you.

[supercooper]

This script will programmatically select each record in polygon attribute table, zoom to the extent of that polygon, create a textbox on the layout with attribute data in it, then export the layout to a jpeg at whatever res you want. Then it moves on the next one. I used it to create watershed maps like these:

Watershed Maps created with script

The polygon layer to zoom to needs to be the topmost layer in the map.

' ############  BEGIN CODE  ###############



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 = "JPEG" 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

	

	'////////////////////////////////////////////////////////

	' 1) Begin title box creation

	

	' Colors

	' Text

	Dim pTitleColorHSV As IHsvColor

	Set pTitleColorHSV = New HsvColor

	pTitleColorHSV.Hue = 0

	pTitleColorHSV.Saturation = 0

	pTitleColorHSV.Value = 0

	

	' Background fill

	Dim pFillColorHSV As IHsvColor

	Set pFillColorHSV = New HsvColor

	pFillColorHSV.Hue = 0

	pFillColorHSV.Saturation = 0

	pFillColorHSV.Value = 97

		

	Dim pTitleSymbol As IFormattedTextSymbol

	Set pTitleSymbol = New TextSymbol

	

	Dim pTitleText As ITextElement

	Set pTitleText = New TextElement

	   

	Dim pTitleCallout As IBalloonCallout

	Set pTitleCallout = New BalloonCallout

	

	Dim pTitleBackground As ITextBackground

	Set pTitleBackground = pTitleCallout

	

	Dim pTitleFill As ISimpleFillSymbol

	Set pTitleFill = New SimpleFillSymbol

	

	Dim pTitleOutline As ICartographicLineSymbol

	Set pTitleOutline = New CartographicLineSymbol

	

	Set pTitleBackground.TextSymbol = pTitleSymbol

	Set pTitleSymbol.Background = pTitleBackground

	

	Dim pTitleMargin As ITextMargins

	Set pTitleMargin = pTitleCallout

	

	With pTitleMargin  ' Margin padding

		.BottomMargin = 16

		.TopMargin = 3

		.LeftMargin = 13

		.RightMargin = 13

	End With

	

	With pTitleOutline   ' Outline

		.Width = 2

		.Cap = esriLCSSquare

		.Join = esriLJSMitre

		.Color = pTitleColorHSV

	End With

	

	With pTitleFill   ' Fill

		.Color = pFillColorHSV

		.Outline = pTitleOutline

	End With

	

	Set pTitleCallout.Symbol = pTitleFill

	

	' Set up the font

	Dim pFontDisp As IFontDisp

	Set pFontDisp = New stdole.StdFont

	pFontDisp.Name = "Arial"

	pFontDisp.Bold = True

	

	' Set up the symbol

	With pTitleSymbol   ' Symbolize the title

		.Font = pFontDisp

		.Color = pTitleColorHSV

		.size = 40

		.HorizontalAlignment = esriTHACenter

	End With

	

	pTitleText.Symbol = pTitleSymbol

		

	Dim pTitlePoint As IPoint   ' Point location placement for title textbox

	Set pTitlePoint = New Point

	pTitlePoint.X = 9

	pTitlePoint.Y = 16.35

	

	' End title box creation

	'////////////////////////////////////////////////////

	

	'////////////////////////////////////////////////////////

	' 2) Begin attribute table box creation

		

	Dim pAttrTableSymbol As IFormattedTextSymbol

	Set pAttrTableSymbol = New TextSymbol

	

	Dim pAttrTableText As ITextElement

	Set pAttrTableText = New TextElement

	   

	Dim pAttrTableCallout As IBalloonCallout

	Set pAttrTableCallout = New BalloonCallout

	

	Dim pAttrTableBackground As ITextBackground

	Set pAttrTableBackground = pAttrTableCallout

	

	Dim pAttrTableFill As ISimpleFillSymbol

	Set pAttrTableFill = New SimpleFillSymbol

	

	Dim pAttrTableOutline As ICartographicLineSymbol

	Set pAttrTableOutline = New CartographicLineSymbol

	

	Set pAttrTableBackground.TextSymbol = pAttrTableSymbol

	Set pAttrTableSymbol.Background = pAttrTableBackground

	

	Dim pAttrTableMargin As ITextMargins

	Set pAttrTableMargin = pAttrTableCallout

	

	With pAttrTableMargin  ' Margin padding

		.BottomMargin = 5

		.TopMargin = 5

		.LeftMargin = 8

		.RightMargin = 8

	End With

	

	With pAttrTableOutline   ' Outline

		.Width = 1

		.Cap = esriLCSSquare

		.Join = esriLJSMitre

		.Color = pTitleColorHSV

	End With

	

	With pAttrTableFill   ' Fill

		.Color = pFillColorHSV

		.Outline = pAttrTableOutline

	End With

	

	Set pAttrTableCallout.Symbol = pAttrTableFill

	

	' Set up the font

	'Dim pFontDisp As IFontDisp

	'Set pFontDisp = New stdole.StdFont

	'pFontDisp.Name = "Arial"

	pFontDisp.Bold = False

	

	' Set up the symbol

	With pAttrTableSymbol   ' Symbolize

		.Font = pFontDisp

		.Color = pTitleColorHSV

		.size = 16

		.HorizontalAlignment = esriTHACenter

	End With

	

	pAttrTableText.Symbol = pAttrTableSymbol

		

	Dim pAttrTablePoint As IPoint   ' Point location placement for title textbox

	Set pAttrTablePoint = New Point

	pAttrTablePoint.X = 9

	pAttrTablePoint.Y = 0.3

	

	' End attribute table box creation

	'////////////////////////////////////////////////////

	

	Set pFeature = pFeatureCursor.NextFeature  ' clear it, get the first feature

	

	Do Until pFeature Is Nothing

		Counter = Counter + 1

		

		Dim strState As String

		If Len(pFeature.Value(12)) = 2 Then

			strState = "State: " & pFeature.Value(12)

		Else

			strState = "States: " & Replace(pFeature.Value(12), " ", ", ")

		End If

		' Add attribute table textbox to map

		pAttrTableText.Text = "<und>" & pFeature.Value(5) & " Subbasin</und><lin leading='4'>" & _

							vbNewLine & "Region: " & pFeature.Value(2) & "</lin>" & _

							vbNewLine & "Subregion: " & pFeature.Value(3) & _

							vbNewLine & "Basin: " & pFeature.Value(4) & _

							vbNewLine & strState & _

							vbNewLine & "Acres: " & FormatNumber(pFeature.Value(10), 0, vbUseDefault, vbFalse, vbTrue) & _

							vbNewLine & "Sq. Miles: " & FormatNumber(pFeature.Value(11), 0, vbUseDefault, vbFalse, vbTrue)

		AddElement pAttrTableText, pAttrTablePoint

		' Add title textbox to map

		pTitleText.Text = pFeature.Value(5) & " Subbasin<lin leading='4'>" & _

							vbNewLine & "<fnt size='26'>HUC 8 #" & pFeature.Value(9) & "</fnt></lin>"

		AddElement pTitleText, pTitlePoint

		' 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 "JPEG", "Z:\images\testing\" & strImageName & ".jpg", 175

		' Delete the title text box before we zoom to next feature

		DeleteElement pAttrTableText, pAttrTablePoint

		DeleteElement pTitleText, pTitlePoint

		' 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 MakeJpegFileName(strHucName As String, strHucNumber As String) As String

	

	If Trim(strHucName) = "" Then

		MakeJpegFileName = Trim(strHucNumber)

	Else

		MakeJpegFileName = Trim(strHucNumber) & "_" & ReplaceMultiple(ReplaceMultiple(strHucName, "_", " ", "-"), "", "'", ".", ",")

	End If



End Function

[benbakelaar]

Thanks guys! I am familiar enough with programming languages and concepts, just not particularly VBA. I've managed to edit a few non-working scripts off the ESRI site to get them working though. So I will try supercoop's, thanks! And Paul I would appreciate having your script as well, I'll PM you my email. I did actually want to export to PDF if possible. I'm sure it's just changing one line of code in coop's code.

[supercooper]

Hope its of use to you. If you have any questions, post them. Here's the export function for PDF. Call it just like you do the jpeg export function. This is set to export at 300 dpi, and I found topos and hillshades to look very good without the files being huge.



Public Function ExportToPDF(FileName As String)
Dim pMxDoc As IMxDocument
Dim pActiveView As IActiveView
Dim pExport As IExport
Dim pPixelBoundsEnv As IEnvelope
Dim exportRECT As tagRECT
Dim iOutputResolution As Integer
Dim iScreenResolution As Integer
Dim hDC As Long

Set pMxDoc = Application.Document
Set pActiveView = pMxDoc.ActiveView

Set pExport = New ExportPDF

pExport.ExportFileName = "Z:\pdf\testing\drilling_sections\topos\hill\2\" & FileName & "." & Right(pExport.Filter, 3)

'Because we are exporting to a resolution that differs from screen resolution, we should
' assign the two values to variables for use in our sizing calculations
iScreenResolution = 96 'default screen resolution is usually 96dpi
iOutputResolution = 300
pExport.Resolution = iOutputResolution

'The ExportFrame property gives us the dimensions appropriate for an export at screen resolution.
' Because we are exporting at a higher resolution (more pixels), we must multiply each dimesion
' by the ratio of OutputResolution to ScreenResolution. Instead of assigning the entire
' ExportFrame directly to the exportRECT, let's bring the values across one at a time and multiply
' the dimensions.
With exportRECT
.Left = 0
.Top = 0
.Right = pActiveView.ExportFrame.Right * (iOutputResolution / iScreenResolution)
.bottom = pActiveView.ExportFrame.bottom * (iOutputResolution / iScreenResolution)
End With

'Set up the PixelBounds envelope to match the exportRECT
Set pPixelBoundsEnv = New Envelope
pPixelBoundsEnv.PutCoords exportRECT.Left, exportRECT.Top, exportRECT.Right, exportRECT.bottom
pExport.PixelBounds = pPixelBoundsEnv

hDC = pExport.StartExporting
pActiveView.Output hDC, pExport.Resolution, exportRECT, Nothing, Nothing
pExport.FinishExporting
pExport.Cleanup

'MsgBox "Export complete!", vbOKOnly + vbInformation

End Function

[Matthew Hampton]

I have always used DSMapbook for this. I have found this to be a very powerful and productive tool for ArcGIS.

Reed Hunter from ESRI has modified this and added much more functionality to create NWMapbook. Here is a link to a presentation he gave at the OR and WA URISA GIS in Action conference earlier this year.