|
What is a choropleth map anyway? Basically it's just a fancy term for a map that displays data values for polygons according to a classification, symbolization, and possibly a labeling scheme. Think population density or median income maps. Often choropleth maps are used as a visualization aid that takes the place of a table of data values. And often the source data table has all sort of vertical columns of data values. For example the Census data files have hundreds of measures for a given county, city, or census block. Who wants to manually make maps of all these values? Sounds too much like 'chloroform' mapping to me. Here is some code to automate the production of basic choropleth .pdf map in ArcMap including: - updating the map title
- setting the field from which data values will be classified (into quantiles, although this could be changed)
- control the number of classes and the colors
- set the label values for each polygon
As the polygon label renderer in ArcMap has some limitations, I like to use the ArcToolbox Data Management --> Features --> Feature To Point tool create a layer of polygon centroids that I can then move around in an edit mode to get the point labels to display in just the right position. This script is oriented specifically to this "polygon for coloring areas and points for labels" approach. This trick together with the use of a line feature class for leader lines allows you to treat GIS features as map graphics (in the generic sense) to do tricks like pulling labels and associated data labels for the small eastern seaboard states into the Atlantic ocean where there is more room. Alternatively, maybe someone should just hire a few big tug boats and physically pull these states (DE, RI, MD, CT for starters) out to sea where there is more elbow room? Speaking of unfriendly choropleth situations, if you have a polygon that is a geographic outlier in size or location, feel free to edit it's geographic location in an edit session. You can also resize outlandishly large polygon features (this should get at least one more state's attention, no names please) by using the ArcMap Scale tool (but you'll have to add it from the ArcMap customize window (Commands tab: category = Editor, command = Scale) and drag this tool onto one of your existing, visible toolbars. Important steps (please read carefully): - Use the Features To Point tool to create a point layer from which labels will be rendered using the layer properties (set placement to On Top of Point). When you're done editing their positions, save, and set the point symbol to a solid (no outline) symbol and set the color to no color.
- If you wish to use 'joined' data from an extenal table (and you should where possible!), make sure that both the point and polygon data carry the join id (foreign key) used in the external table. Make the join on both the point and polygon layers
- Put your ArcMap display in Page Layout Mode and set up a legend for the polygon feature class only. You don't have to do anything special as the legend will be populated from the script. Put a map title in the map (which will be updated) and then right click on it and go to Properties --> Size and Position --> Element Name and set the tag to MapTitleHere.
- Open the ArcMap VBA editor (Tools-->Macros --> Visual Basic Editor). From the Project explorer window double click Project (YourProjectName.mxd) --> ArcMap Objects --> ThisDocument. Paste the code below into the ThisDocument (code) window.
- While in the VBA Editor. Set all of the 7 sets of parameters needed in the script (look for the ***'s). These control the location of the point and polygon layers in the Table of Contents, the field with the polygon feature's name (for labelling), the number of maps to be made, the output path for the maps, an array of 4 variables taht control each map's title, classification field, legend group label, and whether or not the values need a percent sign added to their labels.
Notes: - If you have tens or hundreds of maps to produce, you might check out the very last procedure in the code below. It can be used to build the array of map definition parameters. Right now it is designed to take two inputs, the first and last fieldnames from which you want to define the set of fields to be included in the map definitions.
- There is lots of code below, most of it is for controlling the pdf output which I just borrowed and modified slightly.
- if you don't want a legend or a title, it's as simple as just not adding them to your page layout.
- Should be fairly easily to modify this code to save each map as its own mxd as well. Jsut didn't have time to get around to that.
Another example:
'code updated 8/20 11:23 am Option Explicit
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Sub generateBulkChoroplethPDFs()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Dim mapTitleList() As String
Dim classFieldList() As String 'must be names of numeric fields!
Dim classFieldLabel() As String
Dim isPercentageList() As Boolean
Dim scaleFactorList() As Long
Dim m As Long
Dim pPolyFeatureLayer As IFeatureLayer
Dim pPolyDataset As IDataset
Dim ptLabelFieldName As String
Dim pPtFeatureLayer As IFeatureLayer
Dim pPtDataset As IDataset
'*** 1 SET THESE, Index Location of Layers in Table of Contents
Set pPtFeatureLayer = pMap.Layer(1) 'Index of Point Layer (0 is the topmost layer)
Set pPolyFeatureLayer = pMap.Layer(2) 'Index of Polygon Layer
'*** 2 SET THIS, name of the pt layer field used to label each feature
'name of the pt layer field used to label each feature
ptLabelFieldName = "STATE_ABBR"
'*** 3 SET THIS, TOTAL NUMBER OF MAPS
Const constMapCount = 18
ReDim mapTitleList(constMapCount)
ReDim classFieldList(constMapCount)
ReDim classFieldLabel(constMapCount)
ReDim isPercentageList(constMapCount)
ReDim scaleFactorList(constMapCount)
Dim outputPathStr As String
'*** 4 SET THIS, output path for pdf files
outputPathStr = "c:\temp\"
'*** 5 SET THIS, array of maps to be produced
'for each map to be produced starting with map(0), provide:
mapTitleList(0) = "FHFA/OFHEO Purchase-Only Home Price Index" 'MapTitle & Outfile
classFieldList(0) = "HOFHOPIPO_v" 'Field Name
classFieldLabel(0) = " Home Price Index" 'Legend Field Description
isPercentageList(0) = False 'Use percent signs?
scaleFactorList(0) = 1 'Scale factor, use 100 for ratios
mapTitleList(1) = "ANNUAL CHANGE - FHFA/OFHEO Purchase-Only Home Price Index"
classFieldList(1) = "HOFHOPIPO_r"
classFieldLabel(1) = " Percent Change"
isPercentageList(1) = True
scaleFactorList(1) = 100
mapTitleList(2) = "Total Sales: Existing Single-Family/Apartment Condos & Co-ops"
classFieldList(2) = "HXQ_v"
classFieldLabel(2) = " Total Sales"
isPercentageList(2) = False
scaleFactorList(2) = 1
mapTitleList(3) = "ANNUAL CHANGE - Total Sales: Existing Single-Family/Apartment Condos & Co-ops"
classFieldList(3) = "HXQ_r"
classFieldLabel(3) = " Percent Change"
isPercentageList(3) = True
scaleFactorList(3) = 100
mapTitleList(4) = "Housing Starts: Total"
classFieldList(4) = "RHSTM_v"
classFieldLabel(4) = " Total Housings Starts"
isPercentageList(4) = False
scaleFactorList(4) = 1
mapTitleList(5) = "ANNUAL CHANGE - Housing Starts: Total"
classFieldList(5) = "RHSTM_r"
classFieldLabel(5) = " Percent Change"
isPercentageList(5) = True
scaleFactorList(5) = 100
mapTitleList(6) = "Homeownership Rate"
classFieldList(6) = "XHOWNRQ_v"
classFieldLabel(6) = " Homeownership Rate"
isPercentageList(6) = True
scaleFactorList(6) = 1
mapTitleList(7) = "ANNUAL CHANGE - Homeownership Rate"
classFieldList(7) = "XHOWNRQ_r"
classFieldLabel(7) = " Percent Change"
isPercentageList(7) = True
scaleFactorList(7) = 100
mapTitleList(8) = "All Loans - Percent of Loans Past Due Total (MBA)"
classFieldList(8) = "XMBAD_v"
classFieldLabel(8) = " Values for: XMBAD_v"
isPercentageList(8) = True
scaleFactorList(8) = 1
mapTitleList(9) = "ANNUAL CHANGE - All Loans - Percent of Loans Past Due Total (MBA)"
classFieldList(9) = "XMBAD_r"
classFieldLabel(9) = " Percent Change"
isPercentageList(9) = True
scaleFactorList(9) = 100
mapTitleList(10) = "All Loans - Percent of Loans Past Due 90 Days (MBA)"
classFieldList(10) = "XMBAD90_v"
classFieldLabel(10) = " Past Due Percentage"
isPercentageList(10) = True
scaleFactorList(10) = 1
mapTitleList(11) = "ANNUAL CHANGE - All Loans - Percent of Loans Past Due 90 Days (MBA)"
classFieldList(11) = "XMBAD90_r"
classFieldLabel(11) = " Percent Change"
isPercentageList(11) = True
scaleFactorList(11) = 100
mapTitleList(12) = "All Loans - Percent of Loans in Foreclosure at EOQ (MBA)"
classFieldList(12) = "XMBAFI_v"
classFieldLabel(12) = " EOQ Foreclosure Rate"
isPercentageList(12) = True
scaleFactorList(12) = 1
mapTitleList(13) = "ANNUAL CHANGE - All Loans - Percent of Loans in Foreclosure at EOQ (MBA)"
classFieldList(13) = "XMBAFI_r"
classFieldLabel(13) = "Percent Change"
isPercentageList(13) = True
scaleFactorList(13) = 100
mapTitleList(14) = "All Loans - Percent in Foreclosure - Started (MBA)"
classFieldList(14) = "XMBAFS_v"
classFieldLabel(14) = " Foreclosure Rate"
isPercentageList(14) = True
scaleFactorList(14) = 1
mapTitleList(15) = "ANNUAL CHANGE - All Loans - Percent in Foreclosure - Started (MBA)"
classFieldList(15) = "XMBAFS_r"
classFieldLabel(15) = " Percent Change"
isPercentageList(15) = True
scaleFactorList(15) = 100
mapTitleList(16) = "All Loans - Seriously Delinquent Rate (MBA)"
classFieldList(16) = "XMBASDR_v"
classFieldLabel(16) = " Delinquent Rate"
isPercentageList(16) = True
scaleFactorList(16) = 1
mapTitleList(17) = "ANNUAL CHANGE - All Loans - Seriously Delinquent Rate"
classFieldList(17) = "XMBASDR_r"
classFieldLabel(17) = " Percent Change"
isPercentageList(17) = True
scaleFactorList(17) = 100
'****
Dim pTable As ITable
Dim pTableHistogram As ITableHistogram
Dim pHistogram As IHistogram
Dim vntDataValues As Variant
Dim vntDataFrequencies As Variant
Dim pClassify As IClassify
Dim dblBreakValues() As Double
Dim pRenderer As IClassBreaksRenderer
Dim pColor() As IColor
Dim pOutlineColor As IColor
Dim pFillSymbol As IFillSymbol
Dim c As Long
Dim pPolyGeoFeatureLayer As IGeoFeatureLayer
Dim pPtGeoFeatureLayer As IGeoFeatureLayer
Dim pAnnoLayerProps As IAnnotateLayerProperties
Dim pAnnoLayerPropsColl As IAnnotateLayerPropertiesCollection
Dim pLabelEngine As ILabelEngineLayerProperties
Dim pPageLayout As IPageLayout
Dim pGC As IGraphicsContainer
Dim pElem As IElement
Dim pMSF As IMapSurroundFrame
Dim pMS As IMapSurround
Dim pTextElement As ITextElement
Dim pElemProperties As IElementProperties
Dim pLegendInfo As ILegendInfo
Dim pLegendGroup As ILegendGroup
Dim rangeMin, rangeMax As Double
Dim pLineSymbol As ISimpleLineSymbol
Dim labelDataField As String
'*** 6 SET THIS, set number of quantile and define fill colors
Const classCount = 4
ReDim pColor(classCount)
Set pColor(0) = New RgbColor
pColor(0).RGB = RGB(75, 131, 186)
Set pColor(1) = New RgbColor
pColor(1).RGB = RGB(149, 186, 130)
Set pColor(2) = New RgbColor
pColor(2).RGB = RGB(217, 196, 102)
Set pColor(3) = New RgbColor
pColor(3).RGB = RGB(207, 83, 83)
'*** 7 SET THIS, Define polygon outline color
Set pOutlineColor = New RgbColor
pOutlineColor.RGB = RGB(240, 240, 240)
Set pLineSymbol = New SimpleLineSymbol
pLineSymbol.Color = pOutlineColor
pLineSymbol.Width = 1
pLineSymbol.Style = esriSLSSolid
Set pPolyGeoFeatureLayer = pPolyFeatureLayer 'Query Interface
Set pLegendInfo = pPolyGeoFeatureLayer 'Query Interface
Set pPtDataset = pPtFeatureLayer.FeatureClass
Set pPolyDataset = pPolyFeatureLayer.FeatureClass
For m = 0 To UBound(mapTitleList) - 1
'redefine classbreaks renderer for polygon layer
Set pTable = pPolyFeatureLayer
Set pTableHistogram = New TableHistogram
Set pTableHistogram.Table = pTable
pTableHistogram.Field = classFieldList(m)
Set pHistogram = pTableHistogram
pHistogram.GetHistogram vntDataValues, vntDataFrequencies
Set pClassify = New Quantile
pClassify.SetHistogramData vntDataValues, vntDataFrequencies
pClassify.Classify classCount
dblBreakValues = pClassify.ClassBreaks
If UBound(dblBreakValues) <> classCount Then
MsgBox "Unable to classify data for field named:" & classFieldList(m), vbOKOnly
Else
Set pRenderer = New ClassBreaksRenderer
pRenderer.Field = classFieldList(m)
pRenderer.BreakCount = classCount
pRenderer.MinimumBreak = dblBreakValues(0)
For c = 0 To pRenderer.BreakCount - 1
Set pFillSymbol = New SimpleFillSymbol
pFillSymbol.Color = pColor(c)
pFillSymbol.Outline = pLineSymbol
pRenderer.Symbol(c) = pFillSymbol
pRenderer.Break(c) = dblBreakValues(c + 1)
If isPercentageList(m) = True Then
If c = 0 Then
rangeMin = Round(dblBreakValues(c) * scaleFactorList(m))
Else
rangeMin = Round(dblBreakValues(c) * scaleFactorList(m) + 0.1, 1)
End If
rangeMax = Round(dblBreakValues(c + 1) * scaleFactorList(m), 1)
pRenderer.Label(c) = rangeMin & "% to " & rangeMax & " %"
Else
If c = 0 Then
rangeMin = Round(dblBreakValues(c))
Else
rangeMin = Round(dblBreakValues(c) + 0.1, 1)
End If
rangeMax = Round(dblBreakValues(c + 1), 1)
pRenderer.Label(c) = rangeMin & " to " & rangeMax
End If
Next c
'pRenderer.SortClassesAscending = False
Set pPolyGeoFeatureLayer.Renderer = pRenderer
'redefine label expression for point layer
Set pPtGeoFeatureLayer = pPtFeatureLayer 'QI (Query Interface)
Set pAnnoLayerPropsColl = pPtGeoFeatureLayer.AnnotationProperties
'get the first and *assuming* only one) AnnotateLayerProperties property set in the collection
pAnnoLayerPropsColl.QueryItem 0, pAnnoLayerProps, Nothing, Nothing
'turn on label for the first label class
pAnnoLayerProps.DisplayAnnotation = True
pAnnoLayerProps.LabelWhichFeatures = esriVisibleFeatures
'set the labelling expression
Set pLabelEngine = pAnnoLayerProps 'qi
labelDataField = UCase(classFieldList(m))
If InStr(labelDataField, UCase(pPolyDataset.Name)) > -1 Then
labelDataField = Replace(labelDataField, UCase(pPolyDataset.Name), pPtDataset.Name)
End If
If isPercentageList(m) = True Then
pLabelEngine.Expression = """<BOL>"" & [" & pPtDataset.Name & "." & ptLabelFieldName & _
"] & ""</BOL>"" & vbnewline & clng([" & labelDataField & "] * 10 * " & scaleFactorList(m) & ")/10 & ""%"""
Else
pLabelEngine.Expression = """<BOL>"" & [" & pPtDataset.Name & "." & ptLabelFieldName & _
"] & ""</BOL>"" & vbnewline & clng([" & labelDataField & "] * 10 * " & scaleFactorList(m) & ")/10"
End If
Set pPageLayout = pMxDoc.PageLayout
Set pGC = pPageLayout
pGC.Reset
Set pLegendInfo = pPolyGeoFeatureLayer
Set pLegendGroup = pLegendInfo.LegendGroup(0)
pLegendGroup.Heading = classFieldLabel(m)
Set pElem = pGC.Next
Do Until pElem Is Nothing
'refresh legend
If TypeOf pElem Is IMapSurroundFrame Then
Set pMSF = pElem
Set pMS = pMSF.MapSurround
pMS.Refresh
End If
'refresh title
If TypeOf pElem Is ITextElement Then
Set pTextElement = pElem
Set pElemProperties = pTextElement
If pElemProperties.Name = "MapTitleHere" Then
pTextElement.Text = mapTitleList(m)
End If
End If
Set pElem = pGC.Next
Loop
pMxDoc.ActivatedView.Refresh
pMxDoc.UpdateContents
Call ExportActiveViewToPDF(outputPathStr & removeBadFileNameCharacters(mapTitleList(m)) & ".pdf")
End If
Next m
End Sub
Public Sub ExportActiveViewToPDF(inFileName As String)
Dim pMxDoc As IMxDocument
Dim pActiveView As IActiveView
Dim pExport As IExport
Dim iPrevOutputImageQuality As Long
Dim pOutputRasterSettings As IOutputRasterSettings
Dim pPixelBoundsEnv As IEnvelope
Dim exportRECT As tagRECT
Dim DisplayBounds As tagRECT
Dim pDisplayTransformation As IDisplayTransformation
Dim pPageLayout As IPageLayout
Dim pMapExtEnv As IEnvelope
Dim hdc As Long
Dim tmpDC As Long
Dim sNameRoot As String
Dim sOutputDir As String
Dim iOutputResolution As Long
Dim iScreenResolution As Long
Dim bContinue As Boolean
Dim msg As String
Dim pTrackCancel As ITrackCancel
Dim pGraphicsExtentEnv As IEnvelope
Dim bClipToGraphicsExtent As Boolean
Dim pUnitConvertor As IUnitConverter
Set pMxDoc = Application.Document
Set pActiveView = pMxDoc.ActiveView
Set pTrackCancel = New CancelTracker
'Create an ExportPDF object and QI the pExport interface pointer onto it.
' To export to a format other than PDF, simply create a different CoClass here
Set pExport = New ExportPDF
'assign a resolution for the export in dpi
iOutputResolution = 300
'assign True or False to determin is export image will be clipped to the graphic extent of layout elements.
'this value is ignored for data view exports
bClipToGraphicsExtent = True
Set pOutputRasterSettings = pActiveView.ScreenDisplay.DisplayTransformation
iPrevOutputImageQuality = pOutputRasterSettings.ResampleRatio
' Output Image Quality of the export. The value here will only be used if the export
' object is a format that allows setting of Output Image Quality, i.e. a vector exporter.
' The value assigned to ResampleRatio should be in the range 1 to 5.
' 1 corresponds to "Best", 5 corresponds to "Fast"
If TypeOf pExport Is IExportImage Then
'always set the output quality of the display to 1 for image export formats
SetOutputQuality pActiveView, 1
ElseIf TypeOf pExport Is IOutputRasterSettings Then
' for vector formats, assign a ResampleRatio to control drawing of raster layers at export time
Set pOutputRasterSettings = pExport
pOutputRasterSettings.ResampleRatio = 1
Set pOutputRasterSettings = Nothing
End If
'assign the output path and filename. We can use the Filter property of the export object to
' automatically assign the proper extension to the file.
pExport.ExportFileName = inFileName
tmpDC = GetDC(0)
iScreenResolution = GetDeviceCaps(tmpDC, 88) '88 is the win32 const for Logical pixels/inch in X)
ReleaseDC 0, tmpDC
pExport.Resolution = iOutputResolution
If TypeOf pActiveView Is IPageLayout Then
DisplayBounds = pActiveView.ExportFrame
Set pMapExtEnv = pGraphicsExtentEnv
Else
Set pDisplayTransformation = pActiveView.ScreenDisplay.DisplayTransformation
DisplayBounds.Left = 0
DisplayBounds.Top = 0
DisplayBounds.Right = pDisplayTransformation.DeviceFrame.Right
DisplayBounds.bottom = pDisplayTransformation.DeviceFrame.bottom
Set pMapExtEnv = New Envelope
Set pMapExtEnv = pDisplayTransformation.FittedBounds
End If
Set pPixelBoundsEnv = New Envelope
If bClipToGraphicsExtent And (TypeOf pActiveView Is IPageLayout) Then
Set pGraphicsExtentEnv = GetGraphicsExtent(pActiveView)
Set pPageLayout = pActiveView
Set pUnitConvertor = New UnitConverter
'assign the x and y values representing the clipped area to the PixelBounds envelope
pPixelBoundsEnv.xMin = 0
pPixelBoundsEnv.yMin = 0
pPixelBoundsEnv.xMax = pUnitConvertor.ConvertUnits(pGraphicsExtentEnv.xMax, pPageLayout.Page.Units, esriInches) * pExport.Resolution _
- pUnitConvertor.ConvertUnits(pGraphicsExtentEnv.xMin, pPageLayout.Page.Units, esriInches) * pExport.Resolution
pPixelBoundsEnv.yMax = pUnitConvertor.ConvertUnits(pGraphicsExtentEnv.yMax, pPageLayout.Page.Units, esriInches) * pExport.Resolution _
- pUnitConvertor.ConvertUnits(pGraphicsExtentEnv.yMin, pPageLayout.Page.Units, esriInches) * pExport.Resolution
'assign the x and y values representing the clipped export extent to the exportRECT
With exportRECT
.bottom = Fix(pPixelBoundsEnv.yMax) + 1
.Left = Fix(pPixelBoundsEnv.xMin)
.Top = Fix(pPixelBoundsEnv.yMin)
.Right = Fix(pPixelBoundsEnv.xMax) + 1
End With
Set pMapExtEnv = pGraphicsExtentEnv
Else
'The values in the exportRECT tagRECT correspond to the width
' and height to export, measured in pixels with an origin in the top left corner.
With exportRECT
.bottom = DisplayBounds.bottom * (iOutputResolution / iScreenResolution)
.Left = DisplayBounds.Left * (iOutputResolution / iScreenResolution)
.Top = DisplayBounds.Top * (iOutputResolution / iScreenResolution)
.Right = DisplayBounds.Right * (iOutputResolution / iScreenResolution)
End With
'populate the PixelBounds envelope with the values from exportRECT.
' We need to do this because the exporter object requires an envelope object
' instead of a tagRECT structure.
pPixelBoundsEnv.PutCoords exportRECT.Left, exportRECT.Top, exportRECT.Right, exportRECT.bottom
End If
'Assign the envelope object to the exporter object's PixelBounds property. The exporter object
' will use these dimensions when allocating memory for the export file.
pExport.PixelBounds = pPixelBoundsEnv
Set pExport.TrackCancel = pTrackCancel
Set pExport.StepProgressor = Application.StatusBar.ProgressBar
pTrackCancel.Reset
pTrackCancel.CancelOnClick = False
pTrackCancel.CancelOnKeyPress = True
bContinue = pTrackCancel.Continue()
hdc = pExport.StartExporting
'Redraw the active view, rendering it to the exporter object device context instead of the app display.
'We pass the following values:
' * hDC is the device context of the exporter object.
' * exportRECT is the tagRECT structure that describes the dimensions of the view that will be rendered.
' The values in exportRECT should match those held in the exporter object's PixelBounds property.
' * pMapExtEnv is an envelope defining the section of the original image to draw into the export object.
' * pTrackCancel is a reference to a CancelTracker object
pActiveView.Output hdc, pExport.Resolution, exportRECT, pMapExtEnv, pTrackCancel
bContinue = pTrackCancel.Continue()
If bContinue Then
msg = "Writing export file..."
Application.StatusBar.Message(0) = msg
pExport.FinishExporting
pExport.Cleanup
Else
pExport.Cleanup
End If
pTrackCancel.CancelOnClick = False
pTrackCancel.CancelOnKeyPress = True
bContinue = pTrackCancel.Continue()
If bContinue Then
msg = "Finished exporting '" & pExport.ExportFileName & "'"
Application.StatusBar.Message(0) = msg
End If
SetOutputQuality pActiveView, iPrevOutputImageQuality
Set pTrackCancel = Nothing
Set pMapExtEnv = Nothing
Set pPixelBoundsEnv = Nothing
End Sub
Private Sub SetOutputQuality(pActiveView As IActiveView, iResampleRatio As Long)
Dim pMap As IMap
Dim pGraphicsContainer As IGraphicsContainer
Dim pElement As IElement
Dim pOutputRasterSettings As IOutputRasterSettings
Dim pMapFrame As IMapFrame
Dim pTmpActiveView As IActiveView
If TypeOf pActiveView Is IMap Then
Set pOutputRasterSettings = pActiveView.ScreenDisplay.DisplayTransformation
pOutputRasterSettings.ResampleRatio = iResampleRatio
ElseIf TypeOf pActiveView Is IPageLayout Then
'assign ResampleRatio for PageLayout
Set pOutputRasterSettings = pActiveView.ScreenDisplay.DisplayTransformation
pOutputRasterSettings.ResampleRatio = iResampleRatio
'and assign ResampleRatio to the Maps in the PageLayout
Set pGraphicsContainer = pActiveView
pGraphicsContainer.Reset
Set pElement = pGraphicsContainer.Next
Do While Not pElement Is Nothing
If TypeOf pElement Is IMapFrame Then
Set pMapFrame = pElement
Set pTmpActiveView = pMapFrame.Map
Set pOutputRasterSettings = pTmpActiveView.ScreenDisplay.DisplayTransformation
pOutputRasterSettings.ResampleRatio = iResampleRatio
End If
DoEvents
Set pElement = pGraphicsContainer.Next
Loop
Set pMap = Nothing
Set pMapFrame = Nothing
Set pGraphicsContainer = Nothing
Set pTmpActiveView = Nothing
End If
Set pOutputRasterSettings = Nothing
End Sub
Function GetGraphicsExtent(pActiveView As IActiveView) As IEnvelope
Dim pBounds As IEnvelope
Dim pEnv As IEnvelope
Dim pGraphicsContainer As IGraphicsContainer
Dim pPageLayout As IPageLayout
Dim pDisplay As IDisplay
Dim pElement As IElement
Set pBounds = New Envelope
Set pEnv = New Envelope
Set pPageLayout = pActiveView
Set pDisplay = pActiveView.ScreenDisplay
Set pGraphicsContainer = pActiveView
pGraphicsContainer.Reset
Set pElement = pGraphicsContainer.Next
Do While Not pElement Is Nothing
pElement.QueryBounds pDisplay, pEnv
pBounds.Union pEnv
DoEvents
Set pElement = pGraphicsContainer.Next
Loop
Set GetGraphicsExtent = pBounds
Set pBounds = Nothing
Set pEnv = Nothing
Set pGraphicsContainer = Nothing
Set pPageLayout = Nothing
Set pDisplay = Nothing
Set pElement = Nothing
End Function
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
'Debug.Print "Export complete!"
End Sub
Public Sub buildMapParameterArraySample()
Dim startFieldName, endFieldName As String
Dim targetLayer As Long
startFieldName = "HOFHOPIPO_v"
endFieldName = "XMBASDR_r"
targetLayer = 0
Open "c:/temp/mapoutputparameters.txt" For Output As #1
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As ILayer
Dim pTable As ITable
Dim pDisplayTable As IDisplayTable
Dim x, count, startFieldIndex, endFieldIndex As Long
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pLayer = pMap.Layer(targetLayer)
Set pDisplayTable = pLayer
Set pTable = pDisplayTable.DisplayTable
startFieldIndex = pTable.FindField(startFieldName)
endFieldIndex = pTable.FindField(endFieldName)
count = 0
For x = startFieldIndex To endFieldIndex
Print #1, "mapTitleList(" & count & ") = ""Map of " & pTable.Fields.Field(x).Name & """"
Print #1, "classFieldList(" & count & ") = """ & pTable.Fields.Field(x).Name & """"
Print #1, "classFieldLabel(" & count & ") = "" Values for: " & pTable.Fields.Field(x).Name & """"
Print #1, "isPercentageList(" & count & ") = False"
count = count + 1
Next x
Close #1
End Sub
Private Function removeBadFileNameCharacters(inFN As String) As String
inFN = Replace(inFN, "[", "")
inFN = Replace(inFN, "\", "")
inFN = Replace(inFN, "/", "")
inFN = Replace(inFN, ":", "")
inFN = Replace(inFN, "*", "")
inFN = Replace(inFN, "%", "")
inFN = Replace(inFN, "?", "")
inFN = Replace(inFN, """", "")
inFN = Replace(inFN, "'", "")
inFN = Replace(inFN, "<", "")
inFN = Replace(inFN, ">", "")
inFN = Replace(inFN, " ", "_")
inFN = Replace(inFN, "}", "")
inFN = Replace(inFN, "{", "")
inFN = Replace(inFN, "]", "")
inFN = Replace(inFN, "|", "")
inFN = Replace(inFN, "&", "")
inFN = Replace(inFN, "~", "")
inFN = Replace(inFN, "!", "")
inFN = Replace(inFN, "@", "")
inFN = Replace(inFN, "#", "")
inFN = Replace(inFN, "$", "")
inFN = Replace(inFN, "^", "")
inFN = Replace(inFN, "+", "")
inFN = Replace(inFN, "=", "")
inFN = Replace(inFN, ";", "")
inFN = Replace(inFN, ".", "")
inFN = Replace(inFN, ",", "")
inFN = Replace(inFN, "-", "")
inFN = Replace(inFN, "(", "")
inFN = Replace(inFN, ")", "")
removeBadFileNameCharacters = inFN
End Function
|
