ARCOBJECTS

EXAMPLES
ESRI

1
'***********************************************************************************************
*
' "Lock" layers at top and bottom of TOC
'
' This code prevents the user from re-ordering the ArcMap Table of Contents, effectively "locking"
' the top and bottom layers in position.
'
' The user cannot drag and drop the top or bottom layers into another position, or drop another layer on top of
' the first layer, or below the last layer. Any new layers added to the map will be placed after the top layer, or
' before the bottom layer.
'
' The code could be modified to lock other layers, perhaps by name rather than position - see comments in the script.
'
' Run the StartEvents routine to start "listening" for changes in the TOC. You could run this routine automatically when
' the MXD was opened if necessary.
'
' Run the StopEvents routine to allow changes to the TOC.
'
' History
' Original coding 1st May 2008 - Stephen Lead
'
' Known limitations - using group layers may cause problems with this script.
'
' Please report any problems, questions or comments using the Contact Author option on ArcScripts
'
'***********************************************************************************************
*
Option Explicit

Private WithEvents ActiveViewEvents As Map

Private m_pMxDoc As IMxDocument
Private m_FirstLayerName As String
Private m_LastLayerName As String
'Private m_OtherLockedLayerName as string

Public Sub StartEvents()

' Run this routine to start "listening" for changes. You can run this automatically when the MXD opened by calling this
routine
' in the MxDocument_OpenDocument section

Set m_pMxDoc = Application.Document

Set ActiveViewEvents = m_pMxDoc.FocusMap

Dim pMap As IMap

Set pMap = m_pMxDoc.FocusMap
If pMap.LayerCount = 0 Then Exit Sub

m_FirstLayerName = pMap.Layer(0).Name
m_LastLayerName = pMap.Layer(pMap.LayerCount - 1).Name

2
'You could specify a layer by name rather than position
'm_OtherLockedLayerName = "Specify the layer name here"

End Sub
Public Sub StopEvents()

'Stop "listening" for changes

Set ActiveViewEvents = Nothing

End Sub

Private Sub ActiveViewEvents_ItemAdded(ByVal Item As Variant)

Call CheckLayers
End Sub

Private Sub ActiveViewEvents_ItemReordered(ByVal Item As Variant, ByVal toIndex As Long)

Call CheckLayers
End Sub

Private Sub CheckLayers()

Dim pMap As IMap

Dim iNumLayers As Integer
Dim pEnumLayer As IEnumLayer
Dim pLayer As ILayer

Set pMap = m_pMxDoc.FocusMap

iNumLayers = pMap.LayerCount
If iNumLayers = 0 Then Exit Sub

'If the top layer is already correct, nothing further is required

'If pMap.Layer(0).Name = m_FirstLayerName Then Exit Sub

'Comment out the above line and uncomment this code if you also want to check for the bottom layer
If pMap.Layer(0).Name = m_FirstLayerName Then
If pMap.Layer(iNumLayers - 1).Name = m_LastLayerName Then
Exit Sub
End If
End If

'Otherwise, scroll through each layer til the desired layer is found
Set pEnumLayer = pMap.Layers
Set pLayer = pEnumLayer.Next

Do Until pLayer Is Nothing

If pLayer.Name = m_FirstLayerName Then
'Move it to the top of the TOC
pMap.MoveLayer pLayer, 0
ElseIf pLayer.Name = m_LastLayerName Then
'Move it to the bottom of the TOC
pMap.MoveLayer pLayer, iNumLayers - 1
'ElseIf pLayer.Name = mOtherLockedLayerName Then
'Move it to a particular position
'pmap.MoveLayer player, position_as_index 'specify the layer's position as an index starting from 0
End If
Set pLayer = pEnumLayer.Next
Loop

End Sub

Private Function MxDocument_BeforeCloseDocument() As Boolean

3
'stop listening for changes to the TOC
Call StopEvents
End Function

Private Function MxDocument_OpenDocument() As Boolean

' This code runs automatically when the MXD is opened

MsgBox "The top layer and bottom layers in the TOC will be locked in place", vbInformation
Call StartEvents

End Function

Add a Point to an SDE Layer.

Public Sub AddSDEPoint()

' Create connection string to connect to SQL Server

Dim ConnectStr As String
ConnectStr =
"SERVER=MyServer;INSTANCE=esri_sde;VERSION=SDE.DEFAULT;USER=MyUser;PASSWORD=MyPassword
"

' Open the SQL Server Workspace Factory

Dim pWSF2 As IWorkspaceFactory2
Set pWSF2 = New SdeWorkspaceFactory
Dim pWS As IWorkspace
Set pWS = pWSF2.OpenFromString(ConnectStr, 0)

' Start Editing

Dim pWSEdit As IWorkspaceEdit
Set pWSEdit = pWS
pWSEdit.StartEditing True
pWSEdit.StartEditOperation

' Open the "Point" feature class

Dim pFeatureWS As IFeatureWorkspace
Set pFeatureWS = pWS
Dim pFClass As IFeatureClass
Set pFClass = pFeatureWS.OpenFeatureClass("sde.demo.POINT")

' Create new Feature Layer and Point. Then set point x and y
Dim pFL As IFeatureLayer
Set pFL = New FeatureLayer
Set pFL.FeatureClass = pFClass
Dim pFeat As IFeature
Set pFeat = pFClass.CreateFeature
Dim pPoint As IPoint
Set pPoint = New esriCore.Point
pPoint.X = -107.85
pPoint.Y = 43.23
Set pFeat.Shape = pPoint
pFeat.Store

' Get and set the spatial reference of new layer and new point
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
Dim pBasicMap As IBasicMap
Set pBasicMap = pMap
Set pFL.SpatialReference = pBasicMap.SpatialReference

4
 Set pPoint.SpatialReference = pBasicMap.SpatialReference

' Add new featurelayer as a layer to the map

pFL.Name = "Point"
pMap.AddLayer pFL

' Stop Editing

pWSEdit.StopEditing True
pWSEdit.StopEditOperation

' Refresh the mapview

Dim pAV As IActiveView
Set pAV = pMap
pAV.Refresh

End Sub

ADD ARAEA OF POLYGON TO ATTRIBUTE TABLE

Public Sub AddAreaPolygon()

'
' This VBA script is to calculate the Area of polygons and add the area as
new field
' in the attribute table of the polygon
' Guoyun Zhou, Kyushu University, Fukuoka, Japan
' [email protected]
' April,17, 2002

Dim pMxdoc As IMxDocument

Set pMxdoc = ThisDocument

If Not TypeOf pMxdoc.ActiveView Is IMap Then

MsgBox "A Map must be active!"
Exit Sub
End If

Dim pFLayer As IFeatureLayer

Dim pFClass As IFeatureClass

Set pFLayer = pMxdoc.SelectedLayer

If pFLayer Is Nothing Then
MsgBox "You have to Select a single polygon shapefile!"
Exit Sub
End If
Set pFClass = pFLayer.FeatureClass

If pFClass.ShapeType <> esriGeometryPolygon Then

MsgBox "You must Select a single polygon shapefile!"
Exit Sub
End If

Dim indexA As Long

indexA = pFClass.FindField("Area")
If indexA < 0 Then 'If there is no the field of AREA
Dim pFieldx As IFieldEdit
Set pFieldx = New Field

With pFieldx
.Type = esriFieldTypeDouble
.Name = "Area"
End With
pFClass.AddField pFieldx
End If

5
 indexA = pFClass.FindField("Area")

Dim pFCursor As IFeatureCursor

' Set pFCursor = pFClass.Search(Nothing, False) 'return all records

'Get a cursor that can be used to update features for all records in polygon
feature
Set pFCursor = pFClass.Update(Nothing, False) 'returns all records

Dim pFeature As IFeature

Set pFeature = pFCursor.NextFeature ' move to fist feature

Dim pShape As IGeometry

Dim parea As IArea

Dim aarea As Double

While Not pFeature Is Nothing

Set pShape = pFeature.Shape

Set parea = pShape
aarea = parea.Area

pFeature.Value(indexA) = aarea

pFCursor.UpdateFeature pFeature

' pFeature.Store

Set pFeature = pFCursor.NextFeature

Wend

MsgBox "Ok! Finished ! Please chech your attribute table"

End Sub

SUMMRY:
Adds and populates ACREAGE and/or AREA field to the attribute table of a dataset. Will
properly calculate acreage for projected data, regardless of the linear units (meters, feet) used
in that projection. Some other scripts I've seen DO NOT account for the projection and will
give you wrong results.

Option Explicit

' NAME: frmAddAcreageDev

' CREATOR: Pete Yurkosky
' DATE: 5.26.2005

Private pMxDoc As IMxDocument

Private pMap As IMap
Private pFLayer As IFeatureLayer
Private pFClass As IFeatureClass
Private pSpatialReference As ISpatialReference
Private pGeoDataset As IGeoDataset
Private pProjectedCoordinateSystem As IProjectedCoordinateSystem
Private pLinearUnit As ILinearUnit
Private MeterPerUnit As Double
Private Const SqMetersPerAcre As Double = 4046.8564244
Private Const nameWidth As Integer = 17 ' For formatting of MessagePane
Private Response As Integer

6
Private canRun As Boolean
Private lNumFeat As Long

Private Sub Image1_Click()

End Sub

Private Sub UserForm_Initialize()

' Set the default options on the form.

optAcreage.Value = True
optNativeArea.Value = True
cmdGo.Enabled = True
canRun = True

' A couple of initial settings.

Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pFLayer = pMxDoc.SelectedLayer
Set pGeoDataset = pFLayer
Dim pEditor As IEditor
Dim pId As New UID

' Check to see if we are editing. Unstable behavior when editing is turned on,
' so disable procedure and show message.
pId = "esriCore.Editor"
Set pEditor = Application.FindExtensionByCLSID(pId)
If pEditor.EditState = esriStateEditing Then
'MsgBox "It is editing."
canRun = False
cmdGo.Enabled = False
With MessagePane
.Font = "Arial"
.Caption = "ERROR: Procedure cannot operate during edit session."
.ForeColor = RGB(255, 0, 0)
.Font.Bold = True
.Font.Italic = False
End With

' Check possible conditions in which we opened without a FocusMap

ElseIf pMap Is Nothing Then
canRun = False
cmdGo.Enabled = False
With MessagePane
.Font = "Arial"
.Caption = "ERROR: You must have an active map."
.ForeColor = RGB(255, 0, 0)
.Font.Bold = True
.Font.Italic = False
End With

' Check to see that there is a layer selected.

ElseIf pFLayer Is Nothing Then
canRun = False
cmdGo.Enabled = False
With MessagePane
.Font = "Arial"
.Caption = "ERROR: You must select a map layer."
.ForeColor = RGB(255, 0, 0)
.Font.Bold = True

7
 .Font.Italic = False
End With
Else
' Check to see that the selected layer is of polygon type, and check the
' spatial reference.
Set pFClass = pFLayer.FeatureClass
Set pSpatialReference = pGeoDataset.SpatialReference
If pFClass.ShapeType <> esriGeometryPolygon Then
canRun = False
cmdGo.Enabled = False
With MessagePane
.Font = "Arial"
.Caption = "ERROR: You must select a POLYGON map layer."
.ForeColor = RGB(255, 0, 0)
.Font.Bold = True
.Font.Italic = False
End With
' Check to see that the layer is projected. If not, we will get a calculation
' of area in "decimal degrees squared" which nobody wants.
ElseIf Not TypeOf pSpatialReference Is IProjectedCoordinateSystem Then
canRun = False
cmdGo.Enabled = False
With MessagePane
.Font = "Arial"
.Caption = "ERROR: You must select a PROJECTED map layer."
.ForeColor = RGB(255, 0, 0)
.Font.Bold = True
.Font.Italic = False
End With
End If
End If

' All is normal? Then set up the units, display them. This could be part of the
' above conditional, as the final "Else", but that needs to be reserved for the
' initialization of the pFClass. I can do it there, having established that it
' exists, but then the checks look like "If object.subobject.subobject.subobject..."
' I'll keep this final conditional to keep things readable.
If canRun Then
Set pProjectedCoordinateSystem = pSpatialReference
Set pLinearUnit = pProjectedCoordinateSystem.CoordinateUnit
MeterPerUnit = pLinearUnit.MetersPerUnit
Dim pUnitName As String
pUnitName = pLinearUnit.name
lNumFeat = pFClass.FeatureCount(Nothing)
With MessagePane
' If length of pFLayer.Name > 17, truncate to 17. Otherwise leave alone.
.Caption = "Layer: " + IIf(Len(pFLayer.name) > nameWidth, (Mid(pFLayer.name, 1, nameWidth) + "..."),
pFLayer.name) + vbCrLf + _
"Polys: " + LTrim(Str(lNumFeat)) + vbCrLf + _
"Units: " + "square " + pUnitName
.ForeColor = RGB(0, 0, 255)
.Font.Bold = False
.Font.Italic = False
End With
End If

End Sub

Private Sub optAcreage_Click()

If (optAcreage.Value = False And optNativeArea.Value = False) Or Not canRun Then
cmdGo.Enabled = False
Else

8
 cmdGo.Enabled = True
End If
End Sub

Private Sub optNativeArea_Click()

If (optNativeArea.Value = False And optAcreage.Value = False) Or Not canRun Then
cmdGo.Enabled = False
Else
cmdGo.Enabled = True
End If
End Sub

Private Sub cmdGO_Click()

' We are sure the app is not in an edit mode, and that at least one option is
' checked. Ready to execute the main procedure.

' Clear the dialog box.

frmAddAcreageDev.Hide
Calc_Values pFClass
Unload frmAddAcreageDev

Set pMxDoc = Nothing

Set pMap = Nothing
Set pFLayer = Nothing
Set pFClass = Nothing
Set pSpatialReference = Nothing
Set pGeoDataset = Nothing
Set pProjectedCoordinateSystem = Nothing
Set pLinearUnit = Nothing

End Sub

Private Sub Calc_Values(pFClass As IFeatureClass)

' Test procedure. Lumping both AREA, ACREAGE procs into one, doing conditionals
' within the main cursor loop. Is it faster than opening two cursors each time
' we do this on both AREA and ACREAGE?

Dim indexArea As Long

indexArea = pFClass.FindField("AREA")
Dim indexAcre As Long
indexAcre = pFClass.FindField("ACREAGE")

' Are we doing AREA? If so, check for existing field. Create one if necessary.
If optNativeArea.Value And indexArea < 0 Then
Dim pFieldArea As IFieldEdit
Set pFieldArea = New Field
With pFieldArea
.Type = esriFieldTypeDouble
.name = "AREA"
End With
pFClass.AddField pFieldArea
indexArea = pFClass.FindField("AREA")
End If

' Are we doing ACREAGE? If so, check for existing field. Create one if necessary.
If optAcreage.Value And indexAcre < 0 Then
Dim pFieldAcre As IFieldEdit
Set pFieldAcre = New Field
With pFieldAcre
.Type = esriFieldTypeDouble
.name = "ACREAGE"
End With

9
 pFClass.AddField pFieldAcre
indexAcre = pFClass.FindField("ACREAGE")
End If

' Set up a cursor to hold all features of the current FeatureClass.

Dim pFCursor As IFeatureCursor
Set pFCursor = pFClass.Update(Nothing, False)
Dim pFeature As IFeature
Set pFeature = pFCursor.NextFeature
Dim pShape As IGeometry
Dim pArea As IArea
Dim AreaValue As Double
Dim Acreage As Double

Dim pSBar As IStatusBar

Dim i As Long
Set pSBar = Application.StatusBar

' Go through all features, calculate the area/acreage, update the field.
' Area is defined by the linear units (meters, feet) of the feature class's
' projection. If UTM then meters, etc.
For i = 1 To lNumFeat
pSBar.Message(esriStatusMain) = "Add acreage: Updating record " & i & " of " & lNumFeat & "..."
Set pShape = pFeature.Shape
Set pArea = pShape
AreaValue = pArea.Area
' Get the absolute value, in case we have negative areas resulting from
' counterclockwise polygon parameterization (for example, if somebody
' digitized or GPS'd a polygon counterclockwise).
AreaValue = Abs(AreaValue)
If optNativeArea.Value Then
pFeature.Value(indexArea) = AreaValue
End If
If optAcreage.Value Then
pFeature.Value(indexAcre) = ((Sqr(AreaValue) * MeterPerUnit) ^ 2) / SqMetersPerAcre
End If
pFCursor.UpdateFeature pFeature
Set pFeature = pFCursor.NextFeature
Next

pSBar.Message(esriStatusMain) = "Add acreage: Finished updating records. Check the attribute table."

End Sub

' Name: AddGraphicsCoords

' Creator: Pete Yurkosky
' Date: 1/14/2005
' Description: Given a selection of point graphics, will create and display
' a callout box with the x,y coordinates of the point.
' Issues: Currently works only with graphics points. Function
' GetCalloutOnPoint, however, takes an IPoint parameter and
' could be used with an actual feature, in a similar way.

Private pMxDocument As IMxDocument

Private pFillSymbol As IFillSymbol
Private pRgbColor As IRgbColor
Private pCallout As ILineCallout
Private pTextSymbol As IFormattedTextSymbol
Private CalloutLocation As IPoint
Private IsDecimalDegrees As Boolean
Private xOffset, yOffset As Double

10
Sub AddGraphicsCoords()

Dim pActiveView As IActiveView

Dim pGraphicsContainer As IGraphicsContainer
Dim pGraphicsContainerSelect As IGraphicsContainerSelect
Dim pPoint As IPoint
Dim pPtElement As IElement
Dim pCalloutElement As IElement
Dim pEnumElement As IEnumElement

Set pMxDocument = ThisDocument

' There should be a selection of points. Check.

Set pActiveView = pMxDocument.ActivatedView
Set pGraphicsContainerSelect = pActiveView
Set pGraphicsContainer = pActiveView
If pGraphicsContainerSelect.ElementSelectionCount < 1 Then
MsgBox "You must select some point graphics to label."
Exit Sub
End If

' --------------------------------------------------------------
' Now we can set some default parameters for ALL callout boxes,
' whether feature or graphic-based.
' --------------------------------------------------------------

Set pRgbColor = New RgbColor

With pRgbColor
.Red = 255
.Green = 255
.Blue = 255
End With

' Remember: an IFormattedTextSymbol is an interface on a TextSymbol.

' A TextSymbol contains one TextBackground. A LineCallout is a type of
' Callout, which is a type of TextBackground. Each LineCallout has
' a Border property, which is a SimpleFillSymbol
Set pFillSymbol = New SimpleFillSymbol
pFillSymbol.Color = pRgbColor
Set pCallout = New LineCallout
Set pCallout.AccentBar = Nothing
Set pCallout.Border = pFillSymbol
pCallout.Gap = 0
Set pTextSymbol = New TextSymbol
Set pTextSymbol.Background = pCallout

' Use this boolean later to set coordinate text formatting

If pMxDocument.FocusMap.MapUnits = esriDecimalDegrees Then
IsDecimalDegrees = True
Else
IsDecimalDegrees = False
End If

' Set these so that the callouts don't appear right over the point
xOffset = pMxDocument.ActiveView.Extent.Width / 8
yOffset = pMxDocument.ActiveView.Extent.Width / 20

' Use an enumeration of all the selected points.

Set pEnumElement = pGraphicsContainerSelect.SelectedElements
pEnumElement.Reset
Set pPtElement = pEnumElement.Next

11
' Loop through each selected element.
While Not pPtElement Is Nothing
If TypeOf pPtElement Is IMarkerElement Then
Set pPoint = pPtElement.Geometry
Set pCalloutElement = GetCalloutOnPoint(pPoint)
' Can't call AddElement on an empty Geometry
pGraphicsContainer.AddElement pCalloutElement, 0
pCalloutElement.Activate pActiveView.ScreenDisplay
pActiveView.PartialRefresh esriViewGraphics, pCalloutElement, Nothing
Set pPtElement = pEnumElement.Next
Else
MsgBox "Selection must consist only of points!"
Exit Sub
End If
Wend

Set pFillSymbol = Nothing

Set pRgbColor = Nothing
Set pCallout = Nothing
Set pTextSymbol = Nothing
Set CalloutLocation = Nothing

End Sub

Private Function GetCalloutOnPoint(param_Pt As IPoint) As IElement

' Use point's coordinates to create a new callout.
' Return this as an element, and let calling proc. handle display.

Dim xCoord As Double, xCoordText As String

Dim yCoord As Double, yCoordText As String

Dim pTextElement As ITextElement, outElement As IElement

param_Pt.QueryCoords xCoord, yCoord

If IsDecimalDegrees Then
xCoordText = FormatNumber(xCoord, 5, vbUseDefault, vbUseDefault, vbFalse)
yCoordText = FormatNumber(yCoord, 5, vbUseDefault, vbUseDefault, vbFalse)
Else
xCoordText = FormatNumber(xCoord, 2, vbUseDefault, vbUseDefault, vbFalse)
yCoordText = FormatNumber(yCoord, 2, vbUseDefault, vbUseDefault, vbFalse)
End If

' Use this code to set the offset for the callout box
Set CalloutLocation = New Point
CalloutLocation.PutCoords xCoord - xOffset, yCoord + yOffset
pCallout.AnchorPoint = param_Pt

Set pTextElement = New TextElement

Set outElement = pTextElement
outElement.Geometry = CalloutLocation
pTextElement.Text = xCoordText & vbCrLf & yCoordText
pTextElement.Symbol = pTextSymbol
Set GetCalloutOnPoint = outElement

End Function

Add Elevations to a line or contour shapefile

Attribute VB_Name = "ContourElevation_SK"

Option Explicit

Sub ContourElev_SK()

12
 'This macro was compiled by Sudarshan Karki
'with ideas borrowed from many other scripts
'in the ESRI site. ([email protected])

'Set an error handler method

On Error GoTo ErrorHandler

'Declare variables
Dim pMxDocument As IMxDocument
Dim pFeatureLayer As IFeatureLayer
Dim pFeatureClass As IFeatureClass

'Set variables
Set pMxDocument = ThisDocument
Set pFeatureLayer = pMxDocument.SelectedLayer
Set pFeatureClass = pFeatureLayer.FeatureClass

'Check if any layer is selected or not

If pFeatureLayer Is Nothing Then
MsgBox "Please select a layer", vbInformation, "Layer not selected"
GoTo ErrorHandler
End If

'Declare variables for field name and type

Dim SK As Long
SK = pFeatureClass.FindField("Elev")
If SK < 0 Then
Dim TempField As IFieldEdit
Set TempField = New Field
With TempField
.Type = esriFieldTypeDouble
.Name = "Elev"
End With
pFeatureClass.AddField TempField
End If
SK = pFeatureClass.FindField("Elev")

'Define variable to position cursor

Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureClass.Search(Nothing, False)
Dim pFeature As IFeature
Set pFeature = pFeatureCursor.NextFeature

'Check if the required geometry type is selected

Dim pIZAware As IZAware
Set pIZAware = pFeature.Shape

If pFeatureClass.ShapeType <> esriGeometryPolyline Then

If Not pIZAware.ZAware Then
MsgBox "Please select a Polyline shapefile with Z values",
vbExclamation, "Required PointZ"
GoTo ErrorHandler
End If
End If

'Define variables for progress bar

Dim lNumberofFeatures As Long
Dim dInterval As Double
Dim pStatusBar As IStatusBar
Set pStatusBar = StatusBar
Dim pStepProgressor As IStepProgressor
Set pStepProgressor = pStatusBar.ProgressBar

13
 lNumberofFeatures = pFeatureClass.FeatureCount(Nothing)
dInterval = lNumberofFeatures / 100
Static i
i = 1
pStepProgressor.MinRange = 1
pStepProgressor.MaxRange = lNumberofFeatures
pStepProgressor.StepValue = dInterval

'Define variables to extract and store line attributes

Dim pGeometry As IGeometry
Dim pPolyline As IPolyline
Dim Output As Double

'Loop through the table to compute values

'until the cursor reaches the end
While Not pFeature Is Nothing
'Compute field values
Set pGeometry = pFeature.Shape
Set pPolyline = pGeometry
Output = pPolyline.FromPoint.Z
pFeature.Value(SK) = Output
pFeature.Store

'Show status bar and message on the status bar

pStepProgressor.Position = i
pStepProgressor.Message = "Please be patient...calculating " & Str(i) &
" of " & Str(lNumberofFeatures)
pStepProgressor.Step
pStepProgressor.Show
If i < lNumberofFeatures Then
DoEvents
Else
pStepProgressor.Hide
End If

'Advance the cursor to the next row

Set pFeature = pFeatureCursor.NextFeature
i = i + 1
Wend

pStepProgressor.Hide

'Error handler
ErrorHandler:
Exit Sub

End Sub
Add map elements (north arrow and legend)

Description

This sample adds a north arrow and a legend to the Layout View. North arrows
and legends are types of map elements. Map elements are objects that are
related to a map.
In this sample, you will be running a macro created in the Visual Basic Editor.

How to use

1. Start ArcMap.

14
 2. Open an existing map document (.mxd) or add layers to an empty (Untitled)
map document.
3. Click Tools, point to Macros, then click Visual Basic Editor.
This opens the Visual Basic Editor.
4. Click to expand the Project (<YourProject>.mxd) in the Project Explorer.
5. Right-click Project (<YourProject>.mxd), point to Insert, then click
Module.
A new module (Module1, and possibly Module folder) is added to the
Project folder, and the Module1 (Code) window is opened.
6. Copy and paste the following code into the Module1 (Code) window:

Public Sub AddMapSurrounds()

Dim pMxDoc As IMxDocument

Dim pActiveView As IActiveView
Dim pEnv As IEnvelope
Dim pID As New UID
Dim pMapSurround As IMapSurround
Dim pMarkerNorthArrow As IMarkerNorthArrow
Dim pCharacterMarkerSymbol As ICharacterMarkerSymbol

Set pMxDoc = Application.Document

Set pActiveView = pMxDoc.PageLayout
Set pEnv = New Envelope

'Add a north arrow

pEnv.PutCoords 0.2, 0.2, 1, 1
pID.Value = "esriCore.MarkerNorthArrow"
Set pMapSurround = CreateSurround(pID, pEnv, "North Arrow",
pMxDoc.FocusMap, pMxDoc.PageLayout)
'Change out the default north arrow
Set pMarkerNorthArrow = pMapSurround 'QI
Set pCharacterMarkerSymbol = pMarkerNorthArrow.MarkerSymbol 'clones the
symbol
pCharacterMarkerSymbol.CharacterIndex = 200 'change the symbol
pMarkerNorthArrow.MarkerSymbol = pCharacterMarkerSymbol 'set it back

'Add a legend
'In this case just use the default legend
pEnv.PutCoords 7.5, 0.2, 8.5, 4
pID.Value = "esriCore.Legend"
Set pMapSurround = CreateSurround(pID, pEnv, "Legend", pMxDoc.FocusMap,
pMxDoc.PageLayout)

'Refresh the graphics

pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
End Sub

Private Function CreateSurround(pID As UID, pEnv As IEnvelope, strName As

String, _
pMap As IMap, pPageLayout As IPageLayout) As IMapSurround

Dim pGraphicsContainer As IGraphicsContainer

Dim pActiveView As IActiveView
Dim pMapSurroundFrame As IMapSurroundFrame
Dim pMapSurround As IMapSurround
Dim pMapFrame As IMapFrame
Dim pElement As IElement

'MapSurrounds are held in a MapSurroundFrame

'MapSurroundFrames are related to MapFrames
'MapFrames hold Maps

15
 Set pGraphicsContainer = pPageLayout
Set pMapFrame = pGraphicsContainer.FindFrame(pMap)
Set pMapSurroundFrame = pMapFrame.CreateSurroundFrame(pID, Nothing)
pMapSurroundFrame.MapSurround.Name = strName

'Set the geometry of the MapSurroundFrame to give it a location

'Activate it and add it to the PageLayout's graphics container
Set pElement = pMapSurroundFrame
Set pActiveView = pPageLayout
pElement.Geometry = pEnv
pElement.Activate pActiveView.ScreenDisplay
pGraphicsContainer.AddElement pElement, 0

Set CreateSurround = pMapSurroundFrame.MapSurround

End Function

7. Minimize or close the Visual Basic Editor.

8. Switch to Layout View.
9. In ArcMap, click Tools, point to Macros, then click Macros.
10. On the Macros dialog box, click the Macros in drop-down arrow and click
Project.
11. In the list below the Macro name text box, click Module1.AddMapSurrounds.
12. Click Run.

Tip

* Make sure the code in Visual Basic appears as it does in the above steps.
For example, you may have to add carriage returns.

Private Sub CommandButton5_Click()

Dim pMxdoc As IMxDocument

16
Dim pMap As IMap
Set pMxdoc = ThisDocument
'Get the first map in the document
Set pMap = pMxdoc.FocusMap
If pMap.LayerCount = 0 Then
MsgBox "Please add the shapefile first before add new the field name"
MsgBox "You can get this form in Visual Basic Editor and call this form again after added the map in ArcGIS"
Unload Me
Exit Sub
End If

If TextBox1.Text = "" Then

MsgBox "Please Input the new field name you want to added"
Exit Sub
End If
'Get the first layer in the map
Dim pFeatureLayer As IFeatureLayer
Set pFeatureLayer = pMap.Layer(0)
Dim pFieldstable As ITableFields
Dim c As Integer
Set pFieldstable = pFeatureLayer
For e = 0 To pFieldstable.FieldCount - 1 'visible all field
pFieldstable.FieldInfo(e).Visible = False
Next e
Call Test
'Get the feature class for the first layer
Dim pFeatureClass As IFeatureClass
Set pFeatureClass = pFeatureLayer.FeatureClass
'create new field object
Dim pFieldEdit As IFieldEdit
Set pFieldEdit = New Field
Dim pFields As IFields
Set pFields = pFeatureClass.Fields
For i = 0 To pFields.FieldCount - 1
If pFields.Field(i).name = UCase(TextBox1.Text) Then

For c = 0 To pFieldstable.FieldCount - 1
If pFieldstable.Field(c).name = UCase(TextBox1.Text) Then
pFieldstable.FieldInfo(c).Visible = True
Call Test
pMxdoc.CurrentContentsView.ContextItem = pFeatureLayer
ThisDocument.CommandBars.Find(ArcID.Layer_Table).Execute
UserForm2.Hide
pMxdoc.UpdateContents
pMxdoc.ActiveView.Refresh
If MsgBox("Did you want delete this field?", vbQuestion + vbYesNo, "Delete") = vbYes Then
DeleteField UCase(TextBox1.Text)
Else
CloseWindows
UserForm2.Show
Exit Sub
End If
Exit For
End If
Next c
Exit For
End If
Next

Set pFieldstable = pFeatureLayer

For h = 0 To pFieldstable.FieldCount - 1 'visible all field
pFieldstable.FieldInfo(h).Visible = True

17
 Next h

Set pFields = pFeatureClass.Fields

'create new calculator object
Dim pCalc As ICalculator
Set pCalc = New Calculator
Dim pCursor As ICursor
If ComboBox1.Text = "Short Integer" Then
'create properties of new field
With pFieldEdit
.name = UCase(TextBox1.Text)
.Type = 0
.Precision = TextBox3.Text
End With
'add new field
pFeatureClass.AddField pFieldEdit
ElseIf ComboBox1.Text = "Long Integer" Then
'create properties of new field
With pFieldEdit
.name = UCase(TextBox1.Text)
.Type = 1
.Precision = TextBox3.Text
End With
'add new field
pFeatureClass.AddField pFieldEdit
ElseIf ComboBox1.Text = "Float" Then
'create properties of new field
With pFieldEdit
.name = UCase(TextBox1.Text)
.Type = 2
.Precision = TextBox3.Text
.Scale = TextBox4.Text
End With
'add new field
pFeatureClass.AddField pFieldEdit
ElseIf ComboBox1.Text = "Double" Then
'create properties of new field
With pFieldEdit
.name = UCase(TextBox1.Text)
.Type = 3
.Precision = TextBox3.Text
.Scale = TextBox4.Text
End With
'add new field
pFeatureClass.AddField pFieldEdit
ElseIf ComboBox1.Text = "Text" Then
'create properties of new field
With pFieldEdit
.name = UCase(TextBox1.Text)
.Type = 4
.Length = TextBox2.Text
End With
'add new field
pFeatureClass.AddField pFieldEdit
'calculation script to be performed on new field
Set pCursor = pFeatureClass.Update(Nothing, True)
Set pCalc.Cursor = pCursor
With pCalc
.Expression = """" & TextBox5.Text & """"
.Field = UCase(TextBox1.Text)
End With
'perform field calculation

18
 pCalc.ShowErrorPrompt = True
pCalc.Calculate

ElseIf ComboBox1.Text = "Date" Then

'create properties of new field
With pFieldEdit
.name = UCase(TextBox1.Text)
.Type = 5
End With
'add new field
pFeatureClass.AddField pFieldEdit
End If

'update the attribute table of layer in TOC

Call Test
MsgBox "Add Field Successfuly"
For g = 0 To pFieldstable.FieldCount - 1 'visible all field
pFieldstable.FieldInfo(g).Visible = True
Next g
CloseWindows
pMxdoc.UpdateContents
pMxdoc.ActiveView.Refresh

Set pMxdoc = Nothing

Set pFeatureClass = Nothing
Set pFieldEdit = Nothing
Set pFields = Nothing
Set pMap = Nothing
Set pFeatureLayer = Nothing
Set pFieldEdit = Nothing
Set pField = Nothing
Set pCalc = Nothing
Set pFieldstable = Nothing
Set pCursor = Nothing

Unload Me
End Sub
Private Sub CloseWindows()

Dim pAppWindows As IApplicationWindows

Set pAppWindows = Application

Dim pWindowSet As ISet

Set pWindowSet = pAppWindows.DataWindows

Dim pDataWindow As IDataWindow

Dim pTableWindow As ITableWindow

pWindowSet.Reset
Set pDataWindow = pWindowSet.Next

While Not pDataWindow Is Nothing

If (TypeOf pDataWindow Is ITableWindow) Then
Set pTableWindow = pDataWindow
pTableWindow.Show (False)
End If
Set pDataWindow = pWindowSet.Next
Wend
Set pAppWindows = Nothing
Set pWindowSet = Nothing

19
 Set pTableWindow = Nothing
Set pDataWindow = Nothing
End Sub
Private Sub DeleteField(Fieldname As String)
Dim pMxdoc As IMxDocument
Dim pFeatureLayer As IFeatureLayer
Dim pFeatureClass As IFeatureClass
Dim pFieldEdit As IFieldEdit
Dim pFields As IFields
Dim pField1 As IField
Set pMxdoc = ThisDocument
Set pFeatureLayer = pMxdoc.FocusMap.Layer(0)
Set pFeatureClass = pFeatureLayer.FeatureClass
Set pFieldEdit = New Field
Set pFields = pFeatureClass.Fields
Set pField1 = pFields.Field(pFields.FindField(Fieldname))
pFeatureLayer.FeatureClass.DeleteField pField1
End Sub

Sub Test()
Dim pDWindows As IApplicationWindows
Set pDWindows = Application

Dim pWinSet As ISet

Set pWinSet = pDWindows.DataWindows

pWinSet.Reset
Dim pDWin As IDataWindow
Set pDWin = pWinSet.Next
Do Until pDWin Is Nothing
If TypeOf pDWin Is ITableWindow Then
Dim pTWin As ITableWindow
Set pTWin = pDWin

pTWin.TableControl.RemoveAndReloadCache
' also tried pTWin.Refresh without success
' also tried pTWin.TableControl.Redraw without success
End If
Set pDWin = pWinSet.Next
Loop
Set pWinSet = Nothing
Set pDWin = Nothing
Set pTWin = Nothing
Set pDWindows = Nothing
End Sub
Private Sub ComboBox1_Click()
If ComboBox1.Text = "Short Integer" Then
TextBox2.Visible = False
TextBox3.Visible = True
TextBox4.Visible = False
Label1.Visible = False
Label2.Visible = True
Label3.Visible = False
ElseIf ComboBox1.Text = "Long Integer" Then
TextBox2.Visible = False
TextBox3.Visible = True
TextBox4.Visible = False
Label1.Visible = False
Label2.Visible = True
Label3.Visible = False
ElseIf ComboBox1.Text = "Float" Then
TextBox2.Visible = False

20
TextBox3.Visible = True
TextBox4.Visible = True
Label1.Visible = False
Label2.Visible = True
Label3.Visible = True
ElseIf ComboBox1.Text = "Double" Then
TextBox2.Visible = False
TextBox3.Visible = True
TextBox4.Visible = True
Label1.Visible = False
Label2.Visible = True
Label3.Visible = True
ElseIf ComboBox1.Text = "Text" Then
TextBox2.Visible = True
TextBox3.Visible = False
TextBox4.Visible = False
Label1.Visible = True
Label2.Visible = False
Label3.Visible = False
ElseIf ComboBox1.Text = "Date" Then
TextBox2.Visible = False
TextBox3.Visible = False
TextBox4.Visible = False
Label1.Visible = False
Label2.Visible = False
Label3.Visible = False
End If

End Sub

Private Sub CommandButton6_Click()

MsgBox "You can get this form in Visual Basic Editor and call this form again after added the map in ArcGIS"
Unload Me
End Sub

Public Sub Driver()

Dim pMxdoc As IMxDocument
Dim pMap As IMap
Set pMxdoc = ThisDocument
'Get the first map in the document
Set pMap = pMxdoc.FocusMap
If pMap.LayerCount = 0 Then
MsgBox "Please add the shapefile first"
Unload Me
Exit Sub
End If
'Get the first layer in the map
Dim pFeatureLayer As IFeatureLayer
Set pFeatureLayer = pMap.Layer(0)
Dim LayerName As String

'Dummy subroutine to call SetCurrentLayer

Dim pApp As IApplication
Dim m_pEditor As IEditor
Dim SubType As Long
Dim pID As New UID
pID = "esriEditor.Editor"
Set pApp = Application
Set m_pEditor = pApp.FindExtensionByCLSID(pID)

21
 LayerName = pFeatureLayer.name
SubType = 0
'SetCurrentLayer LayerName, SubType

'Subroutine to set the current layer based on a name and subtype index
Dim pEditLayers As IEditLayers

Dim Count As Integer

Set pEditLayers = m_pEditor
Set pMap = pMxdoc.FocusMap
'Loop through all of the maps layers to find the desired one
For Count = 0 To pMap.LayerCount - 1
If pMap.Layer(Count).name = LayerName Then
'Make sure the layer is editable
If pEditLayers.IsEditable(pMap.Layer(Count)) Then
Set pFeatureLayer = pMap.Layer(Count)
pEditLayers.SetCurrentLayer pFeatureLayer, SubType
Exit Sub
Else
MsgBox "This layer is not editable"
Exit Sub
End If
End If
Next Count

End Sub

Private Sub UserForm_Initialize()

ComboBox1.AddItem "Short Integer"
ComboBox1.AddItem "Long Integer"
ComboBox1.AddItem "Float"
ComboBox1.AddItem "Double"
ComboBox1.AddItem "Text"
ComboBox1.AddItem "Date"
If ComboBox1.ListCount > 0 Then ComboBox1.ListIndex = 0
CloseWindows
End Sub
Add Node to mid point of two node polyline

Private Sub AddNode2Polyline()

'For NFCDD upload

'For lines with only two nodes it will add a new node at the centroid of that
line

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Dim pFLayer As IFeatureLayer
Set pFLayer = pMxDoc.CurrentContentsView.SelectedItem
Dim pFC As IFeatureCursor
Dim pFeature As IFeature
Dim pPointCollection As IPointCollection
Dim pFeatureSelection As IFeatureSelection
Set pFeatureSelection = pFLayer
Dim ShapeCounter As Integer

22
pFeatureSelection.Clear

If pFLayer.FeatureClass.ShapeType = esriGeometryPolyline Then

Set pFC = pFLayer.Search(Nothing, False)

Set pFeature = pFC.NextFeature
Set pPointCollection = pFeature.Shape

Do Until pFeature Is Nothing

Set pPointCollection = pFeature.Shape

If pPointCollection.PointCount <= 2 Then

Dim pPointA As IPoint

Set pPointA = New Point
Dim pPointB As IPoint
Set pPointB = New Point
Dim pPointC As IPoint
Set pPointC = New Point

Set pPointA = pPointCollection.Point(0)

Set pPointB = pPointCollection.Point(1)

If pPointA.X > pPointB.X Then

X = pPointB.X + ((pPointA.X - pPointB.X) / 2)
Else
X = pPointA.X + ((pPointB.X - pPointA.X) / 2)
End If

If pPointA.Y > pPointB.Y Then

Y = pPointB.Y + ((pPointA.Y - pPointB.Y) / 2)
Else
Y = pPointA.Y + ((pPointB.Y - pPointA.Y) / 2)
End If

pPointC.X = X
pPointC.Y = Y

pPointCollection.AddPoint pPointC, 1
Set pFeature.Shape = pPointCollection
pFeature.Store
pFeatureSelection.Add pFeature
ShapeCounter = ShapeCounter + 1

End If

Set pFeature = pFC.NextFeature

Loop

MsgBox (ShapeCounter & " polyline have been updated")

pMxDoc.ActiveView.Refresh

Else

MsgBox ("Please select polyline layer")

Exit Sub

End If

End Sub

23
Add a shapefile to a map

Description

This sample, which can easily be changed to support different data types, opens
a shapefile on your local disk and adds the contents to the map as a feature
layer.
In this sample, you will be adding a control button and writing the code for it.

How to use

1. Start ArcMap.
2. Open an existing map document (.mxd) or add layers to the empty
(Untitled) map document.
3. Click Tools and click Customize.
4. Click the Commands tab.
5. Click the drop-down arrow on the Save in combo box and click the map
document in which the new command will be saved.
6. Scroll through the Categories list and click [UIControls].
7. Click New UIControl.
8. Click to select the UIButtonControl as the UIControl Type.
9. Click Create.
10. Click and drag the new Project.UIButtonControl1 in the Commands list and
drop it on any toolbar.
11. Click Close.
12. Right-click the newly placed control and click View Source.
This opens the Visual Basic Editor.
13. In the ThisDocument (Code) window, click the Procedure Box drop-down
arrow (the one on the right of the window) and choose Click.
This adds the wrapper code for the procedure you are creating.
14. Copy and paste the following code between the two wrapper code lines
(between Private Sub UIButtonControl1_Click() and End Sub).

Dim pWorkspaceFactory As IWorkspaceFactory

Set pWorkspaceFactory = New ShapefileWorkspaceFactory

Dim pWorkSpace As IFeatureWorkspace

'Change C:\Source to the source location of the shapefile you wish to add
Set pWorkSpace = pWorkspaceFactory.OpenFromFile("C:\Source", 0)

Dim pClass As IFeatureClass

'Change USStates to the name of the shapefile you wish to add
Set pClass = pWorkSpace.OpenFeatureClass("USStates")

Dim pLayer As IFeatureLayer

Set pLayer = New FeatureLayer
Set pLayer.FeatureClass = pClass
pLayer.Name = pClass.AliasName

Dim pMxDoc As IMxDocument

Set pMxDoc = ThisDocument

pMxDoc.AddLayer pLayer
pMxDoc.ActiveView.PartialRefresh esriViewGeography, pLayer, Nothing

15. Go to line 5, Set pWorkSpace =

pWorkspaceFactory.OpenFromFile("C:\Source", 0), and change C:\Source to the
source location of the shapefile you want to add.

24
 16. Go to line 8, Set pClass = pWorkSpace.OpenFeatureClass("USStates"), and
change USStates to the name of the shapefile you want to add.
17. Close the Visual Basic Editor.
18. Click the new button in ArcMap to add the feature class to the map.

Tip

* Make sure the code in Visual Basic appears as it does in the above steps.
For example, you may have to add carriage returns.
Title: AddPointsAtCrossings Version: 1.2

Provided by: ESRI-TeamWater as an unsupported, free sample for Water Utilities

Purpose: Create new point features at every crossing (intersection) between line features in two specified
layers

Uses:
Create crossing points between water mains and gas pipes

Modifications:
1.2 > Changed to Changed line 225 from
pSFilter.SpatialRel = esriSpatialRelCrosses
To
pSFilter.SpatialRel = esriSpatialRelIntersects

esriSpatialRelCrosses Does not return a point where the end points of lines meet.
esriSpatialRelIntersects Returns a feature if any spatial relationship is found.

1.3> Correction to this help file under data requirements.

ONLY the Point layer MUST be in an Editable workspace, not all 3 as previously stated.

Files:
ReadMe_ AddPointsAtCrossings.htm
AddPointsAtCrossings.bas

Data requirements:

• Two line layers are needed.

• One point layer is needed.
• The point layer must be in an editable workspace.
• These layers may be either shapefiles or geodatabase feature classes.
• Must have edit target set to the desired point feature.
• Optionally, may have some lines from the first specified layer selected.

Overview of setup (detailed instructions follow this overview):

1) use VBA (provided with ArcMap) to import the code file provided with this sample.
2) optionally, alter the user configuration at the top of the code to match your data
3) optionally, drag one or more of the provided macros onto a toolbar in ArcMap
4) save your mxd (if you did not elect to save these changes to normal)

Setup:
In ArcMap
Tools>Macros>VB Editor

In VB Editor
In the Project Window…
Click Project to store changes for this map document only or
Click Normal to store changes for all maps you access on your computer

File>Import File...

25
 Navigate to AddPointsAtCrossings.bas and click Open
Expand the Modules folder
Double-click the AddPointsAtCrossings module to view the code
Change the user configuration as desired (see user configuration below)
Close VB Window

If you chose to save your changes with this Project, save your map document now.

User configuration:
If you run the UseHighlightedLayers routine, you will not need to change any code.

If desired, you may configure the Example_ AddPointsAtCrossings routine to work with your data, so that
you will not need to highlight any layers in the Table of Contents. You will still need to set your edit target
and optionally select some lines from the first layer.

To use:
In ArcMap, be sure you have the necessary layers in your map.
Be sure that you are editing.
Set the edit target to the point feature you wish to create.
In the Table of Contents, highlight the two line layers that you wish to use.
Select some of the points.
Optionally, select one line.
Tools>Macros>Macros…
Select AddLines.UseHighlightedLayers
Click Run

Here's what happens...

New point features are created.

Credits:
This code was created by ESRI-Team Water.

Your Input:
Please send any comments via email to Michele Lundeen at [email protected].

1)

Option Explicit
Public Sub Example_AddPointsAtCrossings()
Call AddPoints("Water Mains", "Sewer Gravity Mains")
End Sub

Public Sub UseHighlightedLayers()

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pTest As Variant
Dim pSetLayers As ISet
Dim pLayer1 As ILayer
Dim pLayer2 As ILayer
Dim pFLayer1 As IFeatureLayer
Dim pFLayer2 As IFeatureLayer
Dim pFC1 As IFeatureClass
Dim pFC2 As IFeatureClass

Set pMxDoc = Application.Document

Set pMap = pMxDoc.FocusMap

26
 ' Verify that there are at least 2 layers in the table on contents
If pMap.LayerCount < 2 Then
MsgBox "Must have at least two layers in your map."
Exit Sub
End If

'Verify that two layers are selected in the TOC

Set pTest = pMxDoc.SelectedItem
If pTest Is Nothing Then
MsgBox "Please highlight one or two line layers in the TOC."
Exit Sub
End If
If Not TypeOf pMxDoc.SelectedItem Is ISet Then
Set pLayer1 = pMxDoc.SelectedItem
Set pLayer2 = pMxDoc.SelectedItem
Else
Set pSetLayers = pMxDoc.SelectedItem
If pSetLayers.Count > 2 Then
MsgBox "Please highlight only one or two line layers in the TOC."
Exit Sub
End If
pSetLayers.Reset
Set pLayer1 = pSetLayers.Next
Set pLayer2 = pSetLayers.Next
End If

'Verify that the highlighted layers are feature layers

If Not TypeOf pLayer1 Is IFeatureLayer Then
MsgBox pLayer1.name & " is not a feature layer."
Exit Sub
End If
If Not TypeOf pLayer2 Is IFeatureLayer Then
MsgBox pLayer2.name & " is not a feature layer."
Exit Sub
End If

'Get the feature layer and feature class pointers

Set pFLayer1 = pLayer1
Set pFLayer2 = pLayer2
Set pFC1 = pFLayer1.FeatureClass
Set pFC2 = pFLayer2.FeatureClass

'If the first highlighted layer is a line layer...

If pFC1.ShapeType = esriGeometryPolyline Or pFC1.ShapeType = esriGeometryLine And _
pFC2.ShapeType = esriGeometryPolyline Or pFC1.ShapeType = esriGeometryLine Then

'Run the Addpoints routine

AddPoints pLayer1.name, pLayer2.name
Else
MsgBox "You need two line layers highlighted."
Exit Sub
End If
End Sub

Public Sub AddPoints(sLineLayer1 As String, sLineLayer2 As String)

' Purpose: Adds points wherever the line features from the specified layers cross
' Requires: must be editing and have target point layer set
' Optionally: have some features selected in the first line layer

On Error GoTo EH
Dim pApp As IApplication

27
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pId As New UID
Dim pEditor As IEditor
Dim pELayers As IEditLayers
Dim pFLayerLine1 As IFeatureLayer
Dim pFLayerLine2 As IFeatureLayer
Dim pFLayerCross As IFeatureLayer
Dim pFCLine1 As IFeatureClass
Dim pFCLine2 As IFeatureClass
Dim pFCCross As IFeatureClass
Dim pFSel1 As IFeatureSelection
Dim pFCursor1 As IFeatureCursor
Dim pFCursor2 As IFeatureCursor
Dim pFeature1 As IFeature
Dim pFeature2 As IFeature
Dim pNewFeature As IFeature
Dim lCount As Long
Dim lTotal As Long
Dim pRowSubtypes As IRowSubtypes
Dim pSubtypes As ISubtypes
Dim lSubCode As Long
Dim bHasSubtypes As Boolean
Dim pCurve1 As ICurve
Dim pCurve2 As ICurve
Dim pTopoOp1 As ITopologicalOperator
Dim pEnv1 As IEnvelope
Dim pSFilter As ISpatialFilter
Dim pPoint As IPoint
Dim pMPoint As IMultipoint
Dim pGeoCol As IGeometryCollection
Dim lGeoTotal As Long
Dim lGeoCount As Integer

Set pApp = Application

Set pMxDoc = pApp.Document
Set pMap = pMxDoc.FocusMap

' Verify that there are at least 2 layers in the table on contents
If pMap.LayerCount < 2 Then
MsgBox "Must have at least two layers in your map."
Exit Sub
End If

'Find the two line layers by name

Set pFLayerLine1 = FindFLayerByName(pMap, sLineLayer1)
Set pFLayerLine2 = FindFLayerByName(pMap, sLineLayer2)

'Verify layers exisit

If pFLayerLine1 Is Nothing Then
MsgBox sLineLayer1 & " layer not found."
Exit Sub
End If
If pFLayerLine2 Is Nothing Then
MsgBox sLineLayer2 & " layer not found."
Exit Sub
End If

Set pFCLine1 = pFLayerLine1.FeatureClass

Set pFCLine2 = pFLayerLine2.FeatureClass

'Verify that it is a correct type of geometry

28
 If pFCLine1.ShapeType <> esriGeometryPolyline And pFCLine1.ShapeType <> esriGeometryLine Then
MsgBox sLineLayer1 & " layer must be a line or polyline layer."
Exit Sub
End If
If pFCLine2.ShapeType <> esriGeometryPolyline And pFCLine2.ShapeType <> esriGeometryLine Then
MsgBox sLineLayer2 & " layer must be a line or polyline layer."
Exit Sub
End If

'Verify that we are editing

pId = "esriEditor.Editor"
Set pEditor = pApp.FindExtensionByCLSID(pId)
If Not (pEditor.EditState = esriStateEditing) Then
MsgBox "Must be editing."
Exit Sub
End If

'Verify that the target is a point layer

Set pELayers = pEditor
If pELayers.CurrentLayer.FeatureClass.ShapeType = esriGeometryMultipoint Then
MsgBox "This edit target is a multipoint layer. Please use a point layer." & vbNewLine & "Convert using
""Multipart To Singlepart"" GP tool if needed."
Exit Sub
End If

If pELayers.CurrentLayer.FeatureClass.ShapeType <> esriGeometryPoint Then

MsgBox "Edit target must be a point layer (i.e. crossing points)."
Exit Sub
End If

'Get the target point layer

Set pFLayerCross = pELayers.CurrentLayer
Set pFCCross = pFLayerCross.FeatureClass

'Get current target subtype

If TypeOf pFCCross Is ISubtypes Then
Set pSubtypes = pFCCross
If pSubtypes.HasSubtype Then
bHasSubtypes = True
lSubCode = pELayers.CurrentSubtype
Else
bHasSubtypes = False
End If
End If

'Update Message bar

pApp.StatusBar.Message(0) = "Adding " & pFLayerCross.name & " points..."

'Start edit operation (for undo)

pEditor.StartOperation

'Now that an edit operation has been started, use a different error handler
'in order to abort this operation if a problem occurs
On Error GoTo EH2

'If any features in the first layer are selected, use them only
'Otherwise use all features from the first layer
Set pFSel1 = pFLayerLine1
If pFSel1.SelectionSet.Count > 0 Then
pFSel1.SelectionSet.Search Nothing, False, pFCursor1
lTotal = pFSel1.SelectionSet.Count
Else

29
 If vbNo = MsgBox("Use all " & pFCLine1.FeatureCount(Nothing) & " features?", vbYesNo, "Add Points") Then
Exit Sub
End If
Set pFCursor1 = pFLayerLine1.Search(Nothing, False)
lTotal = pFLayerLine1.FeatureClass.FeatureCount(Nothing)
End If

'Step through each feature in layer1

lCount = 1
Set pFeature1 = pFCursor1.NextFeature
Do While Not pFeature1 Is Nothing

'Update status bar

lCount = lCount + 1
pApp.StatusBar.Message(0) = "Processing " & pFLayerLine1.name & " lines ..." & Str(lCount) & " of " &
Str(lTotal)

'Get needed references to this feature from layer1

Set pCurve1 = pFeature1.Shape
Set pTopoOp1 = pCurve1
Set pEnv1 = pCurve1.Envelope

'Create a spatial filter for layer2 to find any potentially crossing lines
Set pSFilter = New SpatialFilter
Set pSFilter.Geometry = pEnv1
pSFilter.GeometryField = pFCLine2.ShapeFieldName
pSFilter.SpatialRel = esriSpatialRelIntersects
Set pFCursor2 = pFCLine2.Search(pSFilter, False)

' Step through each feature in layer2 that crosses the envelope of the
' current feature we are processing from layer1
Set pFeature2 = pFCursor2.NextFeature
Do While Not pFeature2 Is Nothing

'Get the geometry for this feature from layer2

If pFLayerLine1 Is pFLayerLine2 Then
Set pCurve2 = pFeature2.ShapeCopy
Else
Set pCurve2 = pFeature2.Shape
End If

'Find all intersecting points (returned as multipoint)

Set pMPoint = pTopoOp1.Intersect(pCurve2, esriGeometry0Dimension)
If Not pMPoint Is Nothing Then
If Not pMPoint.IsEmpty Then
Set pGeoCol = pMPoint

'Step through each point in the multipoint (often just one)

lGeoTotal = pGeoCol.GeometryCount
For lGeoCount = 0 To lGeoTotal - 1

'Get the point

Set pPoint = pGeoCol.Geometry(lGeoCount)

'Create the new feature and set it's geometry

Set pNewFeature = pFCCross.CreateFeature
Set pNewFeature.Shape = pPoint

'If needed, set the subtype and default values

If bHasSubtypes Then
Set pRowSubtypes = pNewFeature
pRowSubtypes.SubtypeCode = lSubCode

30
 pRowSubtypes.InitDefaultValues
End If

'Save the new feature

pNewFeature.Store

Next lGeoCount
End If
End If

Set pFeature2 = pFCursor2.NextFeature

Loop

Set pFeature1 = pFCursor1.NextFeature

Loop

'Stop feature editing

pEditor.StopOperation ("Add Points")

'Clear all feature selections

pMap.ClearSelection

'Redraw the map so you'll see the new lines

pMxDoc.ActiveView.Refresh

'MsgBox "Auto Add Points is complete."

pApp.StatusBar.Message(0) = "Add Points is complete."

Exit Sub
EH:

MsgBox Err.Number & " " & Err.Description

Exit Sub
EH2:
pEditor.AbortOperation
MsgBox Err.Number & " " & Err.Description
Exit Sub
End Sub

Public Function FindFLayerByName(pMap As IMap, sLayerName As String) As IFeatureLayer

'This function will return only feature layers.
'It can find feature layers within groups.

Dim pEnumLayer As IEnumLayer

Dim pCompositeLayer As ICompositeLayer
Dim i As Integer

Set pEnumLayer = pMap.Layers

pEnumLayer.Reset

Dim pLayer As ILayer

Set pLayer = pEnumLayer.Next

Do While Not pLayer Is Nothing

If TypeOf pLayer Is ICompositeLayer Then
Set pCompositeLayer = pLayer
For i = 0 To pCompositeLayer.Count - 1
With pCompositeLayer
If .Layer(i).name = sLayerName Then
If TypeOf .Layer(i) Is IFeatureLayer Then

31
 Set FindFLayerByName = pCompositeLayer.Layer(i)
Exit Function
End If
End If
End With
Next i
ElseIf pLayer.name = sLayerName And TypeOf pLayer Is IFeatureLayer Then
Set FindFLayerByName = pLayer
Exit Function
End If
Set pLayer = pEnumLayer.Next
Loop

End Function
2)

Option Explicit
Public Sub Example_AddPointsAtCrossings()
Call AddPoints("Water Mains", "Sewer Gravity Mains")
End Sub

Public Sub UseHighlightedLayers()

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pTest As Variant
Dim pSetLayers As ISet
Dim pLayer1 As ILayer
Dim pLayer2 As ILayer
Dim pFLayer1 As IFeatureLayer
Dim pFLayer2 As IFeatureLayer
Dim pFC1 As IFeatureClass
Dim pFC2 As IFeatureClass

Set pMxDoc = Application.Document

Set pMap = pMxDoc.FocusMap

' Verify that there are layers in the table on contents

If pMap.LayerCount < 3 Then
MsgBox "Must have at least three layers in your map."
Exit Sub
End If

'Verify that two layers are selected in the TOC

Set pTest = pMxDoc.SelectedItem
If pTest Is Nothing Then
MsgBox "Please highlight two layers in the TOC."
Exit Sub
End If
If Not TypeOf pMxDoc.SelectedItem Is ISet Then
MsgBox "Please highlight two layers in the TOC."
Exit Sub
End If
Set pSetLayers = pMxDoc.SelectedItem
If pSetLayers.Count <> 2 Then
MsgBox "Please highlight only two layers in the TOC."
Exit Sub
End If

'Get each of these highlighted layers from the TOC

pSetLayers.Reset
Set pLayer1 = pSetLayers.Next

32
 Set pLayer2 = pSetLayers.Next

'Verify that the highlighted layers are feature layers

If Not TypeOf pLayer1 Is IFeatureLayer Then
MsgBox pLayer1.name & " is not a feature layer."
Exit Sub
End If
If Not TypeOf pLayer2 Is IFeatureLayer Then
MsgBox pLayer2.name & " is not a feature layer."
Exit Sub
End If

'Get the feature layer and feature class pointers

Set pFLayer1 = pLayer1
Set pFLayer2 = pLayer2
Set pFC1 = pFLayer1.FeatureClass
Set pFC2 = pFLayer2.FeatureClass

'If the first highlighted layer is a line layer...

If pFC1.ShapeType = esriGeometryPolyline Or pFC1.ShapeType = esriGeometryLine And _
pFC2.ShapeType = esriGeometryPolyline Or pFC1.ShapeType = esriGeometryLine Then

'Run the Addlines routine

AddPoints pLayer1.name, pLayer2.name
Else
MsgBox "You need two line layers highlighted."
Exit Sub
End If
End Sub

Public Sub AddPoints(sLineLayer1 As String, sLineLayer2 As String)

' Purpose: Adds points wherever the line features from the specified layers cross
' Requires: must be editing and have target point layer set
' Optionally: have some features selected in the first line layer

On Error GoTo EH
Dim pApp As IApplication
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pId As New UID
Dim pEditor As IEditor
Dim pELayers As IEditLayers
Dim pFLayerLine1 As IFeatureLayer
Dim pFLayerLine2 As IFeatureLayer
Dim pFLayerCross As IFeatureLayer
Dim pFCLine1 As IFeatureClass
Dim pFCLine2 As IFeatureClass
Dim pFCCross As IFeatureClass
Dim pFSel1 As IFeatureSelection
Dim pFCursor1 As IFeatureCursor
Dim pFCursor2 As IFeatureCursor
Dim pFeature1 As IFeature
Dim pFeature2 As IFeature
Dim pNewFeature As IFeature
Dim lCount As Long
Dim lTotal As Long
Dim pRowSubtypes As IRowSubtypes
Dim pSubtypes As ISubtypes
Dim lSubCode As Long
Dim bHasSubtypes As Boolean
Dim pCurve1 As ICurve
Dim pCurve2 As ICurve

33
Dim pTopoOp1 As ITopologicalOperator
Dim pEnv1 As IEnvelope
Dim pSFilter As ISpatialFilter
Dim pPoint As IPoint
Dim pMPoint As IMultipoint
Dim pGeoCol As IGeometryCollection
Dim lGeoTotal As Long
Dim lGeoCount As Integer

Set pApp = Application

Set pMxDoc = pApp.Document
Set pMap = pMxDoc.FocusMap

' Verify that there are layers in the table on contents

If pMap.LayerCount < 3 Then
MsgBox "Must have at least three layers in your map."
Exit Sub
End If

'Find the two line layers by name

Set pFLayerLine1 = FindFLayerByName(pMap, sLineLayer1)
Set pFLayerLine2 = FindFLayerByName(pMap, sLineLayer2)

'Verify layers exisit

If pFLayerLine1 Is Nothing Then
MsgBox sLineLayer1 & " layer not found."
Exit Sub
End If
If pFLayerLine2 Is Nothing Then
MsgBox sLineLayer2 & " layer not found."
Exit Sub
End If

Set pFCLine1 = pFLayerLine1.FeatureClass

Set pFCLine2 = pFLayerLine2.FeatureClass

'Verify that it is a correct type of geometry

If pFCLine1.ShapeType <> esriGeometryPolyline And pFCLine1.ShapeType <> esriGeometryLine Then
MsgBox sLineLayer1 & " layer must be a line or polyline layer."
Exit Sub
End If
If pFCLine2.ShapeType <> esriGeometryPolyline And pFCLine2.ShapeType <> esriGeometryLine Then
MsgBox sLineLayer2 & " layer must be a line or polyline layer."
Exit Sub
End If

'Verify that we are editing

pId = "esriCore.Editor"
Set pEditor = pApp.FindExtensionByCLSID(pId)
If Not (pEditor.EditState = esriStateEditing) Then
MsgBox "Must be editing."
Exit Sub
End If

'Verify that the target is a point layer

Set pELayers = pEditor
If pELayers.CurrentLayer.FeatureClass.ShapeType <> esriGeometryPoint Then
MsgBox "Edit target must be a point layer (i.e. crossing points)."
Exit Sub
End If

'Get the target polyline layer

34
 Set pFLayerCross = pELayers.CurrentLayer
Set pFCCross = pFLayerCross.FeatureClass

'Get current target subtype

If TypeOf pFCCross Is ISubtypes Then
Set pSubtypes = pFCCross
If pSubtypes.HasSubtype Then
bHasSubtypes = True
lSubCode = pELayers.CurrentSubtype
Else
bHasSubtypes = False
End If
End If

'Update Message bar

pApp.StatusBar.Message(0) = "Adding " & pFLayerCross.name & " points..."

'Start edit operation (for undo)

pEditor.StartOperation

'Now that an edit operation has been started, use a different error handler
'in order to abort this operation if a problem occurs
On Error GoTo EH2

'If any features in the first layers are selected, use them only
'Otherwise use all features from the first layer
Set pFSel1 = pFLayerLine1
If pFSel1.SelectionSet.Count > 0 Then
pFSel1.SelectionSet.Search Nothing, False, pFCursor1
lTotal = pFSel1.SelectionSet.Count
Else
Set pFCursor1 = pFLayerLine1.Search(Nothing, False)
lTotal = pFLayerLine1.FeatureClass.FeatureCount(Nothing)
End If

'Step through each feature in layer1

lCount = 1
Set pFeature1 = pFCursor1.NextFeature
Do While Not pFeature1 Is Nothing

'Update status bar

lCount = lCount + 1
pApp.StatusBar.Message(0) = "Processing " & pFLayerLine1.name & " lines ..." & Str(lCount) & " of " &
Str(lTotal)

'Get needed references to this feature from layer1

Set pCurve1 = pFeature1.Shape
Set pTopoOp1 = pCurve1
Set pEnv1 = pCurve1.Envelope

'Create a spatial filter for layer2 to find any potentially crossing lines
Set pSFilter = New SpatialFilter
Set pSFilter.Geometry = pEnv1
pSFilter.GeometryField = pFCLine2.ShapeFieldName
pSFilter.SpatialRel = esriSpatialRelIntersects
Set pFCursor2 = pFCLine2.Search(pSFilter, False)

' Step through each feature in layer2 that crosses the envelope of the
' current feature we are processing from layer1
Set pFeature2 = pFCursor2.NextFeature
Do While Not pFeature2 Is Nothing

35
 'Get the geometry for this feature from layer2
Set pCurve2 = pFeature2.Shape

'Find all intersecting points (returned as multipoint)

Set pMPoint = pTopoOp1.Intersect(pCurve2, esriGeometry0Dimension)
If Not pMPoint Is Nothing Then
If Not pMPoint.IsEmpty Then
Set pGeoCol = pMPoint

'Step through each point in the multipoint (often just one)

lGeoTotal = pGeoCol.GeometryCount
For lGeoCount = 0 To lGeoTotal - 1

'Get the point

Set pPoint = pGeoCol.Geometry(lGeoCount)

'Create the new feature and set it's geometry

Set pNewFeature = pFCCross.CreateFeature
Set pNewFeature.Shape = pPoint

'If needed, set the subtype and default values

If bHasSubtypes Then
Set pRowSubtypes = pNewFeature
pRowSubtypes.SubtypeCode = lSubCode
pRowSubtypes.InitDefaultValues
End If

'Save the new feature

pNewFeature.Store

Next lGeoCount
End If
End If

Set pFeature2 = pFCursor2.NextFeature

Loop

Set pFeature1 = pFCursor1.NextFeature

Loop

'Stop feature editing

pEditor.StopOperation ("Add Points")

'Clear all feature selections

pMap.ClearSelection

'Redraw the map so you'll see the new lines

pMxDoc.ActiveView.Refresh

'MsgBox "Auto Add Points is complete."

pApp.StatusBar.Message(0) = "Add Points is complete."

Exit Sub
EH:

MsgBox Err.Number & " " & Err.Description

Exit Sub
EH2:
pEditor.AbortOperation
MsgBox Err.Number & " " & Err.Description
Exit Sub
End Sub

36
Public Function FindFLayerByName(pMap As IMap, sLayerName As String) As IFeatureLayer
'This function will return only feature layers.
'It can find feature layers within groups.

Dim pEnumLayer As IEnumLayer

Dim pCompositeLayer As ICompositeLayer
Dim i As Integer

Set pEnumLayer = pMap.Layers

pEnumLayer.Reset

Dim pLayer As ILayer

Set pLayer = pEnumLayer.Next

Do While Not pLayer Is Nothing

If TypeOf pLayer Is ICompositeLayer Then
Set pCompositeLayer = pLayer
For i = 0 To pCompositeLayer.Count - 1
With pCompositeLayer
If .Layer(i).name = sLayerName Then
If TypeOf .Layer(i) Is IFeatureLayer Then
Set FindFLayerByName = pCompositeLayer.Layer(i)
Exit Function
End If
End If
End With
Next i
ElseIf pLayer.name = sLayerName And TypeOf pLayer Is IFeatureLayer Then
Set FindFLayerByName = pLayer
Exit Function
End If
Set pLayer = pEnumLayer.Next
Loop

End Function

37
Public cnnACC As ADODB.Connection 'Access Connection
Public rst As ADODB.RecordSet
Public adoCat As ADOX.Catalog 'Catalog
Public adoTbl As ADOX.Table 'Table
Public Location As String

Private Sub ComboBox1_Click()

Fillrecordinlistview
End Sub

Private Sub CommandButton1_Click()

'******************************************
'Procedure to add a dbf table to the map
'******************************************
Dim pFact As IWorkspaceFactory
Dim pWorkspace As IWorkspace

38
 Dim pFeatws As IFeatureWorkspace
Dim pTable As ITable
Set pFact = New ShapefileWorkspaceFactory
Dim strOpenPath As String
Dim strOpenTable As String
Dim strTableNamewithPath As String
strTableNamewithPath = TextBox1.Text 'Files path location
Dim strRev As String
strRev = StrReverse(strTableNamewithPath)
strRev = Mid(strRev, 1, InStr(1, strRev, "\") - 1)
strOpenTable = StrReverse(strRev)
strOpenPath = Mid(strTableNamewithPath, 1, InStr(1, strTableNamewithPath, strOpenTable) - 1)
Set pWorkspace = pFact.OpenFromFile(strOpenPath, 0)
Set pFeatws = pWorkspace
Set pTable = pFeatws.OpenTable(strOpenTable)
' add the table
Add_Table_TOC pTable

End Sub

Private Sub Add_Table_TOC(pTable As ITable)

'****************************************************************
'Procedure to add the table to Table of Contents of the Map.
'****************************************************************
Dim pDoc As IMxDocument
Dim pMap As IMap
Dim intCol As Integer
Dim blnExists As Boolean
Set pDoc = ThisDocument
Set pMap = pDoc.FocusMap
' Create a new standalone table and add it
' to the collection of the focus map
Dim pStTab As IStandaloneTable
Set pStTab = New StandaloneTable
Set pStTab.Table = pTable
Dim pStTabColl As IStandaloneTableCollection
Set pStTabColl = pMap
For intCol = 0 To pStTabColl.StandaloneTableCount - 1
If pStTabColl.StandaloneTable(intCol).Name = pStTab.Name Then
blnExists = True
Exit For
End If
Next

For i = 0 To pDoc.ContentsViewCount - 1
If pDoc.ContentsView(i).Name = "Source" Then
Set pDoc.CurrentContentsView = pDoc.ContentsView(i)
Exit For
End If
Next i

If blnExists = False Then

pStTabColl.AddStandaloneTable pStTab
End If
' Refresh the TOC
pDoc.UpdateContents

Set pDoc = Nothing

Set pStTabColl = Nothing
Set pMap = Nothing
Set pStTabColl = Nothing

39
 Set pTable = Nothing
Set pFeatws = Nothing
Set pWorkspace = Nothing
Set pFact = Nothing
End Sub

Private Sub CommandButton2_Click()

dlg.Filter = "dBASE Files (*.dbf)| *.dbf"
dlg.CancelError = True
On Error GoTo FileOpenCancel
dlg.InitDir = CurDir
dlg.ShowOpen
TextBox2.Text = dlg.FileTitle
TextBox1.Text = dlg.FileName
populateListBoxWithTableNames
Exit Sub
FileOpenCancel:
Exit Sub
End Sub
'fill the recordset into listview
Sub FillListViewFromExcel(lv As ListView, rs As ADODB.RecordSet, Optional ImgNum As Long = 0, Optional
MultiplyFirstCol As Boolean = False)
lv.ListItems.Clear

Set cnnACC = New ADODB.Connection

If cnnACC.State = adStateOpen Then

cnnACC.Close
End If

Dim strConn As String

Dim sSQL As String
'Set New connection

Set rs = New ADODB.RecordSet

mFolder = Replace(dlg.FileName, dlg.FileTitle, "", 1)
strConn = "Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=" & mFolder
cnnACC.Open strConn
Dim sTable As String
sTable = TextBox2.Text
sSQL = "Select * from " & sTable
rs.Open sSQL, cnnACC, adOpenDynamic, adLockOptimistic

If Not rs.BOF Then

rs.MoveFirst
Dim a As Long
Dim lst As ListItem
Dim TempVal(100) As String
While Not rs.EOF
If Not IsNull(rs.Fields(0).Value) Then
Set lst = lv.ListItems.Add(, , rs.Fields(0).Value, , ImgNum)
TempVal(0) = rs.Fields(0).Value
Else
Set lst = lv.ListItems.Add(, , "", , ImgNum)
End If
For a = 1 To lv.ColumnHeaders.Count - 1
If Not IsNull(rs.Fields(a).Value) Then
lst.SubItems(a) = rs.Fields(a).Value
End If
Next

40
 rs.MoveNext
Wend
End If

If rs.State = adStateOpen Then

rs.Close
End If
Set rs = Nothing
If cnnACC.State = adStateOpen Then
cnnACC.Close
End If
Set cnnACC = Nothing

End Sub

Public Sub populateListBoxWithTableNames()

ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear

Dim strConn As String

Dim sSQL As String
'Set New connection
Set cnnACC = New ADODB.Connection
Set rst = New ADODB.RecordSet
mFolder = Replace(dlg.FileName, dlg.FileTitle, "", 1)
strConn = "Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=" & mFolder
cnnACC.Open strConn
Dim sTable As String
sTable = TextBox2.Text
sSQL = "Select * from " & sTable
rst.Open sSQL, cnnACC, adOpenDynamic, adLockOptimistic
'Call rst.Open("SELECT * FROM " & sTable, cnnACC, adOpenStatic, adLockReadOnly)
Dim a As Long
For a = 0 To rst.Fields.Count - 1
ListView1.ColumnHeaders.Add , , rst.Fields(a).Name
Next
Call FillListViewFromExcel(ListView1, rst, 0)

End Sub

41
Add Tables from Excel.

'Option Explicit
Dim cnExcel As New ADODB.Connection
Dim rsExcel As New ADODB.RecordSet
Dim ExcelFields As String
'fill the recordset into listview
Sub FillListViewFromExcel(lv As ListView, rs As ADODB.RecordSet, Optional ImgNum As Long = 0, Optional
MultiplyFirstCol As Boolean = False)
lv.ListItems.Clear
If Not rs.BOF Then
rs.MoveFirst
Dim a As Long
Dim lst As ListItem
Dim TempVal(100) As String
While Not rs.EOF
If Not IsNull(rs.Fields(0).Value) Then
Set lst = lv.ListItems.Add(, , rs.Fields(0).Value, , ImgNum)
TempVal(0) = rs.Fields(0).Value
Else
Set lst = lv.ListItems.Add(, , "", , ImgNum)
End If
For a = 1 To lv.ColumnHeaders.Count - 1
If Not IsNull(rs.Fields(a).Value) Then

42
 lst.SubItems(a) = rs.Fields(a).Value
End If
Next
rs.MoveNext
Wend
End If

If rsExcel.State = adStateOpen Then

rsExcel.Close
End If
Set rsExcel = Nothing

If cnExcel.State = adStateOpen Then cnExcel.Close

Set cnExcel = Nothing

End Sub

Private Sub cmdDisp_Click()

ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear
If List3.ListCount = 0 Then
MsgBox "You have not selected any fields to display.", vbExclamation, "No Fields Available"
Exit Sub
End If
Dim x As Long
Dim SelectedFields As String
SelectedFields = "select "
For x = 0 To List3.ListCount - 1
SelectedFields = SelectedFields & "[" & List3.List(x) & "]"
If Not (x = List3.ListCount - 1) Then
SelectedFields = SelectedFields & ", "
End If
Next
SelectedFields = SelectedFields & " from [" & List1.Text & "]" ' where not isnull(Product)"
If rsExcel.State = adStateOpen Then
rsExcel.Close
End If

If cnExcel.State = adStateOpen Then cnExcel.Close

Dim ExcelFile As String

ExcelFile = txtExcel.Text
cnExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExcelFile & ";Persist Security Info=False;
Extended Properties=Excel 8.0;"

rsExcel.Open SelectedFields, cnExcel, adOpenDynamic, adLockOptimistic

Dim a As Long
For a = 0 To rsExcel.Fields.Count - 1
ListView1.ColumnHeaders.Add , , rsExcel.Fields(a).Name
Next
Call FillListViewFromExcel(ListView1, rsExcel, 0)
End Sub
Private Sub getTables(cn As ADODB.Connection, lst As ListBox)

43
 Dim tbl As ADOX.Table
Dim cat As New ADOX.Catalog
Set cat.ActiveConnection = cn

For Each tbl In cat.Tables

If Right(tbl.Name, 1) = "$" Then
lst.AddItem tbl.Name
End If
If Right(tbl.Name, 1) = "'" Then
lst.AddItem Mid(tbl.Name, 2, Len(tbl.Name) - 2)
End If
Next tbl

Set cat = Nothing

If rsExcel.State = adStateOpen Then

rsExcel.Close
End If
Set rsExcel = Nothing
If cnExcel.State = adStateOpen Then cnExcel.Close
Set cnExcel = Nothing

End Sub

Private Sub CommandButton1_Click()

If txtExcel.Text = "" Then
MsgBox "Please put The Excel Files"
Exit Sub
ElseIf List3.ListCount = 0 Then
MsgBox "You have not selected any fields to display.", vbExclamation, "No Fields Available"
Exit Sub
End If

Dim myPath As String

myPath = txtExcel.Text 'excel path location
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source = " & myPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""
Dim pPropset As IPropertySet
Set pPropset = New PropertySet
pPropset.SetProperty "CONNECTSTRING", connStr

'++ connect to database

Dim pWorkspace As IFeatureWorkspace
Dim pWorkspaceFact As IWorkspaceFactory
Set pWorkspaceFact = New OLEDBWorkspaceFactory
Set pWorkspace = pWorkspaceFact.Open(pPropset, 0)
If pWorkspace Is Nothing Then Exit Sub

For i = 0 To List1.ListCount - 1 'select sheet

If List1.Selected(i) = True Then
Dim sheet As String
sheet = (List1.List(i))
End If
Next
Dim pTable As ITable
Set pTable = pWorkspace.OpenTable(sheet)

44
 If pTable Is Nothing Then
MsgBox "The table was not found"
Exit Sub
End If

'create the new table object from the dataset name

'Dim pMxDoc As IMxDocument
'Set pMxDoc = ThisDocument
'Dim pMap As IMap
'Set pMap = pMxDoc.ActiveView.FocusMap
'Dim pTableCollection As ITableCollection
'Set pTableCollection = pMap
'pTableCollection.AddTable pTable
'MsgBox "Table added", vbInformation

'Set pTableCollection = pMxDoc.ActiveView.FocusMap

'add the table to Table of Contents
' pMxDoc.UpdateContents

'++ Create a table collection and assign the new table to it

MsgBox "Table added", vbInformation
Dim pStTab As IStandaloneTable
Dim pStTabColl As IStandaloneTableCollection
Dim pMap As IMap
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.ActiveView.FocusMap
Set pStTab = New StandaloneTable
Set pStTab.Table = pTable
Set pStTabColl = pMap
If Not TypeOf pTable Is IStandaloneTable Then
Set pStTab.Table = pTable
pStTab.Name = Replace$(pStTab.Name, "$", "", 1, -1, vbTextCompare)
End If
pStTabColl.AddStandaloneTable pStTab
pMxDoc.UpdateContents

'++ Create and open a new table window for the table
Dim ptabWin As ITableWindow
Set ptabWin = New TableWindow
Set ptabWin.Table = pTable
ptabWin.ShowAliasNamesInColumnHeadings = True
Set ptabWin.Application = Application
ptabWin.Show True

45
 Set pMxDoc = Nothing
Set pStTabColl = Nothing
Set pStTab = Nothing
Set pMap = Nothing
Set ptabWin = Nothing
Set pWorkspace = Nothing
Set pWorkspaceFact = Nothing
Set pPropset = Nothing

If rsExcel.State = adStateOpen Then

rsExcel.Close
End If
Set rsExcel = Nothing
If cnExcel.State = adStateOpen Then cnExcel.Close
Set cnExcel = Nothing

End Sub

Private Sub CommandButton2_Click()

On Error Resume Next

Dim blnHasSelected As Boolean

Dim i As Long

For i = List2.ListCount - 1 To 0 Step -1 ' counts list entries

If List2.Selected(i) = True Then
blnHasSelected = True
List3.AddItem List2.List(i) ' add to other list
List2.RemoveItem i ' optional remove

End If
Next
If blnHasSelected = False Then
If List2.ListCount = 0 Then
Exit Sub
End If
MsgBox "You have not selected anything.", vbOKOnly + vbInformation, "Select Something"
End If

End Sub

Private Sub CommandButton3_Click()

For i = 0 To List2.ListCount - 1 'select sheet
List3.AddItem (List2.List(i))
Next
List2.Clear
End Sub

46
Private Sub CommandButton4_Click()
On Error Resume Next

Dim blnHasSelected As Boolean

Dim i As Long

For i = List3.ListCount - 1 To 0 Step -1 ' counts list entries

If List3.Selected(i) = True Then ' if selected then
List2.AddItem List3.List(i) ' add to other list
List3.RemoveItem i ' optional remove
blnHasSelected = True
End If
Next
If blnHasSelected = False Then
If List3.ListCount = 0 Then
Exit Sub
End If
MsgBox "You have not selected anything.", vbOKOnly + vbInformation, "Select Something"
End If

End Sub

Private Sub CommandButton5_Click()

For i = 0 To List3.ListCount - 1 'select sheet
List2.AddItem (List3.List(i))
Next
List3.Clear
End Sub

Private Sub dlg_Enter()

End Sub

Private Sub List1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

End Sub

Private Sub List2_Click()

End Sub

Private Sub List2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

' On Error Resume Next
'List3.AddItem List2.Text
'List2.RemoveItem List2.ListIndex

End Sub

Private Sub List3_Click()

End Sub

Private Sub List3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

' On Error Resume Next
' List2.AddItem List3.Text
'List3.RemoveItem List3.ListIndex
End Sub

47
Private Sub lvOpen_Click() 'open excel file
dlg.CancelError = True
On Error GoTo FileOpenCancel
Dim ExcelFile As String
ExcelFile = "xxx"

While Not (LCase(Mid(ExcelFile, Len(ExcelFile) - 2, 3)) = "xls" Or ExcelFile = "Canceled")

If ExcelFile = "Canceled" Then Exit Sub
ExcelFile = "xxx"
ExcelFile = openExcel
Wend

If cnExcel.State = adStateOpen Then cnExcel.Close

txtExcel = ExcelFile
cnExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExcelFile & ";Persist Security Info=False;
Extended Properties=Excel 8.0;"
List1.Clear
List2.Clear
List3.Clear
ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear
Call getTables(cnExcel, List1)
Exit Sub
FileOpenCancel:
Exit Sub
End Sub

'display the worksheet for the excel file

Private Sub List1_Click()
If rsExcel.State = adStateOpen Then
rsExcel.Close
End If

If cnExcel.State = adStateOpen Then cnExcel.Close

Dim ExcelFile As String

ExcelFile = txtExcel.Text
cnExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExcelFile & ";Persist Security Info=False;
Extended Properties=Excel 8.0;"

rsExcel.Open "select * from [" & List1.Text & "]", cnExcel, adOpenDynamic, adLockOptimistic

List2.Clear
List3.Clear
ListView1.ColumnHeaders.Clear
ListView1.ListItems.Clear
Dim a As Long
For a = 0 To rsExcel.Fields.Count - 1
If Not Trim(rsExcel.Fields(a).Name) = "" Then
List2.AddItem rsExcel.Fields(a).Name
End If
Next

If rsExcel.State = adStateOpen Then

rsExcel.Close
End If

48
 Set rsExcel = Nothing
If cnExcel.State = adStateOpen Then cnExcel.Close
Set cnExcel = Nothing

End Sub

Function openExcel() As String 'open excel file

dlg.Filter = "All Microsoft Office Excel Files (*.xls)|*.xls|All files (*.*)|*.*"

dlg.FilterIndex = 1
dlg.DefaultExt = "xls"
dlg.Flags = cdlOFNHideReadOnly
dlg.ShowOpen
openExcel = dlg.FileName
Exit Function
End Function

Add Unique Sequential Value to an Attribute Table

Private Sub UIButtonControl1_Click()

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pLayer As ILayer
Dim pSelItem As IUnknown
Dim pStandaloneTable As IStandaloneTable
Dim pFeatLyr As IFeatureLayer
Dim pFeatClass As IFeatureClass

'++Map Document active

Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap

'++Get Selected Item

Set pSelItem = pMxDoc.SelectedItem

'++Is something selected in TOC?

If pMxDoc.SelectedItem Is Nothing Then
MsgBox "Must first select a Shapefile or Standalone Table from the TOC."
Exit Sub
End If

'++Make sure selected something is a StandaloneTable or Shapefile

If TypeOf pSelItem Is IStandaloneTable Then
Set pStandaloneTable = pSelItem
ElseIf TypeOf pSelItem Is IFeatureLayer Then
Set pLayer = pSelItem
Set pFeatLyr = pLayer
Set pFeatClass = pFeatLyr.FeatureClass
If pFeatClass.ShapeType = esriGeometryPoint Then
ElseIf pFeatClass.ShapeType = esriGeometryLine Then
ElseIf pFeatClass.ShapeType = esriGeometryPolyline Then
ElseIf pFeatClass.ShapeType = esriGeometryPolygon Then
Else
MsgBox "Selected feature layer must be a point, line, polyline or polygon shapefile!"
Exit Sub
End If

49
 Else
MsgBox "Must first select a Standalone Table or Shapefile."
Exit Sub
End If

frmAddUniqueVal2Table.Show

End Sub

Private Function UIButtonControl1_Enabled() As Boolean

Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As ILayer
Dim bolEnabled As Boolean
Dim pSelItem As IUnknown

Set pMxDoc = ThisDocument

Set pMap = pMxDoc.FocusMap
bolEnabled = True
Set pSelItem = pMxDoc.SelectedItem

'++Disable if the selected item is nothing, if it is not

'++ a layer or table, or if multiple items are selected
If pSelItem Is Nothing Then
bolEnabled = False
ElseIf Not (TypeOf pSelItem Is ILayer Or TypeOf pSelItem Is IStandaloneTable) Then
bolEnabled = False
End If

UIButtonControl1_Enabled = bolEnabled
End Function

Private Function UIButtonControl1_ToolTip() As String

UIButtonControl1_ToolTip = "Add Unique Value to Table"
End Function
ADD TABLES FROM ACCESS AND EXPORT TO DBF

50
Public cnnACC As ADODB.Connection 'Access Connection
Public rst As ADODB.RecordSet
Public adoCat As ADOX.Catalog 'Catalog
Public adoTbl As ADOX.Table 'Table

Private Sub ComboBox1_Click()

Fillrecordinlistview
End Sub

Private Sub CommandButton1_Click()

'C:\Documents and Settings\fauzul\Desktop\Populate Access\Northwind.mdb

Dim pPropset As IPropertySet

Set pPropset = New PropertySet
Dim Path As String
Path = CurDir

51
 pPropset.SetProperty "CONNECTSTRING", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Path &
"\Northwind.mdb;"
'++ Create a new workspacefactory/workspace
Dim pWorkspaceFact As IWorkspaceFactory
Set pWorkspaceFact = New OLEDBWorkspaceFactory

Dim pWorkspace As IWorkspace

Set pWorkspace = pWorkspaceFact.Open(pPropset, 0)
If pWorkspace Is Nothing Then Exit Sub
Dim pFeatWorkspace As IFeatureWorkspace
Set pFeatWorkspace = pWorkspace

'++ Get the datasets (names) in the workspace

Dim pEnumDataset As IEnumDatasetName
Set pEnumDataset = pWorkspace.DatasetNames(esriDTTable)

'++ Create a new dataset object for the table you want to load
Dim pDataset As IDatasetName
Set pDataset = pEnumDataset.Next

Dim TABLE_NAME As String

TABLE_NAME = ComboBox1.Text
Do Until pDataset Is Nothing
If pDataset.Name = TABLE_NAME Then
Exit Do
End If
Set pDataset = pEnumDataset.Next
Loop

'++ Create and open the new table object from the dataset name
Dim pTable As ITable
Set pTable = pFeatWorkspace.OpenTable(pDataset.Name)
If pTable Is Nothing Then
MsgBox "The table was not found"
Exit Sub
End If

'++ Create a table collection and assign the new table to it

MsgBox "Table added", vbInformation
Dim pStTab As IStandaloneTable
Dim pStTabColl As IStandaloneTableCollection
Dim pMap As IMap
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.ActiveView.FocusMap
Set pStTab = New StandaloneTable
Set pStTab.Table = pTable
Set pStTabColl = pMap
If Not TypeOf pTable Is IStandaloneTable Then
Set pStTab.Table = pTable
pStTab.Name = Replace$(pStTab.Name, "$", "", 1, -1, vbTextCompare)

End If
pStTabColl.AddStandaloneTable pStTab

For i = 0 To pMxDoc.ContentsViewCount - 1
If pMxDoc.ContentsView(i).Name = "Source" Then
Set pMxDoc.CurrentContentsView = pMxDoc.ContentsView(i)

52
 Exit For
End If
Next i

pMxDoc.UpdateContents

'++ Create and open a new table window for the table
Dim ptabWin As ITableWindow
Set ptabWin = New TableWindow
Set ptabWin.Table = pTable
ptabWin.ShowAliasNamesInColumnHeadings = True
Set ptabWin.Application = Application
ptabWin.Show True
Set pMxDoc = Nothing
Set pStTabColl = Nothing
Set pStTab = Nothing
Set pMap = Nothing

Set pWorkspace = Nothing

Set pWorkspaceFact = Nothing
Set pPropset = Nothing
Unload Me
If MsgBox("Do you want export this tables to dbf files?", vbOKCancel, "Export") = vbOK Then
Unload Me
ptabWin.Show False
Set ptabWin = Nothing
UserForm2.Show
Else
Exit Sub
End If

End Sub

Private Sub CommandButton2_Click()

End Sub

Private Sub UserForm_Initialize()

populateListBoxWithTableNames
End Sub
'fill the recordset into listview
Sub FillListViewFromExcel(lv As ListView, rs As ADODB.RecordSet, Optional ImgNum As Long = 0, Optional
MultiplyFirstCol As Boolean = False)
lv.ListItems.Clear
If Not rs.BOF Then
rs.MoveFirst
Dim a As Long
Dim lst As ListItem
Dim TempVal(100) As String
While Not rs.EOF
If Not IsNull(rs.Fields(0).Value) Then
Set lst = lv.ListItems.Add(, , rs.Fields(0).Value, , ImgNum)
TempVal(0) = rs.Fields(0).Value
Else
Set lst = lv.ListItems.Add(, , "", , ImgNum)
End If
For a = 1 To lv.ColumnHeaders.Count - 1
If Not IsNull(rs.Fields(a).Value) Then
lst.SubItems(a) = rs.Fields(a).Value
End If
Next
rs.MoveNext

53
 Wend
End If
End Sub

Public Sub Fillrecordinlistview()

ListView1.ColumnHeaders.Clear
Set rst = New ADODB.RecordSet
'Set New connection
Set cnnACC = New ADODB.Connection
If rst.State = adStateOpen Then
rst.Close
End If

Dim strDB, strConn As String

strDB = CurDir & "\Northwind.mdb"
'String Connection with Database path String
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB & ";Persist Security Info=False"
' Open the connection
cnnACC.Open strConn

Dim sSQL As String

vsRecordSource = ComboBox1.Text
sSQL = "SELECT * FROM [" & vsRecordSource & " ]"
rst.Open sSQL, cnnACC, adOpenDynamic, adLockOptimistic

Dim a As Long
For a = 0 To rst.Fields.Count - 1
ListView1.ColumnHeaders.Add , , rst.Fields(a).Name
Next
Call FillListViewFromExcel(ListView1, rst, 0)

End Sub
Public Sub populateListBoxWithTableNames()

Dim strDB, strConn As String

'Set New connection

Set cnnACC = New ADODB.Connection

'String Database Path

strDB = CurDir & "\Northwind.mdb"

strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB & ";Persist Security Info=False"

' Open the connection

cnnACC.Open strConn

'Set new ADOX CAtalog

Set adoCat = New ADOX.Catalog
'Allow active connection to the opened connection to enable use of the catalog
adoCat.ActiveConnection = cnnACC

'Clear the Userform list box to refresh tables

ComboBox1.Clear

For Each adoTbl In adoCat.Tables

54
 If Left(adoTbl.Name, 4) <> "MSys" Then
ComboBox1.AddItem adoTbl.Name
If ComboBox1.ListCount > 1 Then ComboBox1.ListIndex = 0
End If

Next adoTbl
'Clear Memory
Set cnnACC = Nothing: Set adoCat = Nothing

End Sub

Private Sub CommandButton1_Click()

Dim pDoc As IMxDocument

Dim pMap As IStandaloneTableCollection
Dim pTable As ITable
Set pDoc = ThisDocument
Set pMap = pDoc.FocusMap

Dim pTableCollection As IStandaloneTableCollection

Dim pStAloneTab As IStandaloneTable
Set pTableCollection = pMap
Dim i As Integer
For i = 0 To pTableCollection.StandaloneTableCount - 1
If UCase(pTableCollection.StandaloneTable(i).Name) = UCase(ComboBox1.Text) Then
Set pStAloneTab = pTableCollection.StandaloneTable(i)
Dim pDataset As IDataset
Set pDataset = pStAloneTab.Table

Exit For
End If
Next

If pDataset Is Nothing Then

MsgBox "The table was not found"
Exit Sub
End If

Dim pDSName As IDatasetName

Set pDSName = pDataset.FullName
' case we are creating a dbf file in c:\temp
Dim pWkSpFactory As IWorkspaceFactory
Dim pWkSp As IWorkspace
Dim pWkSpDS As IDataset
Dim pWkSpName As IWorkspaceName
Dim pOutDSName As IDatasetName

55
 Dim Path As String
Path = CurDir

Set pWkSpFactory = New ShapefileWorkspaceFactory

Set pWkSp = pWkSpFactory.OpenFromFile(Path, 0)
Set pWkSpDS = pWkSp
Set pWkSpName = pWkSpDS.FullName
Set pOutDSName = New TableName
pOutDSName.Name = "ExpSample1"
Set pOutDSName.WorkspaceName = pWkSpName

'Check the tables collection to see if the table exists in the map document
Dim pStandAloneTableCollection As IStandaloneTableCollection
Set pStandAloneTableCollection = pMap

Dim j As Integer
Dim pStandAloneTable As IStandaloneTable
For j = 0 To pStandAloneTableCollection.StandaloneTableCount - 1
If TypeOf pStandAloneTableCollection.StandaloneTable(j) Is IStandaloneTable Then
If pStandAloneTableCollection.StandaloneTable(j).Name = sNewTableName Then
Set pStandAloneTable = pStandAloneTableCollection.StandaloneTable(j)
pStandAloneTableCollection.RemoveStandaloneTable pStandAloneTable
End If
End If
Next j 'next table
'Test to see if temp table already exists: if yes, delete it.
Dim pED As IEnumDataset
Set pED = pWkSp.Datasets(esriDTTable)

Dim pDS As IDataset

Set pDS = pED.Next

Do Until pDS Is Nothing

Debug.Print pDS.Name
If pDS.Name = "ExpSample1" Then
pDS.Delete
Exit Do
End If
Set pDS = pED.Next
Loop

'Check to see if the dbf file already exists

If Dir$(Path & "\" & "ExpSample1" & ".dbf") <> "" Then
Kill Path & "\" & "ExpSample1" & ".dbf"
End If

Dim pExpOp As IExportOperation

Set pExpOp = New ExportOperation
pExpOp.ExportTable pDSName, Nothing, Nothing, pOutDSName, Application.hWnd

'******************************************
'Procedure to add a dbf table to the map
'******************************************
Dim pFact As IWorkspaceFactory
Dim pWorkspace As IWorkspace
Dim pFeatws As IFeatureWorkspace
' Dim pTable As ITable
Set pFact = New ShapefileWorkspaceFactory
Dim strOpenPath As String
Dim strOpenTable As String
Dim strRev As String

56
 Set pWorkspace = pFact.OpenFromFile(Path, 0)
Set pFeatws = pWorkspace
Set pTable = pFeatws.OpenTable("ExpSample1")

Add_Table_TOC pTable

Exit Sub
EH:

MsgBox Err.Number & " " & Err.Description

End Sub
Private Sub Add_Table_TOC(pTable As ITable)
'****************************************************************
'Procedure to add the table to Table of Contents of the Map.
'****************************************************************
Dim pDoc As IMxDocument
Dim pMap As IMap
Dim intCol As Integer
Dim blnExists As Boolean
Set pDoc = ThisDocument
Set pMap = pDoc.FocusMap
' Create a new standalone table and add it
' to the collection of the focus map
Dim pStTab As IStandaloneTable
Set pStTab = New StandaloneTable
Set pStTab.Table = pTable
Dim pStTabColl As IStandaloneTableCollection
Set pStTabColl = pMap
For intCol = 0 To pStTabColl.StandaloneTableCount - 1
If pStTabColl.StandaloneTable(intCol).Name = pStTab.Name Then
blnExists = True
Exit For
End If
Next
If blnExists = False Then
' add the table
MsgBox "Successfuly Export to Dbf. Now Added on map", vbInformation
Unload Me
pStTabColl.AddStandaloneTable pStTab
End If
' Refresh the TOC
pDoc.UpdateContents

Set pDoc = Nothing

Set pMap = Nothing
Set pStTab = Nothing
Set pStTabColl = Nothing
Set pNewTable = Nothing
Set pName = Nothing
Set pDS = Nothing
Set pExpOp = Nothing

Set pDataset = Nothing

Set pDSName = Nothing
Set pDataset = Nothing
Set pWkSpFactory = Nothing
Set pWkSp = Nothing
Set pWkSpDS = Nothing
Set pWkSpName = Nothing
Set pOutDSName = Nothing
Set pDSName = Nothing

57
 Set pActiveView = Nothing
Set pSelItem = Nothing
Set pStAloneTab = Nothing

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()

'Loop through the standalone tables in a map
Dim pDoc As IMxDocument
Dim pMap As IMap
Dim pStandAloneTableCollection As IStandaloneTableCollection
Dim pStandAloneTable As IStandaloneTable
Dim pTable As ITable

'Get the current map from the document

Set pDoc = ThisDocument
Set pMap = pDoc.FocusMap

'Get the table collection from the map

ComboBox1.Clear
Set pStandAloneTableCollection = pMap
For i = 0 To pStandAloneTableCollection.StandaloneTableCount - 1
Set pStandAloneTable = pStandAloneTableCollection.StandaloneTable(i)
ComboBox1.AddItem pStandAloneTable.Name
Next
If ComboBox1.ListCount > 0 Then ComboBox1.ListIndex = 0
End Sub
'Private Sub CalcCentroid_Click()
' This script will add a new field for the X and Y coordinate of a polygon feature layer
' and insert the centroid X and Y coordinates
' The script was written by Andrew Bradley on 16th January 2007 in ArcGIS 9.0
' Please feel free to use this script at your discretion
' Enjoy GIS, Andy Bradley! =), Hampshire England, [email protected]

'AB - Check the user meant to run the script and that the selected file is the one they want to work with
Answer = MsgBox("Do you want to work with the selected layer?", vbYesNo, "Are you sure?")
If Answer = vbNo Then
Exit Sub
End If

Dim pMxDoc As IMxDocument

Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
Dim pFeatureLayer As IFeatureLayer

'AB - Ensure the layer is a feature layer

If pMxDoc.SelectedLayer Is Nothing Then
MsgBox "No Layer is Selected, you must select a layer", vbCritical, "Select a layer"
Exit Sub
ElseIf Not TypeOf pMxDoc.SelectedLayer Is IFeatureLayer Then
MsgBox "The Selected layer is not a feature layer", vbCritical, "Feature layer"
Exit Sub
End If

Set pFeatureLayer = pMxDoc.SelectedLayer

58
Dim pFeatureClass As IFeatureClass
Set pFeatureClass = pFeatureLayer.FeatureClass

'AB - Ensure the layer is of a polygon type

If pFeatureClass.ShapeType <> esriGeometryPolygon Then
MsgBox "The Feature Layer you have selected must be a polygon layer", vbCritical, "Error - not Polygon"
Exit Sub
End If

Dim pFieldEdit As IFieldEdit

Dim strXCoord As String
Dim strYCoord As String
'AB - Set field names for the X and Y coordinates
strXCoord = "X_COORD"
strYCoord = "Y_COORD"

'AB - If the field for the X coordinate does not exist then make one
If pFeatureClass.FindField(strXCoord) = -1 Then
Set pFieldEdit = New Field
pFieldEdit.Type = esriFieldTypeDouble
pFieldEdit.Name = strXCoord
pFeatureClass.AddField pFieldEdit
End If
'AB - If the field for the Y coordinate does not exist then make one
If pFeatureClass.FindField(strYCoord) = -1 Then
Set pFieldEdit = New Field
pFieldEdit.Type = esriFieldTypeDouble
pFieldEdit.Name = strYCoord
pFeatureClass.AddField pFieldEdit
End If

'AB - Set a feature cursor to look at all the features in the layer
Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureClass.Search(Nothing, False)

Dim pFeature As IFeature

Dim pArea As IArea
Dim x As Double
Dim y As Double
'Dim pfield As IField
'Dim pfields As IFields
Dim pFieldNumberX As Long
Dim pFieldNumberY As Long
Dim i As Integer
Dim intCount As Long

'AB - Find the field numbers for the 2 coordinate fields

pFieldNumberX = pFeatureClass.FindField(strXCoord)
pFieldNumberY = pFeatureClass.FindField(strYCoord)
intCount = pFeatureClass.FeatureCount(Nothing)

'AB - Warn user they are about to run process and inform user of feature count
Answer = MsgBox("There are " & intCount & " features" & vbNewLine _
& "Press Yes to Continue or No to Cancel", vbYesNo, "Run Script?")
If Answer = vbNo Then
Exit Sub
End If

'AB - Find centroids and update features attributes

For i = 0 To intCount - 1
Set pFeature = pFeatureCursor.NextFeature
Set pArea = pFeature.Shape

59
 x = pArea.Centroid.x
pFeature.Value(pFieldNumberX) = x
y = pArea.Centroid.y
pFeature.Value(pFieldNumberY) = y
pFeature.Store
Next
'AB - Tell user script has finished
MsgBox "Job Finished!", vbInformation, "Finished"
'End Sub

Add X and Y coordinates of features to Attribute Table

Public Sub addxy()

Dim thedocument As IMxDocument

Set thedocument = ThisDocument
Dim thelay As ILayer
Set thelay = thedocument.SelectedLayer

If thelay Is Nothing Then

MsgBox "Select a single point layer or point shapefile"
Exit Sub
End If

Dim thelayer As IFeatureLayer

Set thelayer = thelay
Dim theFC As IFeatureClass
Set theFC = thelayer.FeatureClass

If TypeOf theFC Is ICoverageFeatureClass Or theFC.ShapeType <> esriGeometryPoint Then

MsgBox "Select a single point layer or point shapefile"
Exit Sub
End If

Dim xfield As IFieldEdit

Dim yfield As IFieldEdit
Set xfield = New Field
Set yfield = New Field

With xfield
.Type = 3
.name = "XFIELD"
End With

With yfield
.Type = 3
.name = "YFIELD"
End With

theFC.AddField xfield
theFC.AddField yfield

'Dim thequeryfilter As IQueryFilter

'Set thequeryfilter = New QueryFilter
'thequeryfilter.WhereClause = ""

Dim thefeaturecursor As IFeatureCursor

Set thefeaturecursor = theFC.Search(Nothing, False)

Dim thefeature As IFeature

Set thefeature = thefeaturecursor.NextFeature

60
While Not thefeature Is Nothing

Dim theenvelope As IEnvelope

Set theenvelope = thefeature.Extent

Dim xcoor As Double

xcoor = theenvelope.XMax
Dim ycoor As Double
ycoor = theenvelope.YMax

Dim indexX As Long

indexX = theFC.FindField("XFIELD")

Dim indexY As Long

indexY = theFC.FindField("YFIELD")

thefeature.Value(indexX) = xcoor
'thefeature.Store
thefeature.Value(indexY) = ycoor
thefeature.Store

Set thefeature = thefeaturecursor.NextFeature

Wend

End Sub
Sub AddXY2Att()
'The program adds x and y coordinates to the selected polygon or
point feature layer.
'If the field XCOORD or YCOORD does not exist in the layer, the
program will add the
'field to the layer attribute table.
'The coordinates that are added to the attribute table is in same
coordinate and projection
'as the one sets in the Data Frame Properties. In that case, user
can control what coordinate
'and projection of the x and y will be in the attribute table.
'Program by XY at ISIS Center, California State University, Fresno

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pUnknown As IUnknown
Dim pFeatLayer As IFeatureLayer
Dim pFeatClass As IFeatureClass

Set pMxDoc = ThisDocument

Set pMap = pMxDoc.FocusMap
Set pUnknown = pMxDoc.SelectedLayer

If pUnknown Is Nothing Then

MsgBox "No layer selected." & vbCrLf _
& "Please select a point or polygon feature layer from
the TOC."
Exit Sub
End If

'get spatial reference information of the map frame

Dim pSpRef As ISpatialReference
Set pSpRef = pMap.SpatialReference

61
 If TypeOf pUnknown Is IFeatureLayer Then
Set pFeatLayer = pUnknown
Set pFeatClass = pFeatLayer.FeatureClass
If ((pFeatClass.ShapeType <> 1) And (pFeatClass.ShapeType <>
4)) Then
MsgBox "Point or polygon feature layer only, please."
Exit Sub
End If

'get an exclusive schema lock on the dataset

Dim pSchemalock As ISchemaLock
Set pSchemalock = pFeatClass
pSchemalock.ChangeSchemaLock esriExclusiveSchemaLock

'check if fields named XCOORD and YCOORD exist

Dim pFieldEdit As IFieldEdit
If pFeatClass.FindField("XCOORD") = -1 Then
Set pFieldEdit = New esriCore.Field
With pFieldEdit
.Type = esriFieldTypeDouble
.Name = "XCOORD"
End With
pFeatClass.AddField pFieldEdit
End If
If pFeatClass.FindField("YCOORD") = -1 Then
Set pFieldEdit = New esriCore.Field
With pFieldEdit
.Type = esriFieldTypeDouble
.Name = "YCOORD"
End With
pFeatClass.AddField pFieldEdit
End If

'edit session needed?

Dim pDataset As IDataset
Dim pWSEdit As IWorkspaceEdit
Dim bBypassEditSession As Boolean
Set pDataset = pFeatClass
Set pWSEdit = pDataset.Workspace
bBypassEditSession = CanEditWOEditSession(pFeatClass)
If Not bBypassEditSession Then
pWSEdit.StartEditing False
pWSEdit.StartEditOperation
End If

'can bypass STORE?

Dim pObjectClassInfo2 As IObjectClassInfo2
Dim pQueryFilter As IQueryFilter
Set pObjectClassInfo2 = pFeatClass
If pObjectClassInfo2.CanBypassStoreMethod Then
'MsgBox "Yes, can bypass STORE method."
Set pQueryFilter = New QueryFilter
pQueryFilter.SubFields = pFeatClass.ShapeFieldName & "," &
"XCOORD, YCOORD"
End If

62
 Dim pFeatCursor As IFeatureCursor
Dim pFeature As IFeature
Dim pPoint As IPoint
Dim pFeatGeo As IGeometry
Dim pFeatSR As ISpatialReference
Dim pShape As IGeometry

Set pPoint = New Point

Set pFeatCursor = pFeatClass.Update(pQueryFilter, False)
Set pFeature = pFeatCursor.NextFeature

'get field indeces of XCOORD and YCOORD

Dim lXField As Long
Dim lYField As Long
lXField = pFeatClass.FindField("XCOORD")
lYField = pFeatClass.FindField("YCOORD")

'get spatial reference of the feature class

Set pFeatGeo = pFeature.Shape
Set pFeatSR = pFeatGeo.SpatialReference

'show progress
Dim pSBar As IStatusBar
Dim pProg As IStepProgressor
Dim lNumFeat As Long
Dim dInterval As Double
Dim i
Set pSBar = StatusBar
Set pProg = pSBar.ProgressBar
lNumFeat = pFeatClass.FeatureCount(Nothing)
dInterval = lNumFeat / 100
pProg.MinRange = 1
pProg.MaxRange = lNumFeat
pProg.StepValue = dInterval
i = 1

While Not pFeature Is Nothing

pProg.Position = i
pProg.Message = "Processing record " & Str(i)
pProg.Step
pProg.Show

Dim dblX As Double

Dim dblY As Double

Select Case pFeatClass.ShapeType

Case 1
Set pPoint = pFeature.Shape
Case 4
Dim pArea As IArea
Set pArea = pFeature.Shape
'substitute LabelPoint to Centroid for true
centroid of a polygon
pPoint.PutCoords pArea.LabelPoint.X,
pArea.LabelPoint.Y
Case Else
End Select

63
 Set pShape = pPoint
Set pShape.SpatialReference = pFeatSR
If pFeatSR.Name <> pSpRef.Name Then
'project the feature layer coordinate system to the map
frame corrdinate system
pShape.Project pSpRef
End If

dblX = pPoint.X
dblY = pPoint.Y

pFeature.Value(lXField) = dblX
pFeature.Value(lYField) = dblY
pFeatCursor.UpdateFeature pFeature

Set pFeature = pFeatCursor.NextFeature

i = i + 1
Wend
Set pFeatCursor = Nothing
If pWSEdit.IsBeingEdited Then
pWSEdit.StopEditOperation
pWSEdit.StopEditing True
End If
MsgBox "Job done!"
pProg.Hide
Else
MsgBox "Selected layer is not a feature layer."
Exit Sub
End If
End Sub

Private Function CanEditWOEditSession(pTable As ITable) As Boolean

Dim pVersionedObject As IVersionedObject
Dim pObjClassInfo2 As IObjectClassInfo2
Dim bolVersioned As Boolean
Dim bolEditable As Boolean

If Not TypeOf pTable Is IVersionedObject Then

bolVersioned = False
Else
bolVersioned = True
End If

Set pObjClassInfo2 = pTable

bolEditable = pObjClassInfo2.CanBypassEditSession
If bolEditable And Not bolVersioned Then
CanEditWOEditSession = True
Else
CanEditWOEditSession = False
End If
End Function
Public Sub AddShapePointXY()
'
' This function takes the currently selected Point shape file, and add
' two fields of Xcoord and Ycoord that give the coordante of point.
'
' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan

64
' [email protected]
' Jan 31, 2002
Dim pMxdoc As IMxDocument
Set pMxdoc = ThisDocument

If Not TypeOf pMxdoc.ActiveView Is IMap Then

MsgBox "A Map must be active!"
Exit Sub
End If

Dim pFLayer As IFeatureLayer

Dim pFClass As IFeatureClass

Set pFLayer = pMxdoc.SelectedLayer

If pFLayer Is Nothing Then
MsgBox "Select a single point shapefile!"
Exit Sub
End If
Set pFClass = pFLayer.FeatureClass

If pFClass.ShapeType <> esriGeometryPoint Then

MsgBox "Select a single point shapefile!"
Exit Sub
End If

Dim indexX As Long

indexX = pFClass.FindField("Xcoord")
If indexX < 0 Then 'If there is no the field of Xcoord, indexxX=-1
Dim pFieldx As IFieldEdit
Set pFieldx = New Field

With pFieldx
.Type = esriFieldTypeDouble
.Name = "Xcoord"
End With
pFClass.AddField pFieldx
End If

Dim indexY As Long

indexY = pFClass.FindField("Ycoord")
If indexY < 0 Then 'If there is no the field of Ycoord, indexxX=-1
Dim pFieldy As IFieldEdit
Set pFieldy = New Field

With pFieldy
.Type = esriFieldTypeDouble
.Name = "Ycoord"
End With
pFClass.AddField pFieldy
End If
indexX = pFClass.FindField("Xcoord")
indexY = pFClass.FindField("Ycoord")

Dim pFCursor As IFeatureCursor

Set pFCursor = pFClass.Search(Nothing, False)

Dim pFeature As IFeature

Set pFeature = pFCursor.NextFeature

Dim pShape As IGeometry

Dim pPoint As IPoint

65
 Dim xcoor As Double
Dim ycoor As Double

While Not pFeature Is Nothing

Set pShape = pFeature.Shape

Set pPoint = pShape

xcoor = pPoint.X
ycoor = pPoint.Y

pFeature.Value(indexX) = xcoor
pFeature.Value(indexY) = ycoor
pFeature.Store

Set pFeature = pFCursor.NextFeature

Wend

End Sub
Public Sub SelectableTab()

'Add the Selectable Layers tab to the TOC. Copy this code to the
Normal.mxt -> ThisDocument
'to make it available by default.

Dim pMxDoc As IMxDocument

Set pMxDoc = ThisDocument
Dim i As Integer
For i = 0 To pMxDoc.ContentsViewCount - 1
If pMxDoc.ContentsView(i).Name = "Selection" Then
pMxDoc.ContentsView(i).Visible = True
pMxDoc.UpdateContents
Application.RefreshWindow
End If
Next i

'Don't prompt to save the MXD if this is the only change

Dim pDocDirty As IDocumentDirty2
Set pDocDirty = ThisDocument
pDocDirty.SetClean

End Sub

Private Function MxDocument_NewDocument() As Boolean

'Add the tab when creating a new MXD

Call SelectableTab

End Function

Private Function MxDocument_OpenDocument() As Boolean

'Add the tab when opening an existing MXD

Call SelectableTab

End Function

66
Attribute VB_Name = "anno2polyline"
Public Declare Function GetEnvironmentVariable Lib "kernel32" Alias _
"GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, _
ByVal nSize As Long) As Long

Public Sub ConvertAnno2Line(pMap As IMap, pFl As IFeatureLayer)

On Error GoTo myEH

' This macro convert a ArcInfo annotation coverage

' to ESRI Shapefile with the same fields that annotation coverage
' the Shapefile Geometry is Polyline, that store the orientation
' of texts
' The Selected Layer in the Table of contents should be the annotation coverage

Dim pNewFL As IFeatureLayer

Dim pActiveView As IActiveView
Dim pFC As IFeatureClass
Dim pfields As IFields
Dim pField As IField
Dim pClone As IClone
Dim pnewFC As IFeatureClass
Dim pFW As IFeatureWorkspace
Dim pWSf As IWorkspaceFactory
Dim pFCursor As IFeatureCursor
Dim pFeature As IFeature
Dim pnewFeature As IFeature

Dim pProDiaFac As IProgressDialogFactory

Dim pProgDialog As IProgressDialog2
Dim pStpPro As IStepProgressor
Dim pTrackCancel As ITrackCancel

Set pFC = pFl.FeatureClass

Set pfields = pFC.Fields

Set pClone = pfields
Set pfields = pClone.Clone

Dim sPath As String

Dim lSize As Long
Dim sNameFC As String

sPath = String(255, 0)
lSize = GetEnvironmentVariable("Temp", sPath, Len(sPath))
If lSize = 0 Then
sPath = "C:"
End If

sPath = Left(sPath, lSize)

sname = InputBox("input the name of feature class to create")

If Len(Trim(sname)) = 0 Then Exit Sub

Set pWSf = New ShapefileWorkspaceFactory

Set pFW = pWSf.OpenFromFile(sPath, 0)
Set pnewFC = pFW.CreateFeatureClass(Trim(sname), pfields, Nothing, _
Nothing, esriFTSimple, "Shape", "")
Set pFCursor = pFC.Search(Nothing, False)
Set pFeature = pFCursor.NextFeature

67
Dim lFields As Long
Dim i As Long, k As Long, t As Long
Dim pPolyline As IPolyline
Dim pTopoOp As ITopologicalOperator
Dim lNumFeat As Long
Dim pNewFCursor As IFeatureCursor
Dim pNewFBuffer As IFeatureBuffer

lFields = pfields.FieldCount
lNumFeat = pFC.FeatureCount(Nothing)
Set pProDiaFac = New ProgressDialogFactory
Set pStpPro = pProDiaFac.Create(pTrackCancel, 0)
With pStpPro
.MinRange = 1
.MaxRange = lNumFeat
.StepValue = 1
End With
Set pProgDialog = pStpPro

With pProgDialog
.Animation = esriProgressGlobe
.Title = "Annotation to polyline"

End With

k=1
t=1
Set pNewFCursor = pnewFC.Insert(True)

Do While Not pFeature Is Nothing

pStpPro.Message = "Converting feature " & k & " of " & lNumFeat
pStpPro.Step
Set pNewFBuffer = pnewFC.CreateFeatureBuffer

'Set pnewFeature = pnewFC.CreateFeature

For i = 0 To lFields - 1
Set pField = pfields.Field(i)
If Not ((pField.Type = esriFieldTypeGeometry) Or (pField.Type = esriFieldTypeOID)) Then
pNewFBuffer.Value(i) = pFeature.Value(i)
ElseIf pField.Type = esriFieldTypeGeometry Then
Set pPolyline = pFeature.ShapeCopy
Set pNewFBuffer.Shape = pPolyline
End If
Next i

'pnewFeature.Store
pNewFCursor.InsertFeature pNewFBuffer

Set pFeature = pFCursor.NextFeature

k=k+1
t=t+1
If t = 1000 Then
pNewFCursor.Flush
t=1
End If
Loop
pNewFCursor.Flush
pProgDialog.HideDialog

Set pNewFL = New FeatureLayer

Set pNewFL.FeatureClass = pnewFC

68
 pNewFL.Name = pnewFC.AliasName
pMap.AddLayer pNewFL

Set pActiveView = pMap

pActiveView.Refresh

MsgBox "Finish"
Exit Sub

myEH:

If Err.Number = -2147220653 Then

MsgBox "the layer exist, delete the layer o change the shapefile name"
Exit Sub
End If

MsgBox Err.Number & " " & Err.Description

End Sub

This code brings in label symbology for label classes from a .lyr file and applies it to a selected Feature Class,
Shapefile or Coverage in ArcMap.

To use the code:

1.Add a new UiButtonControl to ArcMap (see Create a new UIButtonControl.doc)

2. After you drag the button to the toolbar, right-click it and select View Source then paste the code in the attached text
filed called Buttoncode.txt into the UiButtonControl1_Click event
(Between the lines:
Private Sub UIButtonControl1_Click()
and
End Sub )

3.Close the Visual Basic Editor

4. Add a Feature Class, Shapefile or Coverage to ArcMap.

5. Select (click) the layer (Feature Class, Shapefile or Coverage) you want to create labels for in the Table of Contents

6. Click the UiButtonControl

7. You will be prompted to select the .lyr file from which you would like to import label symbology.

Note: This code brings in only the LABEL symbology.

private sub lable_display()

Dim pGxFile As IGxFile

Dim pGFLayer As IGeoFeatureLayer
Dim pGxLayer As IGxLayer
Dim pGxDialog As IGxDialog
Dim pGxObjFilter As IGxObjectFilter
Dim pEnumGxObj As IEnumGxObject
Dim pAnnoLayerPropsColl As IAnnotateLayerPropertiesCollection
Dim pGxObj As IGxObject
Dim pMxDoc As IMxDocument

Set pMxDoc = ThisDocument

If pMxDoc.SelectedLayer Is Nothing Then
MsgBox "Please select feature class to label with .lyr file label classes"
Exit Sub

69
 End If
Set pGxDialog = New GxDialog
Set pGxObjFilter = New GxFilterLayers
Set pGxDialog.ObjectFilter = pGxObjFilter
pGxDialog.Title = "Select Layer(.lyr) file"
pGxDialog.ButtonCaption = "Apply Labels"

If pGxDialog.DoModalOpen(0, pEnumGxObj) Then

Set pGxObj = pEnumGxObj.Next
Set pGxLayer = pGxObj
Else
Exit Sub
End If
Set pGFLayer = pGxLayer.Layer
Set pAnnoLayerPropsColl = pGFLayer.AnnotationProperties

'Apply label classes to selected layer in arcmap

Set pGFLayer = pMxDoc.SelectedLayer
pGFLayer.AnnotationProperties = pAnnoLayerPropsColl
pGFLayer.DisplayAnnotation = True
pMxDoc.ActiveView.Refresh
pMxDoc.CurrentContentsView.Refresh pGFLayer
End sub
'**
' Write available printer codes and printer names to a text file
'
' @instructions Define your current printer within ArcMap first (File >
Page and Print Setup...)
'
' Copy this code into the ThisDocument window within
ArcMap's VBA window
' Tools > Macros > Visual Basic Editor
' Project > ArcMap Objects > ThisDocument
'
' Once the code has been pasted into the window, press
the run button
'
' You can optionally assign this routine to a customised
UIButton control
'
'*

'**
' @global sFileName Log file to create
'*
Private Const sFileName As String = "C:\Temp\PrinterSettings.log"

'**
' Method to Log printer settings to text file
'
'
'*
Public Sub LogPrinterSettings()

Dim pMxApp As IMxApplication

Dim pPrinter As IPrinter
Dim fso As Object, f As Object
Dim pEnumTypeInfo As IEnumNamedID

70
 Dim lFormID(100) As Long, l As Long
Dim sName As String, sCode As String

On Error GoTo ErrHandler

'Get Printer
Set pMxApp = Application
Set pPrinter = pMxApp.Printer

'Open/Create log file

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateTextFile(sFileName, True) ' overwrites existing
file

'Temp code to write paper sizes to file

f.WriteLine ("Available Printer Sizes for " & pPrinter.DriverName &
":")
f.WriteLine ("")

Set pEnumTypeInfo = pPrinter.Paper.Forms

pEnumTypeInfo.Reset

lFormID(l) = pEnumTypeInfo.Next(sName)
Do Until lFormID(l) = 0
sCode = CStr(lFormID(l))
While Len(sCode) < 4
sCode = sCode & " "
Wend
f.WriteLine (sCode & ": " & sName)
lFormID(l) = pEnumTypeInfo.Next(sName)
Loop

'Close temp log file

f.Close
Set f = Nothing

MsgBox "Settings logged to file:" & vbCrLf & sFileName,

vbInformation

GoTo Cleanup

ErrHandler:
MsgBox "Error: " & Err.Description, vbCritical
Cleanup:
If Not f Is Nothing Then
f.Close
Set f = Nothing
End If
Set pEnumTypeInfo = Nothing
Set pPrinter = Nothing
Set pMxApp = Nothing

End Sub
'-- Create two UIButtonControls
'-- Attach the two codesets to the appropriate button
'-- Sends results to message box

71
Option Explicit

'-- Graphics 1+ works in data view and tells user to switch to data view
Private Sub AreaCalcGraphplf_Click()
Dim pDoc As IMxDocument
Set pDoc = ThisDocument
Dim pAV As IActiveView
Set pAV = pDoc.ActiveView
Dim pGC As IGraphicsContainerSelect
Set pGC = pAV.GraphicsContainer
Dim pElem As IElement
Dim pPoly As IPolygon
Dim pAcres As Double, pFeet As Double, pMeters As Double
Dim i As Integer, Looper As Integer
i = pGC.ElementSelectionCount

'-- Make sure element is selected

If i = 0 Then
MsgBox "Please select one or more graphics"
Exit Sub
End If

'-- Check to make sure in Data View for graphics

http://forums.esri.com/thread.asp?c=93&f=992&t=61739#157733
If TypeOf pDoc.ActiveView Is IPageLayout Then
MsgBox "Switch to Data View to calc Ac"
Exit Sub
End If

Dim l As Long, dArea As Double 'http://forums.esri.com/Thread.asp?

c=93&f=982&t=62974#163462
For l = 0 To pGC.ElementSelectionCount - 1
If TypeOf pGC.SelectedElement(l).Geometry Is IArea Then
Dim pArea As IArea
Set pArea = pGC.SelectedElement(l).Geometry
dArea = dArea + pArea.Area
End If
Next l

pMeters = dArea
pFeet = pMeters * 10.76391042
pAcres = pFeet / 43560
MsgBox "Acreage = " & Format(pAcres, "##,##0")
End Sub

Private Function AreaCalcGraphplf_ToolTip() As String

AreaCalcGraphplf_ToolTip = "Calc Area Graphics(Ac)"
End Function

'-- Shapes 1+ works in layout or data view

'-- tested on gdb, shp, PC A/I covs should work on all
Private Sub AreaCalcplf_Click() 'http://forums.esri.com/thread.asp?
c=93&f=982&t=42209#104695
Dim pMxDoc As IMxDocument
Dim pArea As IArea

72
Dim pAcres As Double, pFeet As Double, pMeters As Double
Dim i As Integer, Looper As Integer
Dim pPoly As IFeature
Dim pMap As IMap
Dim pFSelection As IEnumFeature
Dim pActiveView As IActiveView
Dim pContentsView As IContentsView

Set pMxDoc = ThisDocument

Set pMap = pMxDoc.FocusMap
Set pActiveView = pMap
Set pContentsView = pMxDoc.CurrentContentsView
Set pFSelection = pMap.FeatureSelection
i = pMap.SelectionCount

'-- Make sure element is selected

If i = 0 Then
MsgBox "Please select one or more shapes"
Exit Sub
End If

Do Until Looper = i
Set pPoly = pFSelection.Next
Looper = Looper + 1
Set pArea = pPoly.Shape
pMeters = (pMeters + pArea.Area)
Loop

pFeet = pMeters * 10.76391042

pAcres = pFeet / 43560
MsgBox "Acreage = " & Format(pAcres, "##,##0")
End Sub

Private Function AreaCalcplf_ToolTip() As String

AreaCalcplf_ToolTip = "Calc Area Shapes(Ac)"
End Function

AREA CALLUCULATION
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap

Dim pFLayer As IFeatureLayer

Dim pFClass As IFeatureClass

Set pFLayer = pMap.Layer(0)

Set pFClass = pFLayer.FeatureClass

Dim pFields As IFields

Set pFields = pFClass.fields

Dim intArea As Integer

intArea = pFields.FindField("NewArea")

73
 If intArea = -1 Then
Dim pFieldEdit As IFieldEdit
Set pFieldEdit = New Field
pFieldEdit.Name = "NewArea"
pFieldEdit.Type = esriFieldTypeDouble
pFClass.AddField pFieldEdit
End If

Dim pCalc As ICalculator

Set pCalc = New Calculator

Dim pCursor As ICursor

Set pCursor = pFClass.Update(Nothing, True)

Set pCalc.Cursor = pCursor

With pCalc
.PreExpression = "Dim dblArea As Double" & vbNewLine & _
"Dim pArea as IArea" & vbNewLine & _
"Set pArea = [shape]" & vbNewLine & _
"dblArea = pArea.Area"
.Expression = "dblArea"
.Field = "NewArea"
End With
pCalc.Calculate
Public Sub Ascii2PointFeatureClass(strAsciiFullFilename As String,
pInFeatureClass As IFeatureClass, Optional strFieldName As String)
''Create a point feature class from a ascii file including the
coordinates of x,y and z
''
''strAsciiFullFilename is the filename of ascii file with folder path,
'' such as "e:\project\test\xyz.txt".
''strFieldName is field name that will be created in the feature
class depending on accii file
'' For example strFieldName = "Elev"
''
''Example call: Ascii2PointFeatureClass
"e:\project\test\xyz.txt",pFeatureClass,"Elev"
''
'' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan
'' [email protected]
'' Mar 15, 2002

Const lgMaxPointNum As Long = 100

If strAsciiFulFilename = "" Then

Exit Sub
End If

Dim xCoor(1 To lgMaxPointNum) As Single, yCoor(1 To lgMaxPointNum)

As Single, zCoor(1 To lgMaxPointNum) As Single
Dim iMaxNum As Long

iMaxNum = 0

'Read Ascii file for the coordinates of x,y and z

74
 Open strAsciiFullFilename For Input As #1
Dim blnIsZValue As Boolean 'Boolean variable dealing with z value
blnIsZValue = IIf(IsMissing(strFieldName) Or strFieldName = "",
False, True)

If blnIsZValue Then 'with z value

While Not EOF(1)
iMaxNum = iMaxNum + 1
Input #1, xCoor(iMaxNum), yCoor(iMaxNum), zCoor(iMaxNum)
Wend
Else 'Without z value
While Not EOF(1)
iMaxNum = iMaxNum + 1
Input #1, xCoor(iMaxNum), yCoor(iMaxNum)
Wend
End If
Close #1

If blnIsZValue Then 'with z value

Dim FieldIndex As Integer
FieldIndex = pInFeatureClass.FindField(strFieldName)
'Skip adding a newfield if found
If FieldIndex < 0 Then ' No find to add a newfield
' Prepare Fields for z value, dimmension as single
Dim pFld As IFieldEdit
Set pFld = New Field
With pFld
.Name = strFieldName 'Given by the optional parameter
.Type = esriFieldTypeSingle
.length = 10
End With

' Add field

pInFeatureClass.AddField pFld
End If
' Get field index
FieldIndex = pInFeatureClass.FindField(strFieldName)
If FieldIndex < 0 Then Exit Sub
End If

'Use an insert cursor to load features,making loading simple

features much quicker
Dim pInsertFeatureBuffer As IFeatureBuffer
Dim pInsertFeatureCursor As IFeatureCursor
Dim NewFeatureCount As Long 'Counter for flushing the feature cursor
Set pInsertFeatureCursor = pInFeatureClass.Insert(True)
Set pInsertFeatureBuffer = pInFeatureClass.CreateFeatureBuffer

'Define a new point

Dim pPoint As IPoint
Set pPoint = New Point
Dim i As Long

For i = 1 To iMaxNum

75
 With pPoint
.x = xCoor(i)
.y = xCoor(i)
End With

'Add the Point feature's geometry to the feature buffer

Set pInsertFeatureBuffer.Shape = pPoint

If blnIsZValue Then
'Add z value to strFieldName field
pInsertFeatureBuffer.Value(FieldIndex) = zCoor(i)
End If
'Insert the feature into the cursor
pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
NewFeatureCount = NewFeatureCount + 1

'Flush the feature cursor every 100 features

If NewFeatureCount = 100 Then
pInsertFeatureCursor.Flush
NewFeatureCount = 0
End If
Next
pInsertFeatureCursor.Flush 'Flush the cursor one last time

End Sub

Public Sub Ascii2PointFeatureClassMultiFields(strAsciiFulFilename As

String, pInFeatureClass As IFeatureClass, strFieldName() As String)
''Create a point feature class from a ascii file including the
coordinates of x,y and z
''
''strAsciiFulFilename is the filename of ascii file with folder path,
'' such as "e:\project\test\xyz.txt".
''strFieldName is an array of field names that will be created in the
feature class depending on accii file
'' For example strFieldName = "Elev"
''
''Example call: Ascii2PointFeatureClass
"e:\project\test\xyz.txt",pFeatureClass,strFieldName
''
'' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan
'' [email protected]
'' Mar 15, 2002

Const lgMaxPointNum As Long = 100

Const intMaxFieldtNum As Long = 10

If strAsciiFulFilename = "" Then

Exit Sub
End If

Dim lgLower As Long, lgUpper As Long

lgLower = LBound(strFieldName) 'the smallest available dimension
lgUpper = UBound(strFieldName) 'the largest available dimension

76
 Dim xCoor(1 To lgMaxPointNum) As Single, yCoor(1 To lgMaxPointNum)
As Single
Dim FieldValue(1 To lgMaxPointNum, intMaxFieldtNum) As Single
Dim iMaxNum As Long, i As Long
'ReDim FieldValue(1 To lgMaxPointNum, lgLower To lgUpper) As Single

iMaxNum = 0

'Read Ascii file for the coordinates of x,y and z

Open strAsciiFulFilename For Input As #1
While Not EOF(1)
iMaxNum = iMaxNum + 1
'Read the coordinates of x,y
Input #1, xCoor(iMaxNum), yCoor(iMaxNum)
'Read the field value
For i = lgLower To lgUpper
Input #1, FieldValue(iMaxNum, i)
Next i
Wend
Close #1

Dim FieldIndex(intMaxFieldtNum) As Integer

'Loop for creating the fields
For i = lgLower To lgUpper
FieldIndex(i) = pInFeatureClass.FindField(strFieldName(i))
'Skip adding a newfield if found
If FieldIndex(i) < 0 Then ' No find to add a newfield
' Prepare Fields for z value, dimmension as single
Dim pFld As IFieldEdit
Set pFld = New Field
With pFld
.Name = strFieldName(i) 'Given by the optional parameter
.Type = esriFieldTypeSingle
.length = 10
End With

' Add field

pInFeatureClass.AddField pFld
End If
' Get field index
FieldIndex(i) = pInFeatureClass.FindField(strFieldName(i))
If FieldIndex(i) < 0 Then
MsgBox "Field:" & strFieldName(i) & "cannot be indexed!",
vbExclamation
Exit Sub
End If
Next i

'Use an insert cursor to load features,making loading simple

features much quicker
Dim pInsertFeatureBuffer As IFeatureBuffer
Dim pInsertFeatureCursor As IFeatureCursor
Dim NewFeatureCount As Long 'Counter for flushing the feature cursor
Set pInsertFeatureCursor = pInFeatureClass.Insert(True)
Set pInsertFeatureBuffer = pInFeatureClass.CreateFeatureBuffer

77
 'Define a new point
Dim pPoint As IPoint
Set pPoint = New Point
Dim j As Integer

For i = 1 To iMaxNum
With pPoint
.x = xCoor(i)
.y = xCoor(i)
End With

'Add the Point feature's geometry to the feature buffer

Set pInsertFeatureBuffer.Shape = pPoint

'Add field value to strFieldName field

For j = lgLower To lgUpper
pInsertFeatureBuffer.Value(FieldIndex(j)) = FieldValue(i, j)
Next j

'Insert the feature into the cursor

pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
NewFeatureCount = NewFeatureCount + 1

'Flush the feature cursor every 100 features

If NewFeatureCount = 100 Then
pInsertFeatureCursor.Flush
NewFeatureCount = 0
End If
Next
pInsertFeatureCursor.Flush 'Flush the cursor one last time

End Sub
Public Sub Ascii2Point(strFilePath As String, strAsciiFilename As
String, strShapeFilename As String)
''Create a point shapefile from a ascii file including the
coordinates of x,y and z
''strFilePath is the folder that contains the ascii file and also
shapefile will be created.
'' For example strFilePath = "e:\project\test"
''strAsciiFilename is the filename of ascii file, such as "xyz.txt".
''strShapeFilename is name of shapefile that will be created in the
folder of strFilePath.
'' For example strShapeFilename = "MyPoint" without extension.
''
''Example call: Ascii2Point "e:\project\test","xyz.txt","MyPoint"
''
'' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan
'' [email protected]
'' Feb 20, 2002

Const strPeriod As String * 1 = "\"

Const lgMaxPointNum As Long = 100

If strFilePath = "" Or strAsciiFilename = "" Or strShapeFilename =

"" Then

78
 Exit Sub
End If

Dim xCoor(1 To lgMaxPointNum) As Single, yCoor(1 To lgMaxPointNum)

As Single, zCoor(1 To lgMaxPointNum) As Single
Dim iMaxNum As Long
Dim strFullAsciiFilename As String
iMaxNum = 0
strFullAsciiFilename = strFilePath + strPeriod + strAsciiFilename

'Read Ascii file for the coordinates of x,y and z

Open strFullAsciiFilename For Input As #1
While Not EOF(1)
iMaxNum = iMaxNum + 1
Input #1, xCoor(iMaxNum), yCoor(iMaxNum), zCoor(iMaxNum)
Wend
Close #1

' Prepare Fields for Shapefile

Dim pXCoor As IFieldEdit
Set pXCoor = New Field
With pXCoor
.Name = "XCoor"
.Type = esriFieldTypeSingle
End With
Dim pYCoor As IFieldEdit
Set pYCoor = New Field
With pYCoor
.Name = "YCoor"
.Type = esriFieldTypeSingle
End With
Dim pZCoor As IFieldEdit
Set pZCoor = New Field
With pZCoor
.Name = "ZCoor"
.Type = esriFieldTypeSingle
End With

'Call for createShapefile function to create a new point shapefile

Dim pFClassOutput As IFeatureClass
Set pFClassOutput = createShapefile(strFilePath, strShapeFilename,
esriGeometryPoint)

'Add fields of xcoor, ycoor and zcoor

pFClassOutput.AddField pXCoor
pFClassOutput.AddField pYCoor
pFClassOutput.AddField pZCoor

' Get indexes of xcoor, ycoor and zcoor

Dim indexX As Long, indexY As Long, indexZ As Long
indexX = pFClassOutput.FindField("XCoor")
indexY = pFClassOutput.FindField("YCoor")
indexZ = pFClassOutput.FindField("ZCoor")
Dim indexShape As Long
indexShape = pFClassOutput.FindField("shape")

Dim pPoint As IPoint

79
 Set pPoint = New Point
Dim i As Long

'Use an insert cursor to load features,making loading simple

features much quicker
Dim pInsertFeatureBuffer As IFeatureBuffer
Dim pInsertFeatureCursor As IFeatureCursor

Set pInsertFeatureCursor = pFClassOutput.Insert(True)

Set pInsertFeatureBuffer = pFClassOutput.CreateFeatureBuffer

For i = 1 To iMaxNum
With pPoint
.x = xCoor(i)
.y = yCoor(i)
End With

'Add the Point feature's geometry to the feature buffer

Set pInsertFeatureBuffer.Shape = pPoint

pInsertFeatureBuffer.Value(indexX) = xCoor(i)
pInsertFeatureBuffer.Value(indexY) = yCoor(i)
pInsertFeatureBuffer.Value(indexZ) = zCoor(i)

'Insert the feature into the cursor

pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer

Next
pInsertFeatureCursor.Flush 'Flush the cursor one last time
End Sub

Public Function createShapefile(strFolder As String, strName As String,

_
geomType As esriCore.esriGeometryType) As esriCore.IFeatureClass

'' Simple function to create a shapefile in the strFolder.

'' Note: the name of the shapefile should not contain the .shp extension
''
'' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan
'' [email protected]
'' Feb 18, 2002

Const strShapeFieldName As String = "Shape"

On Error GoTo EH
Set createShapefile = Nothing
If strFolder = "" Then Exit Function

' Open the folder to contain the shapefile as a workspace

Dim pFWS As IFeatureWorkspace
Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFWS = pWorkspaceFactory.OpenFromFile(strFolder, 0)

' Set up a simple fields collection

Dim pFields As IFields
Dim pFieldsEdit As IFieldsEdit

80
 Set pFields = New esriCore.Fields
Set pFieldsEdit = pFields

Dim pField As IField

Dim pFieldEdit As IFieldEdit

' Make the shape field

' it will need a geometry definition, with a spatial reference
Set pField = New esriCore.Field
Set pFieldEdit = pField
pFieldEdit.Name = strShapeFieldName
pFieldEdit.Type = esriFieldTypeGeometry

Dim pGeomDef As IGeometryDef

Dim pGeomDefEdit As IGeometryDefEdit
Set pGeomDef = New GeometryDef
Set pGeomDefEdit = pGeomDef
With pGeomDefEdit
.GeometryType = geomType
Set .SpatialReference = New UnknownCoordinateSystem
End With
Set pFieldEdit.GeometryDef = pGeomDef
pFieldsEdit.AddField pField

' Create the shapefile

' (some parameters apply to geodatabase options and can be defaulted
as Nothing)

Set createShapefile = pFWS.CreateFeatureClass(strName, pFields,

Nothing, _
Nothing, esriFTSimple,
strShapeFieldName, "")
Exit Function
EH:
MsgBox Err.Description, vbInformation, "createShapefile"
End Function
Public Sub Ascii2Point(strFilePath As String, strAsciiFilename As String, strShapeFilename As String)
''Create a point shapefile from a ascii file including the coordinates of x,y and z
''strFilePath is the folder that contains the ascii file and also shapefile will be created.
'' For example strFilePath = "e:\project\test"
''strAsciiFilename is the filename of ascii file, such as "xyz.txt".
''strShapeFilename is name of shapefile that will be created in the folder of strFilePath.
'' For example strShapeFilename = "MyPoint" without extension.
''
''Example call: Ascii2Point "e:\project\test","xyz.txt","MyPoint"
''
'' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan
'' [email protected]
'' Feb 20, 2002

Const strPeriod As String * 1 = "\"

If strFilePath = "" Or strAsciiFilename = "" Or strShapeFilename = "" Then

Exit Sub
End If

Dim xCoor(1 To 100) As Single, yCoor(1 To 100) As Single, zCoor(1 To 100) As Single
Dim iMaxNum As Long

81
Dim strFullAsciiFilename As String
iMaxNum = 0
strFullAsciiFilename = strFilePath + strPeriod + strAsciiFilename

'Read Ascii file for the coordinates of x,y and z

Open strFullAsciiFilename For Input As #1
While Not EOF(1)
iMaxNum = iMaxNum + 1
Input #1, xCoor(iMaxNum), yCoor(iMaxNum), zCoor(iMaxNum)
Wend
Close #1

' Prepare Fields for Shapefile

Dim pXCoor As IFieldEdit
Set pXCoor = New Field
With pXCoor
.Name = "XCoor"
.Type = esriFieldTypeSingle
End With
Dim pYCoor As IFieldEdit
Set pYCoor = New Field
With pYCoor
.Name = "YCoor"
.Type = esriFieldTypeSingle
End With
Dim pZCoor As IFieldEdit
Set pZCoor = New Field
With pZCoor
.Name = "ZCoor"
.Type = esriFieldTypeSingle
End With

'Call for createShapefile function to create a new point shapefile

Dim pFClassOutput As IFeatureClass
Set pFClassOutput = createShapefile(strFilePath, strShapeFilename, esriGeometryPoint)

'Add fields of xcoor, ycoor and zcoor

pFClassOutput.AddField pXCoor
pFClassOutput.AddField pYCoor
pFClassOutput.AddField pZCoor

' Get indexes of xcoor, ycoor and zcoor

Dim indexX As Long, indexY As Long, indexZ As Long
indexX = pFClassOutput.FindField("XCoor")
indexY = pFClassOutput.FindField("YCoor")
indexZ = pFClassOutput.FindField("ZCoor")
Dim indexShape As Long
indexShape = pFClassOutput.FindField("shape")

Dim pPoint As IPoint

Set pPoint = New Point
Dim i As Long

For i = 1 To iMaxNum
With pPoint
.X = xCoor(i)
.Y = xCoor(i)
End With
Dim pFeature As IFeature
Set pFeature = pFClassOutput.CreateFeature
pFeature.Value(indexShape) = pPoint
pFeature.Value(indexX) = xCoor(i)

82
 pFeature.Value(indexY) = yCoor(i)
pFeature.Value(indexZ) = zCoor(i)
pFeature.Store
Next
End Sub

Public Function createShapefile(strFolder As String, strName As String, _

geomType As esriCore.esriGeometryType) As esriCore.IFeatureClass

'' Simple function to create a shapefile in the strFolder.

'' Note: the name of the shapefile should not contain the .shp extension
''
'' Xiaodong ZHAO, Kyushu University, Fukuoka, Japan
'' [email protected]
'' Feb 18, 2002

Const strShapeFieldName As String = "Shape"

On Error GoTo EH
Set createShapefile = Nothing
If strFolder = "" Then Exit Function

' Open the folder to contain the shapefile as a workspace

Dim pFWS As IFeatureWorkspace
Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFWS = pWorkspaceFactory.OpenFromFile(strFolder, 0)

' Set up a simple fields collection

Dim pFields As IFields
Dim pFieldsEdit As IFieldsEdit
Set pFields = New esriCore.Fields
Set pFieldsEdit = pFields

Dim pField As IField

Dim pFieldEdit As IFieldEdit

' Make the shape field

' it will need a geometry definition, with a spatial reference
Set pField = New esriCore.Field
Set pFieldEdit = pField
pFieldEdit.Name = strShapeFieldName
pFieldEdit.Type = esriFieldTypeGeometry

Dim pGeomDef As IGeometryDef

Dim pGeomDefEdit As IGeometryDefEdit
Set pGeomDef = New GeometryDef
Set pGeomDefEdit = pGeomDef
With pGeomDefEdit
.GeometryType = geomType
Set .SpatialReference = New UnknownCoordinateSystem
End With
Set pFieldEdit.GeometryDef = pGeomDef
pFieldsEdit.AddField pField

' Create the shapefile

' (some parameters apply to geodatabase options and can be defaulted as Nothing)

Set createShapefile = pFWS.CreateFeatureClass(strName, pFields, Nothing, _

Nothing, esriFTSimple, strShapeFieldName, "")
Exit Function
EH:

83
 MsgBox Err.Description, vbInformation, "createShapefile"
End Function
Private Sub UIButtonOffsetBuffers_Click()

'creates two offset arcs, connects the endpoints with circular arcs,
'converts to a polygon and displays as a graphic

Dim pMxDoc As IMxDocument

Dim pActiveView As IActiveView
Dim pGraphicsContainer As IGraphicsContainer
Dim pEnumFeature As IEnumFeature
Dim pFeature As IFeature
Dim pElementPoly As IElement
Dim pPolyline As IPolyline
Dim strOffsetDistR As String
Dim strOffsetDistL As String
Dim dblOffsetDistR As Double
Dim dblOffsetDistL As Double

Set pMxDoc = Application.Document

Set pActiveView = pMxDoc.FocusMap
Set pGraphicsContainer = pMxDoc.FocusMap

'verify that there is a feature selection

If pMxDoc.FocusMap.SelectionCount = 0 Then Exit Sub

'Get offset distances from user

'left side, distance is negative

strOffsetDistL = InputBox("Enter Left offset: ", "Left offset")
If strOffsetDistL = "" Or Not IsNumeric(strOffsetDistL) Then Exit Sub
dblOffsetDistL = -(CDbl(strOffsetDistL))

'right side, distance is positive

strOffsetDistR = InputBox("Enter Right offset: ", "Right offset")
If strOffsetDistR = "" Or Not IsNumeric(strOffsetDistR) Then Exit Sub
dblOffsetDistR = CDbl(strOffsetDistR)

'Get the selected features

Set pEnumFeature = pMxDoc.FocusMap.FeatureSelection
pEnumFeature.Reset
Set pFeature = pEnumFeature.Next

'Loop through selected features

Do While Not pFeature Is Nothing
If TypeOf pFeature.Shape Is IPolyline Then
Set pPolyline = pFeature.Shape

'create offset curves for buffer edges

Dim pOffsetCurveL As IConstructCurve
Dim pOffsetCurveR As IConstructCurve
Set pOffsetCurveL = New Polyline
Set pOffsetCurveR = New Polyline

pOffsetCurveL.ConstructOffset pPolyline, dblOffsetDistL,

esriConstructOffsetRounded + esriConstructOffsetSimple

84
 pOffsetCurveR.ConstructOffset pPolyline, dblOffsetDistR,
esriConstructOffsetRounded + esriConstructOffsetSimple

Dim pOffsetL As IPolyline

Dim pOffsetR As IPolyline
Set pOffsetL = pOffsetCurveL
Set pOffsetR = pOffsetCurveR

'Reverse the directon of left offsetcurve to maintain

Counterclockwise directionality
pOffsetL.ReverseOrientation

'create the curved ends of buffer

Dim pFromPointL As IPoint
Dim pFromPointR As IPoint
Dim pToPointL As IPoint
Dim pToPointR As IPoint

Set pFromPointL = pOffsetL.FromPoint

Set pFromPointR = pOffsetR.FromPoint
Set pToPointL = pOffsetL.ToPoint
Set pToPointR = pOffsetR.ToPoint

Dim pConstructCircularArcL As IConstructCircularArc

Dim pConstructCircularArcR As IConstructCircularArc
Set pConstructCircularArcL = New CircularArc
Set pConstructCircularArcR = New CircularArc

Dim Pi As Double
Pi = 4 * Atn(1) 'calculate the value of Pi
'angles are in radians (Radians = Degrees * PI/180)

'construct a round arc connecting the From points

pConstructCircularArcR.ConstructEndPointsAngle pToPointR,
pFromPointL, True, Pi
pConstructCircularArcL.ConstructEndPointsAngle pToPointL,
pFromPointR, True, Pi

'obtain circular arcs

Dim pCurveLR As ICircularArc
Dim pCurveRL As ICircularArc
Set pCurveLR = pConstructCircularArcL
Set pCurveRL = pConstructCircularArcR

'polylines must be converted to segment collections

Dim pPolySegL As ISegmentCollection
Dim pPolySegR As ISegmentCollection
Set pPolySegL = pOffsetL
Set pPolySegR = pOffsetR

'construct a ring
Dim pRing As IRing
Dim pRingBuffer As ISegmentCollection
Set pRingBuffer = New Ring

pRingBuffer.AddSegmentCollection pPolySegR
pRingBuffer.AddSegment pCurveRL

85
 pRingBuffer.AddSegmentCollection pPolySegL
pRingBuffer.AddSegment pCurveLR

Set pRing = pRingBuffer

'construct a polygon geometry collection

Dim pPolygonGeoColl As IGeometryCollection
Set pPolygonGeoColl = New Polygon

pPolygonGeoColl.AddGeometry pRing

'construct and simplify polygon

Dim pPolygonFinal As IPolygon
Dim pTopological As ITopologicalOperator
Set pPolygonFinal = pPolygonGeoColl
Set pTopological = pPolygonGeoColl
pPolygonFinal.SimplifyPreserveFromTo
pTopological.Simplify

'create polygon graphic element

Set pElementPoly = New PolygonElement
pElementPoly.Geometry = pPolygonFinal

pGraphicsContainer.AddElement pElementPoly, 0

End If
Set pFeature = pEnumFeature.Next
Loop

pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing

'Created by: Justin Johnson

'[email protected]

End Sub
Attribute VB_Name = "OffsetBufferCode"
Option Explicit

'Author: Justin Johnson

'Email : [email protected]
'Date : February 2004
'Description: Creates buffers around polylines and polygon boundaries allowing user to
' specify a different buffer distance for each side of the line.

Public Sub OffsetBuffers()

'Creates offset buffers around polylines and polygons

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pInLayer As ILayer
Dim pInFlayer As IFeatureLayer
Dim pOutFLayer As IFeatureLayer
Dim pInFCursor As IFeatureCursor
Dim pOutFCursor As IFeatureCursor
Dim pOutFBuffer As IFeatureBuffer
Dim pInFClass As IFeatureClass
Dim pOutFClass As IFeatureClass
Dim pInFeature As IFeature
Dim pInGeom As IGeometry

86
Dim sInput As String
Dim dBufferDistance As Double
Dim dLBufferDistance As Double
Dim dRBufferDistance As Double
Dim k As Integer

Set pMxDoc = ThisDocument

Set pMap = pMxDoc.FocusMap
Set pInLayer = pMxDoc.SelectedLayer
Set pOutFLayer = pMap.Layer(0)
Set pOutFClass = pOutFLayer.FeatureClass

Dim pGeomBag As IGeometryCollection

Set pGeomBag = New GeometryBag

Dim pEnumGeom As IEnumGeometry

Set pEnumGeom = pGeomBag

Dim pNewGeom As IGeometry

'Test compatibility of input/output feature layers

If pInLayer Is Nothing Then
MsgBox "Please select a feature layer", vbCritical, "Incompatible input layer"
Exit Sub
End If

If Not TypeOf pInLayer Is IFeatureLayer Then

MsgBox "Please select a feature layer", vbCritical, "Incompatible input layer"
Exit Sub
End If

If Not pOutFClass.ShapeType = esriGeometryPolygon Then

MsgBox "Geometry of output layer is not Polygon", vbCritical, "Incompatible output layer"
Exit Sub
End If

'Set input feature interfaces

Set pInFlayer = pInLayer
Set pInFClass = pInFlayer.FeatureClass

'Create input and output cursors

Set pInFCursor = GetInputFeatures
Set pOutFBuffer = pOutFClass.CreateFeatureBuffer
Set pOutFCursor = pOutFClass.Insert(True)

If pInFClass.ShapeType = esriGeometryPolyline Or pInFClass.ShapeType = esriGeometryPolygon Then

'If feature is a polyline or polygon, ask for offsets

'Get Left side buffer distance, test if response is empty or non-numeric

sInput = InputBox("Enter left buffer distance:", "Left Buffer Distance")
If sInput = "" Or Not IsNumeric(sInput) Then Exit Sub
dLBufferDistance = -CDbl(sInput)
If dLBufferDistance > 0 Then Exit Sub

'Get Right side buffer distance, test if response is empty or non-numeric

sInput = InputBox("Enter right buffer distance:", "Right Buffer Distance")
If sInput = "" Or Not IsNumeric(sInput) Then Exit Sub
dRBufferDistance = CDbl(sInput)
If dRBufferDistance < 0 Then Exit Sub

ElseIf pInFClass.ShapeType = esriGeometryPoint Then

'if feature is a point, ask for buffer radius

87
 sInput = InputBox("Enter point buffer distance:", "Point Buffer Distance")
If sInput = "" Or Not IsNumeric(sInput) Then Exit Sub
dBufferDistance = CDbl(sInput)

Else
Exit Sub

End If

Set pInFeature = pInFCursor.NextFeature 'Get first feature

Do While Not pInFeature Is Nothing

Dim pPolygonGeoColl As IGeometryCollection

Dim pOutGeom As IGeometry
Dim pOutPolygon As IPolygon
Set pPolygonGeoColl = New Polygon

Select Case pInFClass.ShapeType

Case esriGeometryPoint

Dim pCenter As IPoint

Set pCenter = pInFeature.Shape

Set pOutPolygon = ProcessPoint(pCenter, dBufferDistance)
Set pOutGeom = pOutPolygon

pGeomBag.AddGeometry pOutGeom

Case esriGeometryPolyline

Dim pPolyline As IPolyline

Set pPolyline = pInFeature.Shape

Set pOutPolygon = ProcessPolyline(pPolyline, dLBufferDistance, dRBufferDistance, False)
Set pOutGeom = pOutPolygon

pGeomBag.AddGeometry pOutGeom

Case esriGeometryPolygon

Dim pPolygon As IPolygon

Dim pTopoOp As ITopologicalOperator
Dim pPolygonBoundary As IPolyline

Set pPolygon = pInFeature.Shape

Set pTopoOp = pPolygon
Set pPolygonBoundary = pTopoOp.Boundary
Set pOutPolygon = ProcessPolyline(pPolygonBoundary, dLBufferDistance, dRBufferDistance, True)
Set pOutGeom = pOutPolygon

pGeomBag.AddGeometry pOutGeom

End Select

Set pInFeature = pInFCursor.NextFeature

Loop

'send all completed buffer polygons to the output featureclass

88
 pEnumGeom.Reset

Dim pBufferPolygon As IPolygon

Set pBufferPolygon = pEnumGeom.Next

Do While Not pBufferPolygon Is Nothing

Set pOutFBuffer.Shape = pBufferPolygon

pOutFCursor.InsertFeature pOutFBuffer
pOutFCursor.Flush

Set pBufferPolygon = pEnumGeom.Next

Loop

pMxDoc.ActiveView.Refresh

End Sub

Private Function ProcessPoint(pCenter As IPoint, dBufferDistance As Double) As IPolygon

'returns a circle centered on IPoint with a radius dBufferDistance

Dim pCCircularArc As IConstructCircularArc

Dim pSegment As ISegment
Dim pSegColl As ISegmentCollection
Dim pRing As IRing
Dim pGeometry As IGeometry
Dim pGeomColl As IGeometryCollection
Dim pPolygon As IPolygon

Set pCCircularArc = New CircularArc

Set pSegment = pCCircularArc
Set pSegColl = New Ring
Set pRing = pSegColl

pCCircularArc.ConstructCircle pCenter, dBufferDistance, False

pSegColl.AddSegment pSegment

Set pPolygon = New Polygon

Set pGeomColl = pPolygon
Set pGeometry = pRing

pGeomColl.AddGeometry pGeometry

Set ProcessPoint = pPolygon

End Function

Private Function ProcessPolyline(pPolyline As IPolyline, dLBufferDistance As Double, _

dRBufferDistance As Double, IsPolygon As Boolean) As IPolygon

'obtains the polyline segments, creates a rectangle around each segment according to the offsets
'obtains each vertex, sends each vertex to the ProcessVertex function to get the exterior angle buffer
'obtains each endpoint, sends each to ProcessPoint, where circles are created according to the offsets
'unions all polygons, returns the unioned polygon buffer for the entire polyline

Dim pPointColl As IPointCollection

Dim pSegColl As ISegmentCollection
Dim pSegment As ISegment
Dim pCurve As ICurve
Dim pTopoOp As ITopologicalOperator

89
Dim pOffsetpoint As IPoint
Dim pVertexBuffer As IPolygon

Set pPointColl = pPolyline

Set pSegColl = pPolyline

Dim pPolygonGC As IGeometryCollection

Dim pNewGeom As IGeometry
Dim pGeomBag As IGeometryCollection
Dim pIEnumGeom As IEnumGeometry

Set pGeomBag = New GeometryBag

Set pIEnumGeom = pGeomBag

Dim pFseg As ISegment 'from segment

Dim pTseg As ISegment 'to segment

Set pFseg = pSegColl.Segment(0)

Dim k As Integer

For k = 0 To pSegColl.SegmentCount - 1 'process each segment

Dim pConPoint As IConstructPoint

Dim pFpoint As IPoint 'from point
Dim pTpoint As IPoint 'to point
Dim pFL As IPoint 'offset point - left of from point
Dim pFR As IPoint 'offset point - right of from point
Dim pTL As IPoint 'offset point - left of to point
Dim pTR As IPoint 'offset point - right of to point
Dim pClone As IClone

Set pSegment = pSegColl.Segment(k)

Set pCurve = pSegment
Set pFpoint = pSegment.FromPoint
Set pTpoint = pSegment.ToPoint
Set pConPoint = New Point
Set pClone = pConPoint

'Create the corners of the rectangular buffer for this segment

pConPoint.ConstructOffset pCurve, esriNoExtension, 0, False, dLBufferDistance
Set pFL = pClone.Clone
pConPoint.ConstructOffset pCurve, esriNoExtension, pCurve.Length, False, dLBufferDistance
Set pTL = pClone.Clone
pConPoint.ConstructOffset pCurve, esriNoExtension, 0, False, dRBufferDistance
Set pFR = pClone.Clone
pConPoint.ConstructOffset pCurve, esriNoExtension, pCurve.Length, False, dRBufferDistance
Set pTR = pClone.Clone

Dim pRingPtColl As IPointCollection

Dim pRing As IRing

Set pRingPtColl = New Ring

Set pRing = pRingPtColl

pRingPtColl.AddPoint pFR
pRingPtColl.AddPoint pFL
pRingPtColl.AddPoint pTL
pRingPtColl.AddPoint pTR
pRingPtColl.AddPoint pFR

Set pPolygonGC = New Polygon

90
 pPolygonGC.AddGeometry pRing

Set pNewGeom = pPolygonGC

MakeGeometrySimple pNewGeom
pGeomBag.AddGeometry pNewGeom

'send current segment, and previous segment, to obtain the exterior angular buffer at their vertex

If k > 0 Then
Set pTseg = pSegColl.Segment(k)

Set pVertexBuffer = ProcessVertex(pFseg, pTseg, dLBufferDistance, dRBufferDistance)

Set pNewGeom = pVertexBuffer

MakeGeometrySimple pNewGeom
pGeomBag.AddGeometry pNewGeom

Set pFseg = pSegColl.Segment(k)

End If

Next k

If IsPolygon Then
'If polyline is a polygon boundary, create an exterior angular buffer at the vertex of the first
'and last segments of the boundary

Dim pFirstSeg As ISegment

Dim pLastSeg As ISegment
Set pFirstSeg = pSegColl.Segment(0)
Set pLastSeg = pSegColl.Segment(pSegColl.SegmentCount - 1)

Set pVertexBuffer = ProcessVertex(pLastSeg, pFirstSeg, dLBufferDistance, dRBufferDistance)

Set pNewGeom = pVertexBuffer

MakeGeometrySimple pNewGeom
pGeomBag.AddGeometry pNewGeom

Else
'If polyline is not a polygon boundary, create circle buffers at polyline endpoints

Set pFpoint = pPolyline.FromPoint

Set pTpoint = pPolyline.ToPoint
Set pCurve = pPolyline

'get the centerpoint of the buffer circle at the From point

pConPoint.ConstructOffset pCurve, esriNoExtension, 0, False, _
(dRBufferDistance + -dLBufferDistance) / 2 + dLBufferDistance
Set pOffsetpoint = pClone.Clone

Set pVertexBuffer = ProcessPoint(pOffsetpoint, (dRBufferDistance + -(dLBufferDistance)) / 2)

Set pNewGeom = pVertexBuffer

MakeGeometrySimple pNewGeom
pGeomBag.AddGeometry pNewGeom

'get the centerpoint of the buffer circle at the To point

pConPoint.ConstructOffset pCurve, esriNoExtension, pCurve.Length, False, _
(dRBufferDistance + -dLBufferDistance) / 2 + dLBufferDistance
Set pOffsetpoint = pClone.Clone

91
 Set pVertexBuffer = ProcessPoint(pOffsetpoint, (dRBufferDistance + -(dLBufferDistance)) / 2)
Set pNewGeom = pVertexBuffer

MakeGeometrySimple pNewGeom
pGeomBag.AddGeometry pNewGeom

End If

'create output polygon by unioning all geometries in the GeometryBag created so far

Dim pOutPolygon As IPolygon

Set pOutPolygon = New Polygon

Set pTopoOp = pOutPolygon

pTopoOp.ConstructUnion pIEnumGeom
pTopoOp.Simplify

Set ProcessPolyline = pOutPolygon

End Function

Private Function ProcessVertex(pFseg As ISegment, pTseg As ISegment, _

dLBufferDistance As Double, dRBufferDistance As Double) As IPolygon

'takes two segments joined at a common vertex, creates a pie-shaped polygon centered over
'the vertex, sweeping from one segment to the other through the exterior angle (>180°), at a
'radius equal to that specified for that side of the polyline. The interior angle is the "slice"
'taken out of the pie. These polygons are used to fill in the areas not covered by the
'rectangular buffers of each polyline segment.

Dim pPolygon As IPolygon

Dim pRing As IRing
Dim pGeomColl As IGeometryCollection
Dim pSegColl As ISegmentCollection

Set pPolygon = New Polygon

Set pRing = New Ring
Set pGeomColl = pPolygon
Set pSegColl = pRing

Dim pConstCirc As IConstructCircularArc

Dim pConstPoint As IConstructPoint
Dim pCircArc As ICircularArc
Dim dRadius As Double 'circular arc radius
Dim pCircArcFpt As IPoint 'circular arc From point
Dim pCircArcTpt As IPoint 'circular arc To point
Dim pCircArcVtx As IPoint 'circular arc Vertex point
Dim pSegment1 As ISegment 'line segment connecting circular arc to vertex
Dim pSegment2 As ISegment 'line segment connecting circular arc to vertex, completing the polygon
Dim pPtClone As IClone

Set pConstPoint = New Point

Set pConstCirc = New CircularArc
Set pPtClone = pConstPoint
Set pSegment1 = New Line
Set pSegment2 = New Line

Dim pTcurve As ICurve

Dim pFcurve As ICurve
Set pTcurve = pTseg

92
 Set pFcurve = pFseg

Dim pFfpt As IPoint 'From segment From point

Dim pFtpt As IPoint 'From segment To point
Dim pTfpt As IPoint 'To segment From point
Dim pTtpt As IPoint 'To segment To point

Set pFfpt = pFseg.FromPoint

Set pFtpt = pFseg.ToPoint
Set pTfpt = pTseg.FromPoint
Set pTtpt = pTseg.ToPoint

'Find out if pTseg turns left or right from pFseg

Select Case PointIsLeft(pFfpt, pFtpt, pTtpt)
Case Is = -1 'line bends left, use right buffer distance

dRadius = dRBufferDistance

pConstPoint.ConstructAlong pTcurve, esriExtendAtTo, dRadius, False

Set pCircArcTpt = pPtClone.Clone

pConstPoint.ConstructAlong pFcurve, esriExtendAtFrom, pFcurve.Length - dRadius, False

Set pCircArcFpt = pPtClone.Clone

Case Is = 1 'line bends right, use left buffer distance (left distance is a negative value)
'notice that the To and From points of the curve are switched. Find out why.

dRadius = -dLBufferDistance

pConstPoint.ConstructAlong pTcurve, esriExtendAtTo, dRadius, False

Set pCircArcFpt = pPtClone.Clone

pConstPoint.ConstructAlong pFcurve, esriExtendAtFrom, pFcurve.Length - dRadius, False

Set pCircArcTpt = pPtClone.Clone

Case Is = 0
'line segments are inline, don't do anything, the rectangles will merge seamlessly

Set ProcessVertex = pPolygon

Exit Function

End Select

Set pCircArcVtx = pFseg.ToPoint 'set the vertex

pConstCirc.ConstructEndPointsRadius pCircArcFpt, pCircArcTpt, True, dRadius, False

pSegColl.AddSegment pConstCirc 'Add circular segment to Ring

pSegment1.FromPoint = pCircArcTpt 'create first straight-line segment

pSegment1.ToPoint = pCircArcVtx
pSegColl.AddSegment pSegment1

pSegment2.FromPoint = pCircArcVtx 'create second straight-line segment

pSegment2.ToPoint = pCircArcFpt
pSegColl.AddSegment pSegment2

pRing.Close 'close ring

pGeomColl.AddGeometry pRing 'add ring to Polygon

Set ProcessVertex = pPolygon

End Function

93
Private Function GetInputFeatures() As IFeatureCursor
'Gets a Search cursor from the selected layer in the TOC
'Returns IFeatureCursor on either the selected features in the
' FeatureLayer, or all features if none (or all) are selected
'
'Preconditions: Input FeatureLayer is selected in the TOC

Dim iVal As Integer

Dim lVal As Long
Dim sVal As Single
Dim dVal As Double

Dim pMxDoc As IMxDocument

Dim pInFlayer As IFeatureLayer
Dim pInFCursor As IFeatureCursor
Dim pInFClass As IFeatureClass
Dim pFSelection As IFeatureSelection
Dim pSelSet As ISelectionSet

Set pMxDoc = ThisDocument

Set pInFlayer = pMxDoc.SelectedLayer
Set pInFClass = pInFlayer.FeatureClass
Set pFSelection = pInFlayer
Set pSelSet = pFSelection.SelectionSet

If pSelSet.Count <> 0 Then

'use selected features
pFSelection.SelectionSet.Search Nothing, True, pInFCursor
Else
'use all features
Set pInFCursor = pInFClass.Search(Nothing, True)
End If

Set GetInputFeatures = pInFCursor

End Function

Private Function PointIsLeft(p0 As IPoint, p1 As IPoint, p2 As IPoint) As Integer

'returns -1 if p2 is LEFT of the line from p0 to p1

'returns 1 if p2 is RIGHT of the line
'returns 0 if p2 is ON the line from p0 to p1

Dim dResult As Double

Dim vReturn As Integer

dResult = (p1.X - p0.X) * (p2.Y - p0.Y) - (p2.X - p0.X) * (p1.Y - p0.Y)

Select Case dResult

Case Is > 0
vReturn = -1
Case Is = 0
vReturn = 0
Case Is < 0
vReturn = 1
End Select

PointIsLeft = vReturn

End Function

94
Private Function MakeGeometrySimple(ByRef pGeometry As IGeometry)
'Simplifies a geometry by setting the IsKnownSimple value to False, then calling Simplify.
'Should be used to avoid "non-simple geometry" errors when trying to merge geometries.

Dim pTopoOp2 As ITopologicalOperator2

Set pTopoOp2 = pGeometry

pTopoOp2.IsKnownSimple = False
pTopoOp2.Simplify

End Function
'************************************************
Const CzasOds As Integer = 10 '###refresh time in seconds###
Dim i As Integer
Dim Refs
Dim pMxDoc As IMxDocument
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Sub RefreshMap()
Set pMxDoc = ThisDocument
Dim pmap As IMap
Set pmap = pMxDoc.FocusMap
Dim pav As IActiveView
Set pav = pmap
Do While i = 0
Czekaj CzasOds
pav.Refresh
Refs = DoEvents
Loop
End Sub
Public Sub Czekaj(Seconds As Single)
Dim lMilliSeconds As Long
lMilliSeconds = Seconds * 1000
Sleep lMilliSeconds
End Sub
Attribute VB_Name = "AutoAddLines"
Option Explicit
Public Sub Example_AutoAdd_HydrantLaterals()
Call AddLines("Water Mains", "Water Fire Hydrants", False)
End Sub
Public Sub Example_AutoAdd_ServiceLaterals()
Call AddLines("Water Mains", "Water Meters", True)
End Sub
Public Sub UseHighlightedLayers()

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pTest As Variant
Dim pSetLayers As ISet
Dim pLayer1 As ILayer
Dim pLayer2 As ILayer
Dim pFLayer1 As IFeatureLayer
Dim pFLayer2 As IFeatureLayer
Dim pFC1 As IFeatureClass
Dim pFC2 As IFeatureClass

Set pMxDoc = Application.Document

Set pMap = pMxDoc.FocusMap

' Verify that there are layers in the table on contents

If pMap.LayerCount < 3 Then

95
 MsgBox "Must have at least three layers in your map."
Exit Sub
End If

'Verify that two layers are selected in the TOC

Set pTest = pMxDoc.SelectedItem
If pTest Is Nothing Then
MsgBox "Please highlight two layers in the TOC."
Exit Sub
End If
If Not TypeOf pMxDoc.SelectedItem Is ISet Then
MsgBox "Please highlight two layers in the TOC."
Exit Sub
End If
Set pSetLayers = pMxDoc.SelectedItem
If pSetLayers.Count <> 2 Then
MsgBox "Please highlight only two layers in the TOC."
Exit Sub
End If

'Get each of these highlighted layers from the TOC

pSetLayers.Reset
Set pLayer1 = pSetLayers.Next
Set pLayer2 = pSetLayers.Next

'Verify that the highlighted layers are feature layers

If Not TypeOf pLayer1 Is IFeatureLayer Then
MsgBox pLayer1.Name & " is not a feature layer."
Exit Sub
End If
If Not TypeOf pLayer2 Is IFeatureLayer Then
MsgBox pLayer2.Name & " is not a feature layer."
Exit Sub
End If

'Get the feature layer and feature class pointers

Set pFLayer1 = pLayer1
Set pFLayer2 = pLayer2
Set pFC1 = pFLayer1.FeatureClass
Set pFC2 = pFLayer2.FeatureClass

'If the first highlighted layer is a line layer...

If pFC1.ShapeType = esriGeometryPolyline Or pFC1.ShapeType = esriGeometryLine Then

'Stop if the other layer is not a point layer

If pFC2.ShapeType <> esriGeometryPoint Then
MsgBox "You need a point layer and a line layer highlighted." & vbNewLine & _
"Neither of these should be your edit target."
Exit Sub
End If

'Otherwise, go ahead add run the AddLines routine

AddLines pLayer1.Name, pLayer2.Name, True

'If the first highlighted layer is a point layer...

ElseIf pFC1.ShapeType = esriGeometryPoint Then

'Stop if the other layer is not a line layer

If pFC2.ShapeType <> esriGeometryPolyline And pFC2.ShapeType <> esriGeometryLine Then
MsgBox "You need a point layer and a line layer highlighted." & vbNewLine & _
"Neither of these should be your edit target."
Exit Sub

96
 End If

'Otherwise, go ahead add run the AddLines routine

AddLines pLayer2.Name, pLayer1.Name, True

Else
MsgBox "You need a point layer and a line layer highlighted." & vbNewLine & _
"Neither of these should be your edit target."
Exit Sub
End If
End Sub

Public Sub AddLines(sLineLayer As String, sPointLayer As String, blnAllowDoubles As Boolean)

' Requires: must be editing; have some points selected; have target line layer set
' Optional: select one line to force new line(s) to be drawn to it

On Error GoTo EH

Dim pMxDoc As IMxDocument

Dim pMap As IMap
Dim pFLayerPoint As IFeatureLayer
Dim pFLayerLine As IFeatureLayer
Dim pFLayerLateral As IFeatureLayer
Dim pFCPoint As IFeatureClass
Dim pFCLine As IFeatureClass
Dim pFCLateral As IFeatureClass
Dim pFSelPoint As IFeatureSelection
Dim pFSelLine As IFeatureSelection
Dim pFCursorLine As IFeatureCursor
Dim pFeature As IFeature
Dim pFeatureLine As IFeature
Dim pGeometryPoint As IGeometry
Dim pGeometryLine As IGeometry
Dim pPolyLine As IPolyline
Dim pToPoint As IPoint
Dim pFromPoint As IPoint
Dim pApp As IApplication
Dim pId As New UID
Dim pEditor As IEditor
Dim pELayers As IEditLayers
Dim pNewFeature As IFeature
Dim lCount As Long
Dim pProxOpLine As IProximityOperator
Dim pRowSubtypes As IRowSubtypes
Dim pSubtypes As ISubtypes
Dim lSubCode As Long
Dim pEnumPointOIDs As IEnumIDs
Dim pLateral1 As IPolyline
Dim pLateral2 As IPolyline
Dim pSegCol As ISegmentCollection
Dim bHasSubtypes As Boolean
Dim lSelPointCount As Long
Dim pLineFeat1 As IFeature
Dim pLineFeat2 As IFeature
Dim pRelOp As IRelationalOperator

Set pApp = Application

Set pMxDoc = pApp.Document
Set pMap = pMxDoc.FocusMap

' Verify that there are layers in the table on contents

If pMap.LayerCount < 3 Then

97
 MsgBox "Must have at least three layers in your map."
Exit Sub
End If

Set pFLayerPoint = FindFLayerByName(pMap, sPointLayer)

Set pFLayerLine = FindFLayerByName(pMap, sLineLayer)

'Verify layers exisit

If pFLayerPoint Is Nothing Then
MsgBox sPointLayer & " layer not found."
Exit Sub
End If
If pFLayerLine Is Nothing Then
MsgBox sLineLayer & " layer not found."
Exit Sub
End If

Set pFCPoint = pFLayerPoint.FeatureClass

Set pFCLine = pFLayerLine.FeatureClass

'Verify that it is a correct type of geometry

If pFCPoint.ShapeType <> esriGeometryPoint Then
MsgBox pFCPoint.AliasName
MsgBox sPointLayer & " layer must be a point layer."
Exit Sub
End If
If pFCLine.ShapeType <> esriGeometryPolyline And pFCLine.ShapeType <> esriGeometryLine Then
MsgBox sLineLayer & " layer must be a line or polyline layer."
Exit Sub
End If

'Verify that some Points are selected

Set pFSelPoint = pFLayerPoint
Set pFSelLine = pFLayerLine
If pFSelPoint.SelectionSet.Count < 1 Then
MsgBox sPointLayer & " layer must have some features selected."
Exit Sub
End If

'Verify that we are editing

pId = "esriCore.Editor"
Set pEditor = pApp.FindExtensionByCLSID(pId)
If Not (pEditor.EditState = esriStateEditing) Then
MsgBox "Must be editing."
Exit Sub
End If

'Verify that the target is a polyline layer

Set pELayers = pEditor
If pELayers.CurrentLayer.FeatureClass.ShapeType <> esriGeometryPolyline Then
MsgBox "Edit target must be a polyline layer (i.e. laterals)."
Exit Sub
End If

'Get the target polyline layer

Set pFLayerLateral = pELayers.CurrentLayer
Set pFCLateral = pFLayerLateral.FeatureClass

'Verify that the target is not also the source line layer
If pFLayerLine Is pFLayerLateral Then
MsgBox "Target layer must be different than " & sLineLayer & " layer."
Exit Sub

98
 End If

'Get current target subtype

If TypeOf pFCLateral Is ISubtypes Then
Set pSubtypes = pFCLateral
If pSubtypes.HasSubtype Then
bHasSubtypes = True
lSubCode = pELayers.CurrentSubtype
Else
bHasSubtypes = False
End If
End If

'Update Message bar

pApp.StatusBar.Message(0) = "Adding " & pFLayerLateral.Name & " lines..."

'Start edit operation (for undo)

pEditor.StartOperation

On Error GoTo EH2

'Get the number of selected points

lSelPointCount = pFSelPoint.SelectionSet.Count

'Get list of selected point object ids

Set pEnumPointOIDs = pFSelPoint.SelectionSet.IDs

'Step through each selected point

For lCount = 1 To lSelPointCount

'Get the point feature

Set pFeature = pFCPoint.GetFeature(pEnumPointOIDs.Next)

'Update status bar

pApp.StatusBar.Message(0) = "Adding " & pFLayerLateral.Name & " lines..." & str(lCount) & " of " &
str(lSelPointCount)

'Get the "to" point for new line (start from selected point)
Set pGeometryPoint = pFeature.Shape
Set pToPoint = pGeometryPoint

'Get the selected line

If pFSelLine.SelectionSet.Count = 1 Then
pFSelLine.SelectionSet.Search Nothing, True, pFCursorLine
Set pFeatureLine = pFCursorLine.NextFeature
End If

'Or get closest line

If pFSelLine.SelectionSet.Count <> 1 Then
Set pFeatureLine = GetNearestFeature(pFeature, pFCLine)
End If

'If a line was found using either method, then process

If Not pFeatureLine Is Nothing Then

'Get geometry of existing line

Set pGeometryLine = pFeatureLine.Shape

'Create the "from" point for new line

Set pFromPoint = New Point
Set pProxOpLine = pGeometryLine
pProxOpLine.QueryNearestPoint pToPoint, esriNoExtension, pFromPoint

99
 'Create the new line
Set pPolyLine = New Polyline
pPolyLine.FromPoint = pFromPoint
pPolyLine.ToPoint = pToPoint

'If this is not a special double "pig-tail" line, add the line
If blnAllowDoubles = False Or lSelPointCount <> 2 Then 'Single Lateral
'Create a new feature in the target feature class
Set pNewFeature = pFCLateral.CreateFeature
'Set the shape of this new line feature
Set pNewFeature.Shape = pPolyLine
'If needed, set the subtype and default values
If bHasSubtypes Then
Set pRowSubtypes = pNewFeature
pRowSubtypes.SubtypeCode = lSubCode
pRowSubtypes.InitDefaultValues
End If
'Save the new line
pNewFeature.Store

Else 'Double lateral-------------------------------------------

'Store each of the two selected points for later processing

Select Case lCount
Case 1
Set pLineFeat1 = pFeatureLine 'Closest or Selected Line
Set pLateral1 = pPolyLine
Case 2

Set pLineFeat2 = pFeatureLine 'Closest or Selected Line

Set pLateral2 = pPolyLine

'If the two points have different closest lines

'use the one with the shortest distance for both points
Set pRelOp = pLineFeat2.Shape
If Not pRelOp.Equals(pLineFeat1.Shape) Then
If pLateral1.length < pLateral2.length Then
Set pProxOpLine = pLineFeat1.ShapeCopy
pProxOpLine.QueryNearestPoint pLateral2.ToPoint, esriNoExtension, pFromPoint
pLateral2.FromPoint = pFromPoint
Else
Set pProxOpLine = pLineFeat2.Shape
pProxOpLine.QueryNearestPoint pLateral1.ToPoint, esriNoExtension, pFromPoint
pLateral1.FromPoint = pFromPoint
End If
End If
Set pLateral2 = pPolyLine

End Select
End If '--------------------------------------------------------

'If line was not found...

Else
Debug.Print "Could not find closest line in " & sLineLayer
If pFeature.HasOID Then
Debug.Print "for feature OID = " & str(pFeature.OID)
End If
blnAllowDoubles = False
End If

'Process next selected point

100
Next lCount

'DOUBLE LATERAL ONLY -----------------------------------------------------

If blnAllowDoubles = True And lSelPointCount = 2 Then

Dim dMaxDist As Double
Dim dDist As Double
Dim pMainLine As IPolyline
Dim pMainMidPoint As IPoint
Dim pConstructEndPoint As IConstructPoint
Dim pTempPt1 As IPoint
Dim pTempPt2 As IPoint
Dim pConstTempPt1 As IConstructPoint
Dim pConstTempPt2 As IConstructPoint
Dim pCrossPiece As IPolyline
Dim pCrossMidpoint As IPoint
Dim pConstructpCrossMidpoint As IConstructPoint
Dim pEndPolyLine As IPolyline
Dim pEndSegColl As ISegmentCollection
Dim pEndSegment As ISegment
Dim pReturnPoint As IPoint
Dim pTempLine2 As IPolyline
Dim pTempLine As IPolyline

'First, determine the distance to the split...

'Find which lateral is shorter, use this as max distance

If pLateral1.length < pLateral2.length Then
dMaxDist = CInt(pLateral1.length)
Else
dMaxDist = CInt(pLateral2.length)
End If

'Max dist should be less than the available distance

dMaxDist = dMaxDist - 1

'Prompt user for desired distance

dDist = CDbl(InputBox("Enter distance to lateral split" & vbCrLf & _
"Max distance is " & dMaxDist, "Double Lateral"))

'Verify that this will work

If dDist < 0.01 Or dDist > dMaxDist Then 'use 1/2 the max dist
MsgBox "Input distance is not acceptable. Using " & dMaxDist / 2
dDist = dMaxDist \ 2
End If

'Draw a line along the main between the two perpendicular intersections
Set pMainLine = New Polyline
pMainLine.FromPoint = pLateral1.FromPoint
pMainLine.ToPoint = pLateral2.FromPoint

'Find the midpoint (this will be the start of the new line)
Set pMainMidPoint = New Point
Set pConstructEndPoint = pMainMidPoint
pConstructEndPoint.ConstructAlong pMainLine, 0, 0.5, True

'Create a point along each lateral line ddist from the main
Set pTempPt1 = New Point
Set pTempPt2 = New Point
Set pConstTempPt1 = pTempPt1
Set pConstTempPt2 = pTempPt2

101
 pConstTempPt1.ConstructAlong pLateral1, 0, dDist, False
pConstTempPt2.ConstructAlong pLateral2, 0, dDist, False

'Shorten the laterals to these new points

pLateral1.FromPoint = pTempPt1
pLateral2.FromPoint = pTempPt2

'Create a crosspiece between the laterals

Set pCrossPiece = New Polyline
pCrossPiece.FromPoint = pTempPt1
pCrossPiece.ToPoint = pTempPt2

'Create the midpoint of the cross piece

Set pCrossMidpoint = New Point
Set pConstructpCrossMidpoint = pCrossMidpoint
pConstructpCrossMidpoint.ConstructAlong pCrossPiece, 0, 0.5, True

'Create the line for the main trunk

Set pEndPolyLine = New Polyline
pEndPolyLine.FromPoint = pMainMidPoint
pEndPolyLine.ToPoint = pCrossMidpoint
Set pReturnPoint = New Point
Set pEndSegColl = pEndPolyLine
Set pEndSegment = pEndSegColl.Segment(pEndSegColl.SegmentCount - 1)
Set pReturnPoint = pProxOpLine.ReturnNearestPoint(pEndSegment.ToPoint, 0)
pEndPolyLine.FromPoint = pReturnPoint

'Build "U" portion of the line

pLateral1.ReverseOrientation
Set pSegCol = pLateral1
pSegCol.AddSegmentCollection pCrossPiece
pSegCol.AddSegmentCollection pLateral2

'Add "U" as the target line feature

Set pNewFeature = pFCLateral.CreateFeature
Set pNewFeature.Shape = pSegCol
'If needed, set the subtype and default values
If bHasSubtypes Then
Set pRowSubtypes = pNewFeature
pRowSubtypes.SubtypeCode = lSubCode
pRowSubtypes.InitDefaultValues
End If
pNewFeature.Store

'Add the main trunk for the double line

Set pNewFeature = pFCLateral.CreateFeature
Set pNewFeature.Shape = pEndPolyLine
'If needed, set the subtype and default values
If bHasSubtypes Then
Set pRowSubtypes = pNewFeature
pRowSubtypes.SubtypeCode = lSubCode
pRowSubtypes.InitDefaultValues
End If
pNewFeature.Store

End If
'END DOUBLE LATERAL ONLY--------------------------------------------------

'Stop feature editing

pEditor.StopOperation ("Auto Add Lines ")

'Clear all feature selections

102
 pMap.ClearSelection

'Redraw the map so you'll see the new lines

pMxDoc.ActiveView.Refresh

'MsgBox "Auto Add Lines is complete."

pApp.StatusBar.Message(0) = "Auto Add is complete."

Exit Sub
EH:

MsgBox Err.Number & " " & Err.Description

Exit Sub
EH2:
pEditor.AbortOperation
MsgBox Err.Number & " " & Err.Description
Exit Sub
End Sub

Public Function GetNearestFeature(pSrcFeature As IFeature, pSearchFeatureClass As IFeatureClass) As IFeature

Dim pFilter As ISpatialFilter
Dim sShapeField As String
Dim pCursor As IFeatureCursor
Dim pPoint As IPoint
Dim pSearchEnvelope As IEnvelope
Dim pPnt As IPoint
Dim pProxOp As IProximityOperator
Dim dMinDist As Double, dDist As Double
Dim pFeature As IFeature
Dim pSafePoint As IPoint
Dim pSourceFeaturePoint As IPoint

On Error GoTo ErrorHandler

If Not TypeOf pSrcFeature.Shape Is IPoint Then

Err.Raise vbObjectError, , "Source feature is not a Point."
End If

' Make search envelope

Set pSearchEnvelope = New Envelope
Set pPnt = New Point
pPnt.PutCoords 0, 0
pSearchEnvelope.LowerLeft = pPnt
pPnt.PutCoords 1000, 1000 ' cEnvelopeSize, cEnvelopeSize
pSearchEnvelope.UpperRight = pPnt
pSearchEnvelope.CenterAt pSrcFeature.Shape
' Setup the search
Set pFilter = New SpatialFilter
pFilter.SpatialRel = esriSpatialRelIntersects
Set pFilter.Geometry = pSearchEnvelope
sShapeField = pSearchFeatureClass.ShapeFieldName
pFilter.GeometryField = sShapeField
'Set pFilter.OutputSpatialReference(sShapeField) = m_pMap.SpatialReference
' Find all main line features within the search envelope
Set pSafePoint = New Point
Set pSourceFeaturePoint = pSrcFeature.Shape
pSafePoint.PutCoords pSourceFeaturePoint.X, pSourceFeaturePoint.Y
Set pProxOp = pSafePoint
Set pCursor = pSearchFeatureClass.Search(pFilter, False)
' Find the closest one to the source feature (point)
dMinDist = 500

103
 Set pFeature = pCursor.NextFeature
Do While (Not pFeature Is Nothing)
dDist = pProxOp.ReturnDistance(pFeature.ShapeCopy)
If dDist < dMinDist Then
Set GetNearestFeature = pFeature
dMinDist = dDist

End If
Set pFeature = pCursor.NextFeature
Loop

Exit Function
Resume
ErrorHandler:
MsgBox "Error: " & Err.Description, , "GetNearestFeature"
Set GetNearestFeature = Nothing
End Function

Public Function FindFLayerByName(pMap As IMap, sLayerName As String) As IFeatureLayer

'This function will return only feature layers.
'It can find feature layers within groups.

Dim pEnumLayer As IEnumLayer

Dim pCompositeLayer As ICompositeLayer
Dim i As Integer

Set pEnumLayer = pMap.Layers

pEnumLayer.Reset

Dim pLayer As ILayer

Set pLayer = pEnumLayer.Next

Do While Not pLayer Is Nothing

If TypeOf pLayer Is ICompositeLayer Then
Set pCompositeLayer = pLayer
For i = 0 To pCompositeLayer.Count - 1
With pCompositeLayer
If .Layer(i).Name = sLayerName Then
If TypeOf .Layer(i) Is IFeatureLayer Then
Set FindFLayerByName = pCompositeLayer.Layer(i)
Exit Function
End If
End If
End With
Next i
ElseIf pLayer.Name = sLayerName And TypeOf pLayer Is IFeatureLayer Then
Set FindFLayerByName = pLayer
Exit Function
End If
Set pLayer = pEnumLayer.Next
Loop

End Function

104