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

Userform1Public name, path As StringPrivate Sub CheckBox1_Click()drawing = pointUserForm1.HideEnd SubPrivate Sub CheckBox2_Click()drawing = findUserForm1.HideEnd SubPrivate Sub CommandButton1_Click()Dim pFeature As IFeatureDim pFeatureLayer As IFeatureLayerDim pMxDocument As IMxDocumentDim pMap As IMapDim pPoint As IPointDim pFeatClass As IFeatureClassDim a, b As Integer, x, y, z As DoubleDim c, name As StringCommonDialog1.Action = 1CommonDialog1.InitDir = d:CommonDialog1.Filter = GPS(*.txt)|*.txt|all files(*.*)|*.*CommonDialog1.FilterIndex = 1TextBox2.Text = CommonDialog1.FileNameOpen CommonDialog1.FileName For Input As #1a = 0Do While Not EOF(1)Line Input #1, inputdatac = inputdataGPS = 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.DocumentSet pMap = pMxDocument.FocusMapSet pFeatureLayer = pMap.Layer(0)Set pFeatClass = pFeatureLayer.FeatureClassSet pFeature = pFeatClass.CreateFeatureSet pPoint = New PointpPoint.PutCoords GPS(2), GPS(1)Set pFeature.Shape = pPointpFeature.Value(2) = GPS(0)pFeature.Value(3) = GPS(2)pFeature.Value(4) = GPS(1)pFeature.Value(5) = GPS(3)pFeature.StoreLoopClose #1UserForm1.HidepMxDocument.ActivatedView.RefreshEnd SubPrivate Sub CommandButton2_Click()Dim pFeatureWorkspace As IFeatureWorkspaceDim pWorkspaceFactory As IWorkspaceFactoryDim pFields As IFieldsDim pFieldsEdit As IFieldsEditDim pField As IFieldDim pFieldEdit As IFieldEditDim pGeometryDef As IGeometryDefDim pGeometryDefEdit As IGeometryDefEditDim pSpatialFilter As ISpatialFilterDim pFeature As IFeatureDim pFeatureLayer As IFeatureLayerDim pMxDocument As IMxDocumentDim pMap As IMapDim pPoint As IPointDim pFeatClass As IFeatureClassDim pActiveView As IActiveViewDim sShapeFieldName As StringDim sNewShapeFileName As StringDim sFilePath As StringDim sFileName As StringDim i As IntegersFilePath = pathsFileName = nameOn Error GoTo ErrorHandler:sNewShapeFileName = Dir(sFilePath & sFileName & .shp)If (sNewShapeFileName ) ThenMsgBox (文件已经存在)Exit SubEnd IfsShapeFieldName = ShapeOpen the folder to contain the shapefile as a workspaceSet pWorkspaceFactory = New ShapefileWorkspaceFactorySet pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0)Set up a simple fields collectionSet pFields = New FieldsSet pFieldsEdit = pFieldsMake the shape fieldit will need a geometry definition, with a spatial referenceSet pField = New FieldSet pFieldEdit = pFieldpFieldE = sShapeFieldNamepFieldEdit.Type = esriFieldTypeGeometrySet pGeometryDef = New GeometryDefSet pGeometryDefEdit = pGeometryDefWith pGeometryDefEdit.GeometryType = esriGeometryPointSet .SpatialReference = New UnknownCoordinateSystemEnd WithSet pFieldEdit.GeometryDef = pGeometryDefpFieldsEdit.AddField pFieldAdd others miscellaneous text fieldSet pField = New FieldSet pFieldEdit = pFieldWith pFieldE = Name.Type = esriFieldTypeString.Editable = True.Precision = 2End WithpFieldsEdit.AddField pFieldSet pField = New FieldSet pFieldEdit = pFieldWith pFieldE = x.Type = esriFieldTypeDouble.Editable = TrueEnd WithpFieldsEdit.AddField pFieldSet pField = New FieldSet pFieldEdit = pFieldWith pFieldE = y.Type = esriFieldTypeDouble.Editable = True.Precision = 2End WithpFieldsEdit.AddField pFieldSet pField = New FieldSet pFieldEdit = pFieldWith pFieldE = z.Type = esriFieldTypeDouble.Editable = TrueEnd WithpFieldsEdit.AddField pFieldCreate 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 = ) ThenMsgBox (Build Success)ElseMsgBox (Build Fail)End IfExit SubSet pFeatureLayer = New FeatureLayerSet pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(sFileName)pFeatureL = pFeatureLayer.FeatureClass.AliasNameAdd the FeatureLayer to the focus mapSet pMxDocument = Application.DocumentSet pMap = pMxDocument.FocusMappMap.AddLayer pFeatureLayerSet pMxDocument = Application.DocumentSet pMap = pMxDocument.FocusMapEnd SubPrivate Sub CommandButton3_Click()Dim po As Integer, fname As Stringpo = 0TextBox1.Text = TextBox2.Text = CommonDialog1.Action = 2CommonDialog1.Filter = all files(*.*)|*.*TextBox1.Text = CommonDialog1.FileNamefname = CommonDialog1.FileNameDo While che 1po = po + 1name = Right(fname, po)che = Left(InStr(Right(fname, po), ), 1)Loopname = Right(name, Len(name) - 1)path = Left(fname, InStr(fname, name) - 1)End SubModulesPublic drawing As StringthisdocumentPrivate Sub UIButtonControl1_Click()UserForm1.ShowEnd SubPrivate 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.AliasNameEnd IfEnd SubPrivate 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 = 40A