sklobe25
08-13-2010, 08:38 AM
I am trying to run a user created VB of the web but am getting a Compile Error: User-defined type not defined @ the highlighting the pink text in the script below. I am very new to all of this, any thoughts?
Private Sub comboLayers_Change()
Frame1.Enabled = True
Frame2.Enabled = True
optChull.Enabled = True
optRect.Enabled = True
optRectBuff.Enabled = True
optchullbuff.Enabled = True
optSquareBuff.Enabled = True
Label3.Enabled = True
chkSelected.Enabled = True
CommandButton2.Enabled = True
End Sub
Private Sub CommandButton2_Click()
''
''
''--------------- INSTRUCTIONS --------------
'' (c) Dr. M. Sawada 2002 msawada@uottawa.ca
'' This program creates a polygon shapefile cointaining the convex hull of a set of points or the
'' convex envelope (minimum bounding) and adds it to the current dataframe. The polygon shapefile
'' is created in the current projection (coordinate-system) of the dataframe.
''
'' Associate (load) this form with a UIButtonControl in ArcMap.
'' use the code
'' ''
'' load frmConvexHull
'' frmConvexHull.show
''---------------------------------------------------------------------
'
'' Get user selected point shapefile
Dim theindex As Double, thelay As Double
theindex = comboLayers.ListIndex
If theindex = -1 Then
MsgBox "There are no point layers or you have not selected a point layer.", , "Convex hull"
Exit Sub
Else
thelay = comboindex.List(theindex)
End If
'
'' Get map and active layer
Dim theimx As IMxDocument
Dim theimap As IMap
Dim theilayer As ILayer
Dim thefeaturelayer As IFeatureLayer
Set theimx = ThisDocument
Set theimap = theimx.FocusMap
Set theilayer = theimap.Layer(thelay) 'theimx.SelectedLayer
Set thefeaturelayer = theilayer
If thefeaturelayer Is Nothing Then
MsgBox "Error.", , "Convex Hull"
Exit Sub
End If
'' get layer name
theilayername = theilayer.Name
'
'Set up the projection for the new shapefile to the existing data frame projection
Dim pSR As ISpatialReference
Set pSR = theimap.SpatialReference
'
'' Get all records or selected records and then get the first one in theifeature
Dim theIFeatureSelection As IFeatureSelection
Set theIFeatureSelection = thefeaturelayer
Dim theISelectionSet As ISelectionSet
Set theISelectionSet = theIFeatureSelection.SelectionSet
Dim theifcursor2 As IFeatureCursor
If chkSelected.Value Then
theISelectionSet.Search Nothing, False, theifcursor2
If theISelectionSet.Count = 0 Then 'select all features
Set theifcursor2 = thefeaturelayer.Search(Nothing, False)
End If
Else
Set theifcursor2 = thefeaturelayer.Search(Nothing, False)
End If
Dim theifeature2 As IFeature
Set theifeature2 = theifcursor2.NextFeature
Dim theIPointTest As IPoint
'
'' Set up multipoint for constructing convex hull and/or rectangle
Dim theIMultiPoint As IMultipoint
Set theIMultiPoint = New Multipoint
Dim thePointCollection As IPointCollection
Set thePointCollection = theIMultiPoint
Dim theigeometry As IGeometry
'
'' Loop through each point, project it and add it to the pointcollection for use in chull calculation
Do While Not theifeature2 Is Nothing
Set theigeometry = theifeature2.Shape
theigeometry.Project pSR
Set theIPointTest = theigeometry 'theifeature2.Shape
thePointCollection.AddPoint theIPointTest
Set theifeature2 = theifcursor2.NextFeature
Loop
'
'' Make sure that there is more than one point selected.
If thePointCollection.PointCount < 2 Then
MsgBox "There are less than 2 points or less than 2 points selected. Cannot create convex hull or envelope polygon.", , "Convex Hull"
Exit Sub
End If
'
'' Set up for getting the convex hull of the points and get its area and length
Dim theitopo As ITopologicalOperator ' FOR CREATION OF CHULL
Set theitopo = theIMultiPoint ' WHAT THEITOPO WILL OPERATE ON
Dim theigeomchull As IGeometry 'TO HOLD CHULL RETURN FROM THEITOPO.CONVEXHULL
Dim theIArea As IArea 'TO GET AREA OF CHULL
Dim theIcurve As ICurve 'TO GET PERIMITER OF CHULL
Dim thearea As Double
Dim theperim As Double
' Check Buffer Distance
Dim BUFFDIST As Double
If Not IsNumeric(TXTBUFFDIST.Text) Then
MsgBox "Buffer distance must be a number.", , "Convex Hull"
Exit Sub
Else
BUFFDIST = CDbl(TXTBUFFDIST.Text)
End If
'
'' Get the envelope of the multipoint and create a polygon from its boundaries
Dim thenv As IEnvelope
Set thenv = theIMultiPoint.Envelope
If optSquareBuff Then thenv.Expand BUFFDIST, BUFFDIST, False
Dim dXmin As Double, dYmin As Double, dXmax As Double, dYmax As Double
thenv.QueryCoords dXmin, dYmin, dXmax, dYmax
Dim p(0 To 4) As IPoint
For i = 0 To 4
Set p(i) = New Point
Next i
p(0).PutCoords dXmin, dYmin
p(1).PutCoords dXmin, dYmax
p(2).PutCoords dXmax, dYmax
p(3).PutCoords dXmax, dYmin
p(4).PutCoords dXmin, dYmin
Dim pPolygonPointColl As IPointCollection
Set pPolygonPointColl = New Polygon
pPolygonPointColl.AddPoints 5, p(0)
'
'' Determine based on user input which type of polygon will be ouput.
Dim xnt As IPolygon
If optRect Or optSquareBuff Then
Set theigeomchull = pPolygonPointColl
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
ElseIf optRectBuff Then
Set theigeomchull = pPolygonPointColl
Set theitopo = theigeomchull
Set theigeomchull = theitopo.buffer(BUFFDIST)
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
ElseIf optChull Then
Set theigeomchull = theitopo.ConvexHull
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
ElseIf optchullbuff Then
Set theigeomchull = theitopo.ConvexHull
Set theitopo = theigeomchull
Set theigeomchull = theitopo.buffer(BUFFDIST)
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
End If
'
'
'' call the make polygon shapefile function
Call makeshapefile(theigeomchull, pSR, theilayername, thearea, theperim)
'
'' Memory cleanup
Set theimx = Nothing
Set theimap = Nothing
Set theilayer = Nothing
Set thefeaturelayer = Nothing
Set pSR = Nothing
Set theIFeatureSelection = Nothing
Set theISelectionSet = Nothing
Set theifcursor2 = Nothing
Set theifeature2 = Nothing
Set theIMultiPoint = Nothing
Set thePointCollection = Nothing
Set thePointCollection = Nothing
Set theigeometry = Nothing
Set theIPointTest = Nothing
Set theifeature2 = Nothing
Set theitopo = Nothing
Set theigeomchull = Nothing
Set theIArea = Nothing
Set theIcurve = Nothing
'' Unload the form after shapefile is created
Unload frmConvexHull
frmConvexHull.Hide
End Sub
Public Function makeshapefile(thePolyGeometry As IGeometry, pSR As ISpatialReference, theilayername, thearea As Double, theperim As Double)
On Error GoTo EH
Dim tFileName As String, tFilePath As String, tPath As String
Dim pGxObject As IGxObject
Dim pGxDialog As IGxDialog
Dim pGxFilter As IGxObjectFilter
Set pGxDialog = New GxDialog
Set pGxFilter = New GxFilterShapefiles
Set pGxDialog.ObjectFilter = pGxFilter
pGxDialog.AllowMultiSelect = False
pGxDialog.ButtonCaption = "Click to Save Polygon Shapefile"
pGxDialog.Title = "Enter shapefile name to save convex polygon"
pGxDialog.Name = "chull_" & theilayername
If pGxDialog.DoModalSave(0) Then
Set pGxObject = pGxDialog.FinalLocation
Else
Exit Function 'user cancelled operation
End If
'pGxDialog.DoModalSave ThisDocument.Parent.hWnd
If pGxDialog.ReplacingObject Then
MsgBox "Create a new filename", , "Convex Hull"
Exit Function
End If
'
''------- GET FILE NAME AND OUTPUT FILE --------
tFileName = pGxDialog.Name
tFilePath = pGxObject.FullName
'Dim pFSO As Object, sFCName As String
' sFCName = tFilePath & "\" & tFileName
' Set pFSO = CreateObject("Scripting.FileSystemObject")
' If pFSO.FileExists(sFCName) Then
' MsgBox "Select different name for the new shapefile.", vbInformation, "File of same name exists."
' Exit Function
'End If
Dim strfolder As String
Dim strname As String ' Dont include .shp extension
Const strShapeFieldName As String = "Shape"
strfolder = tFilePath
strname = tFileName
' 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 = esriGeometryPolygon
Set .SpatialReference = pSR 'New UnknownCoordinateSystem
End With
Set pFieldEdit.GeometryDef = pGeomDef
pFieldsEdit.AddField pField
' Add another miscellaneous text field
Set pField = New esriCore.Field
Set pFieldEdit = pField
With pFieldEdit
.Length = 30
.Name = "Descrip"
.Type = esriFieldTypeString
End With
pFieldsEdit.AddField pField
Set pField = New esriCore.Field
Set pFieldEdit = pField
With pFieldEdit
.Type = esriFieldTypeDouble
.Name = "Area"
.Precision = 20
.Scale = 10
End With
pFieldsEdit.AddField pField
Set pField = New esriCore.Field
Set pFieldEdit = pField
With pFieldEdit
.Type = esriFieldTypeDouble
.Name = "Perim"
.Precision = 20
.Scale = 10
End With
pFieldsEdit.AddField pField
' Create the shapefile
' (some parameters apply to geodatabase options and can be defaulted as Nothing)
Dim theIFeatureClass As IFeatureClass
Set theIFeatureClass = pFWS.CreateFeatureClass(strname, pFields, Nothing, _
Nothing, esriFTSimple, strShapeFieldName, "")
Dim theFeatureCursor As IFeatureCursor
Set theFeatureCursor = theIFeatureClass.Search(Nothing, False)
Dim theIfeature As IFeature
Set theIfeature = theIFeatureClass.CreateFeature
Set theIfeature.Shape = thePolyGeometry
theIfeature.Store
dindex = theIfeature.Fields.FindField("descrip")
theIfeature.Value(dindex) = "Convex hull from layer " & theilayername
theIfeature.Store
aindex = theIfeature.Fields.FindField("Area")
theIfeature.Value(aindex) = thearea
theIfeature.Store
pindex = theIfeature.Fields.FindField("perim")
theIfeature.Value(pindex) = theperim
theIfeature.Store
Call AddShapeFile(strfolder, strname)
Exit Function
EH:
MsgBox Err.Description, vbInformation, "createShapefile"
End Function
Private Function AddShapeFile(strfolder As String, strname As String)
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
Dim pFeatureLayer As IFeatureLayer
Dim pMxDocument As IMxDocument
Dim pMap As IMap
'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strfolder, 0)
'Create a new FeatureLayer and assign a shapefile to it
Set pFeatureLayer = New FeatureLayer
Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(strname)
pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
'Add the FeatureLayer to the focus map
Set pMxDocument = Application.Document
Set pMap = pMxDocument.FocusMap
pMap.AddLayer pFeatureLayer
End Function
Private Sub CommandButton3_Click()
MsgBox "Professor M. Sawada <msawada@aix1.uottawa.ca>", , "Convex Hull"
End Sub
Private Sub CommandButton4_Click()
Unload frmConvexHull
frmConvexHull.Hide
End Sub
Private Sub optChull_Click()
TXTBUFFDIST.Enabled = False
End Sub
Private Sub optchullbuff_Click()
If optChull.Value = F And optRect.Value = F Then
TXTBUFFDIST.Enabled = True
End If
If Not (optChull.Value = F Or optRect.Value = F) Then
TXTBUFFDIST.Enabled = False
End If
End Sub
Private Sub optRect_Click()
TXTBUFFDIST.Enabled = False
End Sub
Private Sub optRectBuff_Click()
If optChull.Value = F And optRect.Value = F Then
TXTBUFFDIST.Enabled = True
End If
If Not (optChull.Value = F Or optRect.Value = F) Then
TXTBUFFDIST.Enabled = False
End If
End Sub
Private Sub optSquareBuff_Click()
If optChull.Value = F And optRect.Value = F Then
TXTBUFFDIST.Enabled = True
End If
If Not (optChull.Value = F Or optRect.Value = F) Then
TXTBUFFDIST.Enabled = False
End If
End Sub
Private Sub UserForm_Initialize()
Dim pMxDocument As IMxDocument
Dim pMap As IMap
Dim pEnumLayer As IEnumLayer
Dim pLayer As ILayer
Dim pId As New UID
Set pMxDocument = Application.Document
Set pMap = pMxDocument.FocusMap
If pMap Is Nothing Then
MsgBox "Activate a Data Frame.", , "Convex Hull"
Exit Sub
End If
If pMxDocument.ActivatedView.FocusMap.LayerCount = 0 Then
MsgBox "You have no layers in your Data Frame. Add a layer.", , "Convex Hull"
Exit Sub
End If
pId = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}"
Set pEnumLayer = pMap.Layers(pId, True)
pEnumLayer.Reset
Set pLayer = pEnumLayer.Next
counter = 0
Dim tf As IFeatureLayer
Dim tfclass As IFeatureClass
Do While Not pLayer Is Nothing
Set tf = pLayer
Set tfclass = tf.FeatureClass
If tfclass.ShapeType = esriGeometryPoint Then
comboLayers.AddItem pLayer.Name ', counter
comboindex.AddItem counter
End If
Set pLayer = pEnumLayer.Next
counter = counter + 1
Loop
'
'
Set pMap = Nothing
Set pMxDocument = Nothing
Set pEnumLayer = Nothing
Set pLayer = Nothing
Set tf = Nothing
Set tfclass = Nothing
End Sub
Private Sub comboLayers_Change()
Frame1.Enabled = True
Frame2.Enabled = True
optChull.Enabled = True
optRect.Enabled = True
optRectBuff.Enabled = True
optchullbuff.Enabled = True
optSquareBuff.Enabled = True
Label3.Enabled = True
chkSelected.Enabled = True
CommandButton2.Enabled = True
End Sub
Private Sub CommandButton2_Click()
''
''
''--------------- INSTRUCTIONS --------------
'' (c) Dr. M. Sawada 2002 msawada@uottawa.ca
'' This program creates a polygon shapefile cointaining the convex hull of a set of points or the
'' convex envelope (minimum bounding) and adds it to the current dataframe. The polygon shapefile
'' is created in the current projection (coordinate-system) of the dataframe.
''
'' Associate (load) this form with a UIButtonControl in ArcMap.
'' use the code
'' ''
'' load frmConvexHull
'' frmConvexHull.show
''---------------------------------------------------------------------
'
'' Get user selected point shapefile
Dim theindex As Double, thelay As Double
theindex = comboLayers.ListIndex
If theindex = -1 Then
MsgBox "There are no point layers or you have not selected a point layer.", , "Convex hull"
Exit Sub
Else
thelay = comboindex.List(theindex)
End If
'
'' Get map and active layer
Dim theimx As IMxDocument
Dim theimap As IMap
Dim theilayer As ILayer
Dim thefeaturelayer As IFeatureLayer
Set theimx = ThisDocument
Set theimap = theimx.FocusMap
Set theilayer = theimap.Layer(thelay) 'theimx.SelectedLayer
Set thefeaturelayer = theilayer
If thefeaturelayer Is Nothing Then
MsgBox "Error.", , "Convex Hull"
Exit Sub
End If
'' get layer name
theilayername = theilayer.Name
'
'Set up the projection for the new shapefile to the existing data frame projection
Dim pSR As ISpatialReference
Set pSR = theimap.SpatialReference
'
'' Get all records or selected records and then get the first one in theifeature
Dim theIFeatureSelection As IFeatureSelection
Set theIFeatureSelection = thefeaturelayer
Dim theISelectionSet As ISelectionSet
Set theISelectionSet = theIFeatureSelection.SelectionSet
Dim theifcursor2 As IFeatureCursor
If chkSelected.Value Then
theISelectionSet.Search Nothing, False, theifcursor2
If theISelectionSet.Count = 0 Then 'select all features
Set theifcursor2 = thefeaturelayer.Search(Nothing, False)
End If
Else
Set theifcursor2 = thefeaturelayer.Search(Nothing, False)
End If
Dim theifeature2 As IFeature
Set theifeature2 = theifcursor2.NextFeature
Dim theIPointTest As IPoint
'
'' Set up multipoint for constructing convex hull and/or rectangle
Dim theIMultiPoint As IMultipoint
Set theIMultiPoint = New Multipoint
Dim thePointCollection As IPointCollection
Set thePointCollection = theIMultiPoint
Dim theigeometry As IGeometry
'
'' Loop through each point, project it and add it to the pointcollection for use in chull calculation
Do While Not theifeature2 Is Nothing
Set theigeometry = theifeature2.Shape
theigeometry.Project pSR
Set theIPointTest = theigeometry 'theifeature2.Shape
thePointCollection.AddPoint theIPointTest
Set theifeature2 = theifcursor2.NextFeature
Loop
'
'' Make sure that there is more than one point selected.
If thePointCollection.PointCount < 2 Then
MsgBox "There are less than 2 points or less than 2 points selected. Cannot create convex hull or envelope polygon.", , "Convex Hull"
Exit Sub
End If
'
'' Set up for getting the convex hull of the points and get its area and length
Dim theitopo As ITopologicalOperator ' FOR CREATION OF CHULL
Set theitopo = theIMultiPoint ' WHAT THEITOPO WILL OPERATE ON
Dim theigeomchull As IGeometry 'TO HOLD CHULL RETURN FROM THEITOPO.CONVEXHULL
Dim theIArea As IArea 'TO GET AREA OF CHULL
Dim theIcurve As ICurve 'TO GET PERIMITER OF CHULL
Dim thearea As Double
Dim theperim As Double
' Check Buffer Distance
Dim BUFFDIST As Double
If Not IsNumeric(TXTBUFFDIST.Text) Then
MsgBox "Buffer distance must be a number.", , "Convex Hull"
Exit Sub
Else
BUFFDIST = CDbl(TXTBUFFDIST.Text)
End If
'
'' Get the envelope of the multipoint and create a polygon from its boundaries
Dim thenv As IEnvelope
Set thenv = theIMultiPoint.Envelope
If optSquareBuff Then thenv.Expand BUFFDIST, BUFFDIST, False
Dim dXmin As Double, dYmin As Double, dXmax As Double, dYmax As Double
thenv.QueryCoords dXmin, dYmin, dXmax, dYmax
Dim p(0 To 4) As IPoint
For i = 0 To 4
Set p(i) = New Point
Next i
p(0).PutCoords dXmin, dYmin
p(1).PutCoords dXmin, dYmax
p(2).PutCoords dXmax, dYmax
p(3).PutCoords dXmax, dYmin
p(4).PutCoords dXmin, dYmin
Dim pPolygonPointColl As IPointCollection
Set pPolygonPointColl = New Polygon
pPolygonPointColl.AddPoints 5, p(0)
'
'' Determine based on user input which type of polygon will be ouput.
Dim xnt As IPolygon
If optRect Or optSquareBuff Then
Set theigeomchull = pPolygonPointColl
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
ElseIf optRectBuff Then
Set theigeomchull = pPolygonPointColl
Set theitopo = theigeomchull
Set theigeomchull = theitopo.buffer(BUFFDIST)
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
ElseIf optChull Then
Set theigeomchull = theitopo.ConvexHull
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
ElseIf optchullbuff Then
Set theigeomchull = theitopo.ConvexHull
Set theitopo = theigeomchull
Set theigeomchull = theitopo.buffer(BUFFDIST)
Set theIArea = theigeomchull
thearea = theIArea.Area
Set theIcurve = theigeomchull
theperim = theIcurve.Length
End If
'
'
'' call the make polygon shapefile function
Call makeshapefile(theigeomchull, pSR, theilayername, thearea, theperim)
'
'' Memory cleanup
Set theimx = Nothing
Set theimap = Nothing
Set theilayer = Nothing
Set thefeaturelayer = Nothing
Set pSR = Nothing
Set theIFeatureSelection = Nothing
Set theISelectionSet = Nothing
Set theifcursor2 = Nothing
Set theifeature2 = Nothing
Set theIMultiPoint = Nothing
Set thePointCollection = Nothing
Set thePointCollection = Nothing
Set theigeometry = Nothing
Set theIPointTest = Nothing
Set theifeature2 = Nothing
Set theitopo = Nothing
Set theigeomchull = Nothing
Set theIArea = Nothing
Set theIcurve = Nothing
'' Unload the form after shapefile is created
Unload frmConvexHull
frmConvexHull.Hide
End Sub
Public Function makeshapefile(thePolyGeometry As IGeometry, pSR As ISpatialReference, theilayername, thearea As Double, theperim As Double)
On Error GoTo EH
Dim tFileName As String, tFilePath As String, tPath As String
Dim pGxObject As IGxObject
Dim pGxDialog As IGxDialog
Dim pGxFilter As IGxObjectFilter
Set pGxDialog = New GxDialog
Set pGxFilter = New GxFilterShapefiles
Set pGxDialog.ObjectFilter = pGxFilter
pGxDialog.AllowMultiSelect = False
pGxDialog.ButtonCaption = "Click to Save Polygon Shapefile"
pGxDialog.Title = "Enter shapefile name to save convex polygon"
pGxDialog.Name = "chull_" & theilayername
If pGxDialog.DoModalSave(0) Then
Set pGxObject = pGxDialog.FinalLocation
Else
Exit Function 'user cancelled operation
End If
'pGxDialog.DoModalSave ThisDocument.Parent.hWnd
If pGxDialog.ReplacingObject Then
MsgBox "Create a new filename", , "Convex Hull"
Exit Function
End If
'
''------- GET FILE NAME AND OUTPUT FILE --------
tFileName = pGxDialog.Name
tFilePath = pGxObject.FullName
'Dim pFSO As Object, sFCName As String
' sFCName = tFilePath & "\" & tFileName
' Set pFSO = CreateObject("Scripting.FileSystemObject")
' If pFSO.FileExists(sFCName) Then
' MsgBox "Select different name for the new shapefile.", vbInformation, "File of same name exists."
' Exit Function
'End If
Dim strfolder As String
Dim strname As String ' Dont include .shp extension
Const strShapeFieldName As String = "Shape"
strfolder = tFilePath
strname = tFileName
' 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 = esriGeometryPolygon
Set .SpatialReference = pSR 'New UnknownCoordinateSystem
End With
Set pFieldEdit.GeometryDef = pGeomDef
pFieldsEdit.AddField pField
' Add another miscellaneous text field
Set pField = New esriCore.Field
Set pFieldEdit = pField
With pFieldEdit
.Length = 30
.Name = "Descrip"
.Type = esriFieldTypeString
End With
pFieldsEdit.AddField pField
Set pField = New esriCore.Field
Set pFieldEdit = pField
With pFieldEdit
.Type = esriFieldTypeDouble
.Name = "Area"
.Precision = 20
.Scale = 10
End With
pFieldsEdit.AddField pField
Set pField = New esriCore.Field
Set pFieldEdit = pField
With pFieldEdit
.Type = esriFieldTypeDouble
.Name = "Perim"
.Precision = 20
.Scale = 10
End With
pFieldsEdit.AddField pField
' Create the shapefile
' (some parameters apply to geodatabase options and can be defaulted as Nothing)
Dim theIFeatureClass As IFeatureClass
Set theIFeatureClass = pFWS.CreateFeatureClass(strname, pFields, Nothing, _
Nothing, esriFTSimple, strShapeFieldName, "")
Dim theFeatureCursor As IFeatureCursor
Set theFeatureCursor = theIFeatureClass.Search(Nothing, False)
Dim theIfeature As IFeature
Set theIfeature = theIFeatureClass.CreateFeature
Set theIfeature.Shape = thePolyGeometry
theIfeature.Store
dindex = theIfeature.Fields.FindField("descrip")
theIfeature.Value(dindex) = "Convex hull from layer " & theilayername
theIfeature.Store
aindex = theIfeature.Fields.FindField("Area")
theIfeature.Value(aindex) = thearea
theIfeature.Store
pindex = theIfeature.Fields.FindField("perim")
theIfeature.Value(pindex) = theperim
theIfeature.Store
Call AddShapeFile(strfolder, strname)
Exit Function
EH:
MsgBox Err.Description, vbInformation, "createShapefile"
End Function
Private Function AddShapeFile(strfolder As String, strname As String)
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
Dim pFeatureLayer As IFeatureLayer
Dim pMxDocument As IMxDocument
Dim pMap As IMap
'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strfolder, 0)
'Create a new FeatureLayer and assign a shapefile to it
Set pFeatureLayer = New FeatureLayer
Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(strname)
pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
'Add the FeatureLayer to the focus map
Set pMxDocument = Application.Document
Set pMap = pMxDocument.FocusMap
pMap.AddLayer pFeatureLayer
End Function
Private Sub CommandButton3_Click()
MsgBox "Professor M. Sawada <msawada@aix1.uottawa.ca>", , "Convex Hull"
End Sub
Private Sub CommandButton4_Click()
Unload frmConvexHull
frmConvexHull.Hide
End Sub
Private Sub optChull_Click()
TXTBUFFDIST.Enabled = False
End Sub
Private Sub optchullbuff_Click()
If optChull.Value = F And optRect.Value = F Then
TXTBUFFDIST.Enabled = True
End If
If Not (optChull.Value = F Or optRect.Value = F) Then
TXTBUFFDIST.Enabled = False
End If
End Sub
Private Sub optRect_Click()
TXTBUFFDIST.Enabled = False
End Sub
Private Sub optRectBuff_Click()
If optChull.Value = F And optRect.Value = F Then
TXTBUFFDIST.Enabled = True
End If
If Not (optChull.Value = F Or optRect.Value = F) Then
TXTBUFFDIST.Enabled = False
End If
End Sub
Private Sub optSquareBuff_Click()
If optChull.Value = F And optRect.Value = F Then
TXTBUFFDIST.Enabled = True
End If
If Not (optChull.Value = F Or optRect.Value = F) Then
TXTBUFFDIST.Enabled = False
End If
End Sub
Private Sub UserForm_Initialize()
Dim pMxDocument As IMxDocument
Dim pMap As IMap
Dim pEnumLayer As IEnumLayer
Dim pLayer As ILayer
Dim pId As New UID
Set pMxDocument = Application.Document
Set pMap = pMxDocument.FocusMap
If pMap Is Nothing Then
MsgBox "Activate a Data Frame.", , "Convex Hull"
Exit Sub
End If
If pMxDocument.ActivatedView.FocusMap.LayerCount = 0 Then
MsgBox "You have no layers in your Data Frame. Add a layer.", , "Convex Hull"
Exit Sub
End If
pId = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}"
Set pEnumLayer = pMap.Layers(pId, True)
pEnumLayer.Reset
Set pLayer = pEnumLayer.Next
counter = 0
Dim tf As IFeatureLayer
Dim tfclass As IFeatureClass
Do While Not pLayer Is Nothing
Set tf = pLayer
Set tfclass = tf.FeatureClass
If tfclass.ShapeType = esriGeometryPoint Then
comboLayers.AddItem pLayer.Name ', counter
comboindex.AddItem counter
End If
Set pLayer = pEnumLayer.Next
counter = counter + 1
Loop
'
'
Set pMap = Nothing
Set pMxDocument = Nothing
Set pEnumLayer = Nothing
Set pLayer = Nothing
Set tf = Nothing
Set tfclass = Nothing
End Sub