bastrans.bas

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

Attribute VB_Name = "basTrans"





Public g_bIsGeo As Boolean  '是否是地理坐标之间的转换
Public g_bIsTo54 As Boolean  '是否向54参考转换
Public pProgDlg As New GWMescLib.CGWProgressDialog '进度条
Public ReportNum As Long

'*******************************************************
'函数名称：CopyAttribute
'函数描述：拷贝字段的属性
'参数说明：pSourceFeature：原要素  pDestinationFeature：暂时存储要素
'返回值：
'*******************************************************
Public Sub CopyAttribute(pSourceFeature As IFeature, pDestinationFeature As IFeatureBuffer)
On Error GoTo ErrorHandler
  Dim pField As IField, i As Integer
  Dim pFields As IFields
  Dim FieldCount As Integer   '字段数量
  Set pFields = pSourceFeature.Fields  '得到字段集合
  For FieldCount = 0 To pFields.FieldCount - 1
      Set pField = pFields.Field(FieldCount)
      If InStr(pField.Name, ".") < 1 And pField.Type <> esriFieldTypeBlob And pField.Type <> esriFieldTypeGeometry Then
        i = pDestinationFeature.Fields.FindField(pField.Name)
        If i > -1 And i > 0 Then
            If VarType(pSourceFeature.Value(FieldCount)) <> vbNull Then
                pDestinationFeature.Value(i) = pSourceFeature.Value(FieldCount)
            Else
                pDestinationFeature.Value(i) = vbNull
            End If
        End If
      End If
  Next FieldCount
  Exit Sub
ErrorHandler:
  MsgBox "Error " & err.Number & ": " & err.Description & vbNewLine _
       & "In " & err.Source & " at COPYATTRIBUTES"
End Sub

'*******************************************************
'函数名称：ProToGeoTrans
'函数描述：平面到地理转换
'参数说明：pInFeatureLayer：要转换的图层，strFolder：目标文件夹，FileName：目标文件名 ，pNewSpatialReference：要转换到的空间参考
'返回值：
'*******************************************************
'
Public Function ProToGeoTrans(pInFeatureLayer As IFeatureLayer, strFolder As String, FileName As String, pNewSpatialReference As ISpatialReference) As Boolean
On Error GoTo err
    Const strShapeFieldName As String = "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 Function
            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)  '要素的数量
     '加进度条
 
    Set pProgDlg = New GWMescLib.CGWProgressDialog
    pProgDlg.Animation = 0
    pProgDlg.CancelEnabled = True
    pProgDlg.Title = "Shape文件坐标转换"
    pProgDlg.Description = "正在转换" & FileName & "文件"
    pProgDlg.MinValue = 0
    If FCount > 0 Then
        pProgDlg.MaxValue = FCount
    Else
        pProgDlg.MaxValue = 1
    End If
    pProgDlg.StepValue = 1
    pProgDlg.Scrolling = 0
    pProgDlg.ShowDialog
    pProgDlg.Message = "正在进创建shape文件..."
    AddReport "正在创建Shape数据文件！创建时间：" & Now
'    Set pInFeatureLayer.SpatialReference = pNewSpatialReference
    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"  '设置shape字段
    pFieldEdit.Type = esriFieldTypeGeometry
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    Set pGeomDef = New GeometryDef
    Set pGeomDefEdit = pGeomDef
    

'        pGeomDefEdit.SpatialReference.GetDomain xmin, xmax, ymin, ymax

'        pNewSpatialReference.SetDomain xmin, xmax, ymin, ymax
        
    With pGeomDefEdit
        .GeometryType = pInFeatureClass.ShapeType
        Set .SpatialReference = pNewSpatialReference '图形投影
        .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 = pNewSpatialReference '设置新图层的空间参考
    
    '先创建空的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 pNewSpatialReference
            Set pInsertFeatureBuffer.Shape = pFeature.Shape
            pInsertFeatureBuffer.Shape.Project pNewSpatialReference ' 对要素进行投影
            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

    ProToGeoTrans = True
    Exit Function
err:
    '出错信息
    pProgDlg.HideDialog
    Set pProgDlg = Nothing
    AddReport "坐标转换完成过程出错！原因：" & err.Description & "，时间：" & Now
End Function
'
'*******************************************************
'函数名称：GeoToGeoTrans
'函数描述：地理到地理转换（54和84之间）采用模型转换
'参数说明：pInFeatureLayer：要转换的图层，strFolder：目标文件夹，FileName：目标文件名 ，pNewSpatialReference：要转换到的空间参考
'返回值：
'*******************************************************
Public Function GeoToGeoTrans(pInFeatureLayer As IFeatureLayer, strFolder As String, FileName As String, pNewSpatialReference As ISpatialReference) As Boolean
On Error GoTo err
    Const strShapeFieldName As String = "Shape"
    g_bIsGeo = True  '表示地理坐标之间的转换
    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 Function
            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)

     '加进度条
    Set pProgDlg = New GWMescLib.CGWProgressDialog
    pProgDlg.Animation = 0
    pProgDlg.CancelEnabled = True
    pProgDlg.Title = "shape文件坐标转换"
    pProgDlg.Description = "正在转换" & FileName & "文件"
    pProgDlg.MinValue = 0
    If FCount > 0 Then
        pProgDlg.MaxValue = FCount
    Else
        pProgDlg.MaxValue = 1
    End If
    pProgDlg.StepValue = 1
    pProgDlg.Scrolling = 0
    pProgDlg.ShowDialog
    pProgDlg.Message = "正在进创建shape文件...    "
    AddReport "正在创建Shape数据文件！创建时间：" & Now
'    Set pInFeatureLayer.SpatialReference = pNewSpatialReference
    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 = pNewSpatialReference  '设置新的空间参考
        .GridCount = pGeometryDef.GridCount
        .HasM = pGeometryDef.HasM
        .HasZ = pGeometryDef.HasZ
    End With
    Set pFieldEdit.GeometryDef = pGeomDef
    pFieldsEdit.AddField pField '将图形字段入
    
    Set pOutFeatureLayer = New FeatureLayer