'函数功能： 将矢量要素导入到指定数据库的数据集中，可以将shapefile，dxf，coverage格式导入倒GEodatabase中
' 参数表：
' pInDatasetNameCol 一个存储要导入的矢量要素（IFeatureClassName类型）的Collection对象
' pOutNameCol 一个存储导入的矢量要素名称（string类型）的Collection对象
' strGDBPath 包含矢量要素数据集名称的GDB路径，如“D:\world\Map3D.mdb”
'****************************************************************
Public Function convFeatureClass(pInDatasetNameCol As Collection, pOutNameCol As Collection, strGDBPath As String)
'获得导入数据的数目
Dim iInFCNum As Integer
iInFCNum = pInDatasetNameCol.Count
'获得输出的数据库名和数据集名
Dim sOutFDSName As String
Dim sOutGDBName As String
sOutFDSName = GetPathName(strGDBPath, 1)
sOutGDBName = GetPathName(strGDBPath, 0)
'获得输出要素集的IFeatureDatasetName
Dim pWSF As IWorkspaceFactory
Set pWSF = New AccessWorkspaceFactory
Dim pWS As IWorkspace
Set pWS = pWSF.OpenFromFile(sOutGDBName, 0)
Dim pOutFeatureWS As IFeatureWorkspace
Set pOutFeatureWS = pWS
'获得输出要素集的Dataset Name
Dim pOutFDSName As IFeatureDatasetName
Dim pOutFDS As IFeatureDataset
Set pOutFDS = pOutFeatureWS.OpenFeatureDataset(sOutFDSName)
Set pOutFDSName = pOutFDS.FullName
Dim i As Integer
For i = 1 To iInFCNum
Dim pOutPropertySet As IPropertySet
Set pOutPropertySet = New PropertySet
pOutPropertySet.SetProperty "DATASET", sOutGDBName
Dim pOutWorkspaceName As IWorkspaceName
Set pOutWorkspaceName = New WorkspaceName
pOutWorkspaceName.ConnectionProperties = pOutPropertySet
pOutWorkspaceName.WorkspaceFactoryProgID = "esriDataSourcesGDB.AccessWorkspaceFactory.1"
'设置输出要素的FeatureClass Name
Dim pOutFCName As IFeatureClassName
Set pOutFCName = New FeatureClassName
Dim pDatasetName As IDatasetName
Set pDatasetName = pOutFCName
Set pDatasetName.WorkspaceName = pOutWorkspaceName
pDatasetName.name = pOutNameCol.Item(i)
'获得输入要素的FeatureClass Name
Dim pInDatasetName As IDatasetName
Set pInDatasetName = pInDatasetNameCol.Item(i)
'判断是否有重名现象
Dim pWS2 As IWorkspace2
Set pWS2 = pWS
'如果名称已存在
If pWS2.NameExists(esriDTFeatureClass, pDatasetName.name) Then
Dim R
R = MsgBox("矢量要素" & pDatasetName.name & "在数据库中已存在!" & Chr(13) & "是否覆盖?", vbExclamation + vbYesNo)
'覆盖原矢量要素
If R = vbYes Then
Dim pFWS As IFeatureWorkspace
Set pFWS = pWS
Dim pDataset As IDataset
Set pDataset = pFWS.OpenFeatureClass(pDatasetName.name)
pDataset.Delete
Set pFWS = Nothing
Set pDataset = Nothing
'不覆盖,则退出for循环,忽略这个要素,转入下一个要素的导入
Else
GoTo NextStep
End If
Set pWS2 = Nothing
End If
'打开Table获得Fields
Dim pname As IName
Dim pInTable As ITable
Set pname = pInDatasetName
Set pInTable = pname.Open
Dim pInFields As IFields
Set pInFields = pInTable.Fields
'检查Field Name
Dim pFieldChecker As IFieldChecker
Set pFieldChecker = New FieldChecker
Dim pOutFields As IFields
pFieldChecker.Validate pInFields, Nothing, pOutFields
'对Fields进行循环查，查找Geometry域
Dim j As Integer
Dim pGeoField As IField
For j = 0 To pOutFields.FieldCount - 1
If pOutFields.Field(j).Type = esriFieldTypeGeometry Then
Set pGeoField = pOutFields.Field(j)
Exit For
End If
Next j
'获得Geometry Field的GeometryDef
Dim pOutFCGeoDef As IGeometryDef
Set pOutFCGeoDef = pGeoField.GeometryDef
'设置GeometryDef的GridCount，GridSize，SpatialReference
Dim pOutFCGeoDefEdit As IGeometryDefEdit
Set pOutFCGeoDefEdit = pOutFCGeoDef
pOutFCGeoDefEdit.GridCount = 1
pOutFCGeoDefEdit.GridSize(0) = DefaultIndexGrid(pInTable)
Dim re
'判断空间参考是否一致，全局变量m_SpatialRef是创建的矢量要素集的空间参考
If m_SpatialRef.name <> pGeoField.GeometryDef.SpatialReference.name Then
re = MsgBox(pInDatasetName.name & "的空间参考与数据库中的矢量要素集空间参考不符！" & Chr(13) _
& "导入后会丢失数据。 是否继续导入？", vbYesNo + vbExclamation)
Set pOutFCGeoDefEdit.SpatialReference = m_SpatialRef
If re = vbNo Then
GoTo NextStep
End If
Else
Set pOutFCGeoDefEdit.SpatialReference = pGeoField.GeometryDef.SpatialReference
End If
'+++++++++++++++++++
'Set pOutFCGeoDefEdit.SpatialReference = pGeoField.GeometryDef.SpatialReference
'进行导入
Dim pConverter As IFeatureDataConverter
Set pConverter = New FeatureDataConverter
pConverter.ConvertFeatureClass pInDatasetNameCol.Item(i), Nothing, pOutFDSName, pOutFCName, pOutFCGeoDef, pOutFields, "", 1000, 0
Set pOutPropertySet = Nothing
Set pOutWorkspaceName = Nothing
Set pOutFCName = Nothing
Set pDatasetName = Nothing
Set pInDatasetName = Nothing
Set pname = Nothing
Set pInTable = Nothing
Set pFieldChecker = Nothing
Set pOutFields = Nothing
Set pGeoField = Nothing
Set pOutFCGeoDef = Nothing
Set pConverter = Nothing
NextStep:
Next i
Set pWSF = Nothing
Set pWS = Nothing
End Function