How to Scale a Dataset

This VBA code demonstrates how to scale an ArcGIS Shapefile dataset and re-center it on the original dataset.

Eicher GIS, LLC

http://www.eicher-gis.com

Option Explicit

Const SCALE_FACTOR = 5

Sub ScalePolygons()

' .mxd setup:

'       First layer should be original poly shapes

'       Second layer empty poly shape file where scaled shapes will be stored

' ----------------------------------------------------------------------

' logic:

'   1) TRANSLATE to set false origin at lower left of extent of all polys

'

'   2) apply SCALE transformation to every x, y point (locations

'       based on false origin

'

'   3) TRANSLATE all points by fixed x and y shift so that

'       center of new dataset extent equals center of

'       orig dataset extent

'

'   4) TRANSLATE to undo 1)

'

' ----------------------------------------------------------------------

    Dim pMxDoc As IMxDocument

    Set pMxDoc = ThisDocument

    Dim pOriginalLayer As IFeatureLayer

    Set pOriginalLayer = pMxDoc.ActiveView.FocusMap.Layer(0)

    Dim pGeoDataset As IGeoDataset

    Set pGeoDataset = pOriginalLayer

    ' get envelope of orig dataset

    Dim pOrigEnv As IEnvelope

    Set pOrigEnv = pGeoDataset.Extent

    ' get coordinates of lower left corner of dataset

    Dim dblDSLowerLeftX As Double

    dblDSLowerLeftX = pOrigEnv.LowerLeft.X

    Dim dblDSLowerLeftY As Double

    dblDSLowerLeftY = pOrigEnv.LowerLeft.Y

    ' calc width and height of scaled dataset

    Dim dblNewDSHeight As Double

    Dim dblNewDSWidth As Double

    dblNewDSHeight = pOrigEnv.Height * SCALE_FACTOR

    dblNewDSWidth = pOrigEnv.Width * SCALE_FACTOR

    ' calc x and y translation distances to move scaled

    '   dataset points so that scaled dataset is

    '   centered on orig dataset

    Dim dblXAdjust As Double

    Dim dblYAdjust As Double

    dblXAdjust = (dblNewDSWidth - pOrigEnv.Width) / 2

    dblYAdjust = (dblNewDSHeight - pOrigEnv.Height) / 2

    ' setup output feature class for writing

    Dim pOutFeatLayer As IFeatureLayer

    Set pOutFeatLayer = pMxDoc.ActiveView.FocusMap.Layer(1)

    Dim pOutFeatClass As IFeatureClass

    Set pOutFeatClass = pOutFeatLayer.FeatureClass

    Dim pInsertCursor As IFeatureCursor

    Set pInsertCursor = pOutFeatClass.Insert(True)

    Dim pFeatBuf As IFeatureBuffer

    Set pFeatBuf = pOutFeatClass.CreateFeatureBuffer

    ' declare variables that we'll use in the loop

    Dim pPoint As IPoint

    Dim pPoly As IPolygon

    Dim pPolyPointColl As IPointCollection

    Dim i As Integer

    Dim p

    Dim pNewPoly As IPolygon

    Dim pNewPolyPointColl As IPointCollection

    Dim pNewPolyTopoOper As ITopologicalOperator

    ' query orig features

    Dim pQF As IQueryFilter

    Set pQF = New QueryFilter

    pQF.WhereClause = "" ' to get all features

    Dim pFeatCursor As IFeatureCursor

    Set pFeatCursor = pOriginalLayer.FeatureClass.Search(pQF, False)

    Dim pFeat As IFeature

    Set pFeat = pFeatCursor.NextFeature

    Dim iFIDField As Integer

    iFIDField = pFeat.Fields.FindField("FID")

    Dim iFID As Integer

    ' loop through all orig features...

    Do While Not pFeat Is Nothing

        iFID = pFeat.Value(iFIDField)

        Set pPoly = pFeat.ShapeCopy

        Set pPolyPointColl = pPoly

        Set pNewPoly = New Polygon

        Set pNewPolyPointColl = pNewPoly

        ' loop through all points in feature polygon

        For i = 0 To pPolyPointColl.PointCount - 1

            Set pPoint = pPolyPointColl.Point(i)

            '   1) TRANSLATE to set false origin at lower left of extent of all polys

            pPoint.X = pPoint.X - dblDSLowerLeftX

            pPoint.Y = pPoint.Y - dblDSLowerLeftY

            '   2) apply SCALE transformation to every x, y point (locations

            '       based on false origin

            ' multiplication is straightforward in our case because

            '   x scaling = y scaling = SCALE_FACTOR

            pPoint.X = pPoint.X * SCALE_FACTOR

            pPoint.Y = pPoint.Y * SCALE_FACTOR

            '   3) TRANSLATE all points by fixed x and y shift so that

            '       center of new dataset extent equals center of

            '       orig dataset extent

            pPoint.X = pPoint.X - dblXAdjust

            pPoint.Y = pPoint.Y - dblYAdjust

            '   4) TRANSLATE to reset origin (i.e. undo 1)

            pPoint.X = pPoint.X + dblDSLowerLeftX

            pPoint.Y = pPoint.Y + dblDSLowerLeftY

            ' output scaled point

            Debug.Print "Shape " + Str(iFID) + ": " + Str(pPoint.X) + "," + Str(pPoint.Y)

            ' add point to new poly

            pNewPolyPointColl.AddPoint pPoint

        Next i  ' get next point in polygon

        ' simplify poly to close polygon

        Set pNewPolyTopoOper = pNewPoly

        pNewPolyTopoOper.Simplify

        ' create new feature (with scaled shape) and insert into output feature class

        Set pFeatBuf.Shape = pNewPoly

        pInsertCursor.InsertFeature pFeatBuf

        ' get next poly feature

        Set pFeat = pFeatCursor.NextFeature

Loop

End Sub

Eicher GIS, LLC

http://www.eicher-gis.com