bastrans.bas

Shape 坐标转换程序 Shape 坐标转换程序

    AddReport "正在创建Shape数据文件！创建时间：" & Now
    Dim pOutFeatureLayer As IFeatureLayer
    Dim pFields As IFields
    Dim pFieldsEdit As IFieldsEdit
    Dim pFieldEdit As IFieldEdit
    Set pFields = New Fields
    Set pFieldsEdit = pFields
    Dim i As Long
    Dim pField As IField
    For i = 0 To pInFeatureClass.Fields.FieldCount - 1
        Set pField = pInFeatureClass.Fields.Field(i)
        If InStr(pField.Name, ".") < 1 And pField.Type <> esriFieldTypeOID And pField.Type <> esriFieldTypeBlob And pField.Type <> esriFieldTypeGeometry Then
            pFieldsEdit.AddField pField
        End If
    Next i
    
    '图形信息
    Dim lGeomIndex As Integer, pGeometryDef As IGeometryDef
    lGeomIndex = pInFeatureClass.Fields.FindField(pInFeatureClass.ShapeFieldName)
    Set pField = pInFeatureClass.Fields.Field(lGeomIndex)
    Set pGeometryDef = pField.GeometryDef
    Set pField = New esriGeoDatabase.Field
    Set pFieldEdit = pField
    pFieldEdit.Name = "SHAPE"
    pFieldEdit.Type = esriFieldTypeGeometry
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    Set pGeomDef = New GeometryDef
    Set pGeomDefEdit = pGeomDef
    With pGeomDefEdit
        .GeometryType = pInFeatureClass.ShapeType
        Set .SpatialReference = mpsFPcs
        .GridCount = pGeometryDef.GridCount
        .HasM = pGeometryDef.HasM
        .HasZ = pGeometryDef.HasZ
    End With
    Set pFieldEdit.GeometryDef = pGeomDef
    pFieldsEdit.AddField pField   '增加字段信息
    
    Set pOutFeatureLayer = New FeatureLayer
    Set pOutFeatureLayer.SpatialReference = mpsFPcs '设置图层的投影
    '创建shape文件
    Set pOutFeatureLayer.FeatureClass = pFWS.CreateFeatureClass(FileName, pFields, Nothing, Nothing, esriFTSimple, strShapeFieldName, "")
    If FCount > 0 Then
        Dim pOutFeatureClass As IFeatureClass
        Set pOutFeatureClass = pOutFeatureLayer.FeatureClass
        Dim pFeatureCursor As IFeatureCursor
        Dim pFilter As IQueryFilter
        Set pFilter = New QueryFilter
        Set pFeatureCursor = pInFeatureClass.Search(pFilter, False)  '得到所有要素的集合
        Dim pFeature As IFeature
        Set pFeature = pFeatureCursor.NextFeature  '得到第一个要素
        Dim pInsertFeatureBuffer As IFeatureBuffer
        Dim pInsertFeatureCursor As IFeatureCursor
        Dim pwe As IWorkspaceEdit
        Set pwe = pFWS
        pwe.StartEditing True        '开始写入
        pwe.StartEditOperation
        Set pInsertFeatureCursor = pOutFeatureClass.Insert(True)
        Set pInsertFeatureBuffer = pOutFeatureClass.CreateFeatureBuffer
        Dim j As Long
        j = 1
        Do While Not pFeature Is Nothing
            If pProgDlg.HasCanceled Then  '如果取消，将退出循环
                Exit Do
            End If
            pProgDlg.Message = "正在处理第" & j & "行数据 "
            pProgDlg.Step
            CopyAttribute pFeature, pInsertFeatureBuffer  '复制要素的属性
    '        pFeature.Shape.Project pOutSpatialReference
            
            Set pInsertFeatureBuffer.Shape = pFeature.Shape   '写入图形信息
            pInsertFeatureBuffer.Shape.Project mpsFPcs ' 对要素进行投影
            pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
            Set pFeature = pFeatureCursor.NextFeature  '下一要素
            j = j + 1
        Loop
        pwe.StopEditOperation
        pwe.StopEditing True  '停止写入，保存
        Set pwe = Nothing
    End If
    AddReport "文件" & FileName & "坐标转换完成！时间：" & Now
    pProgDlg.HideDialog   '隐藏进度条
    Set pProgDlg = Nothing
 
    Exit Sub
err:
    pProgDlg.HideDialog
    Set pProgDlg = Nothing
    AddReport "坐标转换完成过程出错！原因：" & err.Description & "，时间：" & Now

End Sub

'
'*******************************************************
'函数名称：DefineGeoToGeotrans
'函数描述：实现自定义地理参考之间的转换
'参数说明：pInFeatureLayer：要转换的图层，strFolder：目标文件夹，FileName：目标文件名 ，pNewSpatialReference：要转换到的空间参考 ,lNo:投影的带号
'返回值：
'*******************************************************
Public Sub DefineGeoToGeotrans(pInFeatureLayer As IFeatureLayer, strFolder As String, FileName As String)
On Error GoTo err
    Dim psr As IUnknownCoordinateSystem
    Set psr = New UnknownCoordinateSystem
    Const strShapeFieldName As String = "Shape"     '定义shape文件
    Dim pFWS As IFeatureWorkspace
    Dim pWorkspaceFactory As IWorkspaceFactory
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFWS = pWorkspaceFactory.OpenFromFile(strFolder, 0) '打开文件
    Dim pWorkspace As IWorkspace
    Set pWorkspace = pFWS
    Dim pEnum As IEnumDataset
    Set pEnum = pWorkspace.Datasets(esriDTFeatureClass)
    Dim pDataset As IDataset
    Set pDataset = pEnum.Next   '得到第一个数据集
    Do While Not pDataset Is Nothing
        If UCase(pDataset.Name) = UCase(FileName) Then
            If MsgBox("当前目录下目标数据已经存在，是否要覆盖？", vbYesNo + vbQuestion, "提示") = vbNo Then
                Set pDataset = Nothing
                Set pFWS = Nothing
                Set pWorkspace = Nothing
                Set pWorkspaceFactory = Nothing
                Exit Sub
            Else
                pDataset.Delete '删除文件
                Exit Do
            End If
        End If
        Set pDataset = pEnum.Next
    Loop
    '得到feature的数量
    Dim pInFeatureClass As IFeatureClass
    Set pInFeatureClass = pInFeatureLayer.FeatureClass
    Dim pQFilt As IQueryFilter
    Set pQFilt = New QueryFilter '设置过滤条件
    Dim FCount As Long
    FCount = pInFeatureClass.FeatureCount(pQFilt)
    If FCount = 0 Then
        MsgBox "此shape文件要素为空,不需要进行坐标转换!", vbInformation + vbOKOnly, "系统"
        Exit Sub
    End If
     '加进度条
    Set pProgDlg = New GWMescLib.CGWProgressDialog
    pProgDlg.Animation = 0
    pProgDlg.CancelEnabled = True
    pProgDlg.Title = "shape文件坐标转换"
    pProgDlg.Description = "正在转换" & FileName & "文件"
    pProgDlg.MinValue = 0
    pProgDlg.MaxValue = FCount
    pProgDlg.StepValue = 1
    pProgDlg.Scrolling = 0
    pProgDlg.ShowDialog
    pProgDlg.Message = "正在进创建shape文件..."
    AddReport "正在创建Shape数据文件！创建时间：" & Now
    Dim pOutFeatureLayer As IFeatureLayer
    Dim pFields As IFields
    Dim pFieldsEdit As IFieldsEdit
    Dim pFieldEdit As IFieldEdit
    Set pFields = New Fields
    Set pFieldsEdit = pFields
    Dim i As Long
    Dim pField As IField
    For i = 0 To pInFeatureClass.Fields.FieldCount - 1
        Set pField = pInFeatureClass.Fields.Field(i)
        If InStr(pField.Name, ".") < 1 And pField.Type <> esriFieldTypeOID And pField.Type <> esriFieldTypeBlob And pField.Type <> esriFieldTypeGeometry Then
            pFieldsEdit.AddField pField
        End If
    Next i
    
    '图形信息
    Dim lGeomIndex As Integer, pGeometryDef As IGeometryDef
    lGeomIndex = pInFeatureClass.Fields.FindField(pInFeatureClass.ShapeFieldName)
    Set pField = pInFeatureClass.Fields.Field(lGeomIndex)
    Set pGeometryDef = pField.GeometryDef
    Set pField = New esriGeoDatabase.Field
    Set pFieldEdit = pField
    pFieldEdit.Name = "SHAPE" '图形字段
    pFieldEdit.Type = esriFieldTypeGeometry
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    Set pGeomDef = New GeometryDef
    Set pGeomDefEdit = pGeomDef
    With pGeomDefEdit
        .GeometryType = pInFeatureClass.ShapeType
        Set .SpatialReference = psr
        .GridCount = pGeometryDef.GridCount
        .HasM = pGeometryDef.HasM
        .HasZ = pGeometryDef.HasZ
    End With
    Set pFieldEdit.GeometryDef = pGeomDef
    pFieldsEdit.AddField pField
    
    Set pOutFeatureLayer = New FeatureLayer
    Set pOutFeatureLayer.SpatialReference = psr  '设置空间参考
    '创建文件
    Set pOutFeatureLayer.FeatureClass = pFWS.CreateFeatureClass(FileName, pFields, Nothing, Nothing, esriFTSimple, strShapeFieldName, "")

    Dim pOutFeatureClass As IFeatureClass
    Set pOutFeatureClass = pOutFeatureLayer.FeatureClass
    Dim pFeatureCursor As IFeatureCursor
    Dim pFilter As IQueryFilter  '过滤条件
    Set pFilter = New QueryFilter
    Set pFeatureCursor = pInFeatureClass.Search(pFilter, False) '查找所有的要素
    Dim pFeature As IFeature
    Set pFeature = pFeatureCursor.NextFeature
    Dim pInsertFeatureBuffer As IFeatureBuffer
    Dim pInsertFeatureCursor As IFeatureCursor
    Dim pwe As IWorkspaceEdit
    Set pwe = pFWS
    pwe.StartEditing True  '停止编辑
    pwe.StartEditOperation
    Set pInsertFeatureCursor = pOutFeatureClass.Insert(True)
    Set pInsertFeatureBuffer = pOutFeatureClass.CreateFeatureBuffer
    Dim j As Long
    j = 1
    Do While Not pFeature Is Nothing
        If pProgDlg.HasCanceled Then
            Exit Do
        End If
        pProgDlg.Message = "正在处理第" & j & "行数据 "
        pProgDlg.Step
        CopyAttribute pFeature, pInsertFeatureBuffer '拷贝属性
'        pFeature.Shape.Project pOutSpatialReference
        
        Set pInsertFeatureBuffer.Shape = getOutDefGeometry(pFeature)
        pInsertFeatureBuffer.Shape.Project psr ' 对要素进行投影
        pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
        Set pFeature = pFeatureCursor.NextFeature  '下一要素
        j = j + 1
    Loop
    AddReport "文件" & FileName & "坐标转换完成！时间：" & Now
    pProgDlg.HideDialog  '隐藏进度条
    Set pProgDlg = Nothing
    pwe.StopEditOperation
    pwe.StopEditing True '停止编辑
    Set pwe = Nothing
    Exit Sub
err:
    pProgDlg.HideDialog
    Set pProgDlg = Nothing
    AddReport "坐标转换完成过程出错！原因：" & err.Description & "，时间：" & Now

End Sub
'
'*******************************************************
'函数名称：getOutGeometry
'函数描述：得到转换后的shape
'参数说明：pInFeature：转换前的要素
'返回值：返回转换后的Geometry
'*******************************************************
Public Function getOutGeometry(pInFeature As IFeature) As IGeometry
On Error GoTo err
    Dim pInGeometry  As IGeometry
    Set pInGeometry = pInFeature.Shape
    If TypeOf pInGeometry Is IPoint Then     '如果是点层
        Dim pInPoint As IPoint
        Set pInPoint = New Point
        Set pInPoint = pInGeometry
        Set getOutGeometry = PointTrans(pInPoint)
    ElseIf TypeOf pInGeometry Is IPolyline Then '如果是线层
        Dim pInPolyline As IPolyline
        Set pInPolyline = New Polyline
        Set pInPolyline = pInGeometry
        Set getOutGeometry = PolylineTrans(pInPolyline)
    ElseIf TypeOf pInGeometry Is IPolygon Then '如果是面层
        Dim pInPolygon As IPolygon
        Set pInPolygon = New Polygon
        Set pInPolygon = pInGeometry
        Set getOutGeometry = PolygonTrans(pInPolygon)
    End If
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'*******************************************************
'函数名称：getOutDefGeometry
'函数描述：自定义得到转换后的shape
'参数说明：pInFeature：转换前的要素
'返回值：返回转换后的Geometry
'*******************************************************
Public Function getOutDefGeometry(pInFeature As IFeature) As IGeometry
On Error GoTo err
    Dim pInGeometry  As IGeometry
    Set pInGeometry = pInFeature.Shape
    If TypeOf pInGeometry Is IPoint Then  '点层
        Dim pInPoint As IPoint
        Set pInPoint = New Point
        Set pInPoint = pInGeometry
        Set getOutDefGeometry = PointDefTrans(pInPoint)  '
    ElseIf TypeOf pInGeometry Is IPolyline Then   '线层
        Dim pInPolyline As IPolyline
        Set pInPolyline = New Polyline
        Set pInPolyline = pInGeometry
        Set getOutDefGeometry = PolylineDefTrans(pInPolyline)
    ElseIf TypeOf pInGeometry Is IPolygon Then  '面层
        Dim pInPolygon As IPolygon
        Set pInPolygon = New Polygon
        Set pInPolygon = pInGeometry
        Set getOutDefGeometry = PolygonDefTrans(pInPolygon)
    End If
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function