XY坐标文本转换为FeatureClass存储到Geodatabase的VB源代码

XY坐标文本转换为FeatureClass存储到Geodatabase的VB源码整理。

把xyz的文本转换成一个featureclass到一个存在的geodatabase

Private Sub cmdOk_Click()
If txtShp.Text = "" Then
MsgBox "请设置SHP文件的存放路径!", vbExclamation, App.Title & "--" & "错误提示"
Exit Sub
End If

On Error GoTo ErrHandle
Me.MousePointer = vbArrowHourglass
Dim pIniFields As IFields
Set pIniFields = New Fields
Dim pIniFieldsEdit As IFieldsEdit
Set pIniFieldsEdit = pIniFields
pIniFieldsEdit.FieldCount = 3
Dim pIniField As IField
Dim pIniFieldEdit As IFieldEdit
Set pIniField = New Field
Set pIniFieldEdit = pIniField
With pIniFieldEdit
.Name = "OBJECTID"
.AliasName = "FID"
.Type = esriFieldTypeOID
End With
Set pIniFieldsEdit.Field(0) = pIniField

Dim pGeoDef As IGeometryDef
Dim pGeoDefEdit As IGeometryDefEdit
Set pGeoDef = New GeometryDef
Set pGeoDefEdit = pGeoDef

Set pIniField = New Field
Set pIniFieldEdit = pIniField
pGeoDefEdit.GeometryType = esriGeometryPoint
With pGeoDefEdit
.AvgNumPoints = 5
.GridCount = 2
.GridSize(0) = 200
.GridSize(1) = 500
.HasM = False
.HasZ = False
End With
If optSR.Item(0).value = True Then
Dim pSpatialRefFactory As ISpatialReferenceFactory
Dim pSpatialRef As ISpatialReference
Dim pProCoordSys As IProjectedCoordinateSystem
Set pSpatialRefFactory = New SpatialReferenceEnvironment
Set pProCoordSys = pSpatialRefFactory.CreateProjectedCoordinateSystem(esriSRProjCS_Xian1980_GK_CM_117E)
Set pSpatialRef = pProCoordSys \'QI
Set pGeoDefEdit.SpatialReference = pSpatialRef
End If
With pIniFieldEdit
.Name = "SHAPE"
.Type = esriFieldTypeGeometry
Set .GeometryDef = pGeoDef
.IsNullable = True
.Required = True
End With
Set pIniFieldsEdit.Field(1) = pIniField

Set pIniField = New Field
Set pIniFieldEdit = pIniField
With pIniFieldEdit
.Name = "点名"
.AliasName = "点名"
.Type = esriFieldTypeString
.Length = 30
End With
Set pIniFieldsEdit.Field(2) = pIniField

Set pFeatCls = basFunction.CreateFeatureClassAtLocationByFields(pIniFields, sShpPath, sShpName)
Dim pPt As IPoint
Set fso = New FileSystemObject
Dim txtStream As textStream
Set txtStream = fso.OpenTextFile(txtPath.Text, ForReading)
Dim iPtName As Integer
Dim iX As Integer: Dim iY As Integer
Dim sLine As String
sLine = txtStream.ReadLine
Dim sFld() As String
sFld = Split(sLine, Chr(9))
Dim i As Integer
For i = 0 To UBound(sFld)
If sFld(i) = "点名" Then
iPtName = i
End If
If sFld(i) = cboX.Text Then
iX = i
End If
If sFld(i) = cboY.Text Then
iY = i
End If
Next
Dim pFeat As IFeature
Do While txtStream.AtEndOfStream <> True
Set pPt = New Point
sLine = txtStream.ReadLine
Set pFeat = pFeatCls.CreateFeature
sFld = Split(sLine, Chr(9))
pPt.X = Val(sFld(iX))
pPt.Y = Val(sFld(iY))
Set pFeat.Shape = pPt
pFeat.value(pFeat.Fields.FindField("点名")) = sFld(iPtName)
pFeat.Store
Loop
txtStream.Close
Set txtStream = Nothing
Set fso = Nothing
Set pPt = Nothing
Set pFeat = Nothing
Dim sAnswer As String
sAnswer = MsgBox("操作成功,把该图层加入地图窗口?", vbYesNo, App.Title & "--" & "是否加载该图层")
If sAnswer = vbYes Then
Dim pOutFeatureWKS As IFeatureWorkspace
Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pOutFeatureWKS = pWorkspaceFactory.OpenFromFile(sShpPath, 0)
Dim pOutFCS As IFeatureClass
Set pOutFCS = pOutFeatureWKS.OpenFeatureClass(sShpName)
If pOutFCS Is Nothing Then
Me.MousePointer = vbDefault
MsgBox "加载失败!", vbCritical, App.Title & "--" & "错误处理"
Unload Me
End If
Dim pFeatureLayer As IFeatureLayer
Set pFeatureLayer = New FeatureLayer
pFeatureLayer.Name = pOutFCS.AliasName
Set pFeatureLayer.FeatureClass = pOutFCS
Call AddLyrToMapByType(pFeatureLayer, m_MainMapWindow)
Set pWorkspaceFactory = Nothing
Set pFeatureLayer = Nothing
Set pOutFeatureWKS = Nothing
End If
Me.MousePointer = vbDefault
Unload Me

Exit Sub

ErrHandle:
Me.MousePointer = vbDefault
Set fso = Nothing
MsgBox Err.Description & Err.Number, vbCritical, App.Title & "--" & "错误处理"
Exit Sub


End Sub