ArcGIS加载创建shapefile文件,并导入点

Public name, path As String

Private Sub CheckBox1_Click()

drawing = "point"

UserForm1.Hide

End Sub

Private Sub CheckBox2_Click()

drawing = "find"

UserForm1.Hide

End Sub

Private Sub CommandButton1_Click()

Dim pFeature As IFeature

Dim pFeatureLayer As IFeatureLayer

Dim pMxDocument As IMxDocument

Dim pMap As IMap

Dim pPoint As IPoint

Dim pFeatClass As IFeatureClass

Dim a, b As Integer, x, y, z As Double

Dim c, name As String

CommonDialog1.Action = 1

CommonDialog1.InitDir = "d:\\"

CommonDialog1.Filter = "GPS(*.txt)|*.txt|all files(*.*)|*.*"

CommonDialog1.FilterIndex = 1

TextBox2.Text = CommonDialog1.FileName

Open CommonDialog1.FileName For Input As #1

a = 0

Do While Not EOF(1)

Line Input #1, inputdata

c = inputdata

GPS = Split(c, 

'lenth = Len(c)

'n = InStr(c, 

'name = Left(c, n - 1)

'r = Right(c, lenth - n)

'n = InStr(r, 

'y = Val(Left(r, n - 1))

'lenth = Len(r)

'r = Right(r, lenth - n)

'n = InStr(r, 

'x = Val(Left(r, n - 1))

'r = Right(r, lenth - n)

'lenth = Len(r)

'n = InStr(r, 

'r = Right(r, lenth - n)

'z = Val(r)

Set pMxDocument = Application.Document

Set pMap = pMxDocument.FocusMap

Set pFeatureLayer = pMap.Layer(0)

Set pFeatClass = pFeatureLayer.FeatureClass

Set pFeature = pFeatClass.CreateFeature

Set pPoint = New Point

pPoint.PutCoords GPS(2), GPS(1)

Set pFeature.Shape = pPoint

pFeature.Value(2) = GPS(0)

pFeature.Value(3) = GPS(2)

pFeature.Value(4) = GPS(1)

pFeature.Value(5) = GPS(3)

pFeature.Store

Loop

Close #1

UserForm1.Hide

pMxDocument.ActivatedView.Refresh

End Sub

Private Sub CommandButton2_Click()

Dim pFeatureWorkspace As IFeatureWorkspace

Dim pWorkspaceFactory As IWorkspaceFactory

Dim pFields As IFields

Dim pFieldsEdit As IFieldsEdit

Dim pField As IField

Dim pFieldEdit As IFieldEdit

Dim pGeometryDef As IGeometryDef

Dim pGeometryDefEdit As IGeometryDefEdit

Dim pSpatialFilter As ISpatialFilter

Dim pFeature As IFeature

Dim pFeatureLayer As IFeatureLayer

Dim pMxDocument As IMxDocument

Dim pMap As IMap

Dim pPoint As IPoint

Dim pFeatClass As IFeatureClass

'Dim pActiveView As IActiveView

Dim sShapeFieldName As String

Dim sNewShapeFileName As String

Dim sFilePath As String

Dim sFileName As String

Dim i As Integer

sFilePath = path

sFileName = name

'On Error GoTo ErrorHandler:

sNewShapeFileName = Dir(sFilePath & sFileName & ".shp")

If (sNewShapeFileName <> "") Then

MsgBox ("文件已经存在")

Exit Sub

End If

sShapeFieldName = "Shape"

'Open the folder to contain the shapefile as a workspace

Set pWorkspaceFactory = New ShapefileWorkspaceFactory

Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0)

'Set up a simple fields collection

Set pFields = New Fields

Set pFieldsEdit = pFields

'Make the shape field

'it will need a geometry definition, with a spatial reference

Set pField = New Field

Set pFieldEdit = pField

pFieldEdit.name = sShapeFieldName

pFieldEdit.Type = esriFieldTypeGeometry

Set pGeometryDef = New GeometryDef

Set pGeometryDefEdit = pGeometryDef

With pGeometryDefEdit

.GeometryType = esriGeometryPoint

Set .SpatialReference = New UnknownCoordinateSystem

End With

Set pFieldEdit.GeometryDef = pGeometryDef

pFieldsEdit.AddField pField

'Add others miscellaneous text field

Set pField = New Field

Set pFieldEdit = pField

With pFieldEdit

.name = "Name"

.Type = esriFieldTypeString

.Editable = True

'.Precision = 2

End With

pFieldsEdit.AddField pField

Set pField = New Field

Set pFieldEdit = pField

With pFieldEdit

.name = "x"

.Type = esriFieldTypeDouble

.Editable = True

End With

pFieldsEdit.AddField pField

Set pField = New Field

Set pFieldEdit = pField

With pFieldEdit

.name = "y"

.Type = esriFieldTypeDouble

.Editable = True

'.Precision = 2

End With

pFieldsEdit.AddField pField

Set pField = New Field

Set pFieldEdit = pField

With pFieldEdit

.name = "z"

.Type = esriFieldTypeDouble

.Editable = True

End With

pFieldsEdit.AddField pField

'Create the shapefile

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

Set pFeatClass = pFeatureWorkspace.CreateFeatureClass _

(sFileName, pFields, Nothing, Nothing, _

esriFTSimple, sShapeFieldName, "")

sNewShapeFileName = Dir(sFilePath & "\\MyShapeFile.shp")

If (sNewShapeFileName = "") Then

MsgBox ("Build Success")

Else

MsgBox ("Build Fail")

End If

'Exit Sub

Set pFeatureLayer = New FeatureLayer

Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(sFileName)

pFeatureLayer.name = pFeatureLayer.FeatureClass.AliasName

'Add the FeatureLayer to the focus map

Set pMxDocument = Application.Document

Set pMap = pMxDocument.FocusMap

pMap.AddLayer pFeatureLayer

'Set pMxDocument = Application.Document

'Set pMap = pMxDocument.FocusMap

End Sub

Private Sub CommandButton3_Click()

Dim po As Integer, fname As String

po = 0

TextBox1.Text = ""

TextBox2.Text = ""

CommonDialog1.Action = 2

CommonDialog1.Filter = "all files(*.*)|*.*"

TextBox1.Text = CommonDialog1.FileName

fname = CommonDialog1.FileName

Do While che < 1

po = po + 1

name = Right(fname, po)

che = Left(InStr(Right(fname, po), "\\"), 1)

Loop

name = Right(name, Len(name) - 1)

path = Left(fname, InStr(fname, name) - 1)

End Sub

Modules

Public drawing As String

thisdocument

Private Sub UIButtonControl1_Click()

UserForm1.Show

End Sub

Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)

  If drawing = "point" Then

  Dim pMxDoc As IMxDocument

  Dim pMap As IMap

  Dim pActiveView As IActiveView

  Dim pScreenDisplay As IScreenDisplay

  Dim pPoint As IPoint

  Dim pFeatureLayer As IFeatureLayer

  Dim pFeatClass As IFeatureClass

  Dim pFeature As IFeature

  Static n As Integer

  n = n + 1

  Set pMxDoc = Application.Document

  Set pMap = pMxDoc.FocusMap

  Set pActiveView = pMxDoc.FocusMap

  Set pScreenDisplay = pActiveView.ScreenDisplay

  With pScreenDisplay

    .StartDrawing pScreenDisplay.hDC, esriNoScreenCache

    .SetSymbol New SimpleMarkerSymbol

    .DrawPoint pMxDoc.CurrentLocation

    .FinishDrawing

  End With

  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)

  Set pFeatureLayer = pMap.Layer(0)

  Set pFeatClass = pFeatureLayer.FeatureClass

  Set pFeature = pFeatClass.CreateFeature

  pPoint.PutCoords pPoint.x, pPoint.y

  Set pFeature.Shape = pPoint

  pFeature.Value(2) = "GPS" & n

  pFeature.Value(3) = pPoint.x

  pFeature.Value(4) = pPoint.y

  pFeature.Store

  pMxDoc.ActivatedView.Refresh

 ElseIf drawing = "find" Then

  Set pMxDoc = Application.Document

  Set pActiveView = pMxDoc.FocusMap

  'Create a search point

  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)

  'Pass the point to the FindFeature function along with the Map and search tolerance

  Set pFeature = FindFeature(pMxDoc.SearchTolerance, pPoint, pMxDoc.FocusMap)

  'Message box the feature ID and feature class alias name

  If Not pFeature Is Nothing Then MsgBox pFeature.OID & " " & pFeature.Class.AliasName

End If

End Sub

Private Function FindFeature(SearchTol As Double, pPoint As IPoint, pMap As IMap) As IFeature

  Dim pEnvelope As IEnvelope

  Dim pSpatialFilter As ISpatialFilter

  Dim pEnumLayer As IEnumLayer

  Dim pFeatureLayer As IFeatureLayer

  Dim pFeatureClass As IFeatureClass

  Dim pFeatureCursor As IFeatureCursor

  Dim pFeature As IFeature

  Dim pUID As New UID

  Dim ShapeFieldName As String

  If pMap.LayerCount = 0 Then Exit Function

  'Expand the points envelope to give better search results

  Set pEnvelope = pPoint.Envelope

  pEnvelope.Expand SearchTol, SearchTol, False

  'Create a new spatial filter and use the new envelope as the geometry

  Set pSpatialFilter = New SpatialFilter

  Set pSpatialFilter.Geometry = pEnvelope

  pSpatialFilter.SpatialRel = esriSpatialRelIntersects

  'Search each selectable feature layer for a feature

  'Return the first feature found

  pUID = "{40A9E885-5533-11D0-98BE-00805F7CED21}" 'IFeatureLayer

  Set pEnumLayer = pMap.Layers(pUID, False)

  pEnumLayer.Reset

  Set pFeatureLayer = pEnumLayer.Next

  Do While Not pFeatureLayer Is Nothing

    'Only search the selectable layers

    If pFeatureLayer.Selectable Then

      ShapeFieldName = pFeatureLayer.FeatureClass.ShapeFieldName

      Set pSpatialFilter.OutputSpatialReference(ShapeFieldName) = pMap.SpatialReference

      pSpatialFilter.GeometryField = pFeatureLayer.FeatureClass.ShapeFieldName

      Set pFeatureClass = pFeatureLayer.FeatureClass

      Set pFeatureCursor = pFeatureClass.Search(pSpatialFilter, False)  'Do the search

      Set pFeature = pFeatureCursor.NextFeature  'Get the first feature

      If Not pFeature Is Nothing Then

        Set FindFeature = pFeature  'Exit if feature is valid

        Exit Do

      End If

    End If

    Set pFeatureLayer = pEnumLayer.Next

  Loop

End Function