bastrans.bas

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

    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  '得到第一个feature
        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  '搜索所有的feature
            If pProgDlg.HasCanceled Then
                Exit Do   '取消退出
            End If
            pProgDlg.Message = "正在处理第" & j & "行数据 "
            pProgDlg.Step
            CopyAttribute pFeature, pInsertFeatureBuffer  '拷贝属性
    '        pFeature.Shape.Project pNewSpatialReference
            Set pInsertFeatureBuffer.Shape = getOutGeometry(pFeature) '通过模型转换得到的图形
            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

    Exit Function
err:
    pProgDlg.HideDialog
    Set pProgDlg = Nothing
    AddReport "坐标转换完成过程出错！原因：" & err.Description & "，时间：" & Now

End Function
'
'*******************************************************
'函数名称：ProToProtrans
'函数描述：实现平面参考之间的转换（54和84之间）
'参数说明：pInFeatureLayer：要转换的图层，strFolder：目标文件夹，FileName：目标文件名 ，pNewSpatialReference：要转换到的空间参考 ,lNo:投影的带号
'返回值：
'*******************************************************
Public Sub ProToProtrans(pInFeatureLayer As IFeatureLayer, strFolder As String, FileName As String)
On Error GoTo err
    g_bIsGeo = False  '表示平面坐标之间的转换
    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)   '所有要素的数量
 

   
    Dim pFeature As IFeature

    Set mpSF54Pcs = CreatePrj("1954年北京经纬度平面")  '创建对应的平面坐标
    Set mpSF84Pcs = CreatePrj("GCS_WGS_1984平面") '创建对应的平面坐标
'    Set mpSFPcs = CreatePrj
    If mpSF84Pcs Is Nothing Then Exit Sub
    If mpSF54Pcs Is Nothing Then Exit Sub
    
     '加进度条
    
    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
    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
  
        .GridCount = pGeometryDef.GridCount
        .HasM = pGeometryDef.HasM
        .HasZ = pGeometryDef.HasZ
        If g_bIsTo54 = True Then
            Set .SpatialReference = mpSF54Pcs '54参考
        Else
            Set .SpatialReference = mpSF84Pcs '84参考
        End If
    End With
    Set pFieldEdit.GeometryDef = pGeomDef

    
    pFieldsEdit.AddField pField   '增加字段信息

    Dim pOutFeatureLayer As IFeatureLayer  '定义输出图层
    Set pOutFeatureLayer = New FeatureLayer
    If g_bIsTo54 = True Then  '分54和84两种
        Set pOutFeatureLayer.SpatialReference = mpSF54Pcs '设置图层的投影
    Else
        Set pOutFeatureLayer.SpatialReference = mpSF84Pcs
    End If
    '创建新的文件
    Set pOutFeatureLayer.FeatureClass = pFWS.CreateFeatureClass(FileName, pFields, Nothing, Nothing, esriFTSimple, strShapeFieldName, "")
    If FCount > 0 Then
        Dim pOutFeatureClass As IFeatureClass
        Set pOutFeatureClass = pOutFeatureLayer.FeatureClass
    
        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
        Dim pFeatureCursor As IFeatureCursor
        Set pFeatureCursor = pInFeatureClass.Search(pQFilt, False)  '得到所有要素的集合
        Set pFeature = pFeatureCursor.NextFeature  '得到第一个要素
        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 mpSF84Pcs
    '        Dim pTmpPoint As IPoint
    '        Set pTmpPoint = New Point
    '        pTmpPoint.X = 12#
    '        pTmpPoint.Y = 13#
    '        pTmpPoint.Z = 1000
    ''
    '        Set pFeature = pTmpPoint
    '        Set pFeature = pInsertFeatureBuffer
    '        Set pFeature.Shape = pTmpPoint
    '        Set pInsertFeatureBuffer.Shape = pFeature.Shape
            Set pInsertFeatureBuffer.Shape = getOutGeometry(pFeature)    '写入图形信息
            If g_bIsTo54 = True Then
                pInsertFeatureBuffer.Shape.Project mpSF54Pcs ' 对要素进行投影
            Else
                pInsertFeatureBuffer.Shape.Project mpSF84Pcs ' 对要素进行投影
            End If
    '
            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
'*******************************************************
'函数名称：GeoToProtrans
'函数描述：实现地理参考到平面参考之间的转换
'参数说明：pInFeatureLayer：要转换的图层，strFolder：目标文件夹，FileName：目标文件名 ,lNo:投影的带号
'返回值：
'*******************************************************
Public Sub GeoToProtrans(pInFeatureLayer As IFeatureLayer, strFolder As String, FileName As String)
On Error GoTo err
    Const strShapeFieldName As String = "Shape"     '定义shape文件
    Dim mpsFPcs As ISpatialReference
    Set mpsFPcs = CreatePrj(g_PrjName) '创建对应的平面参考
    If mpsFPcs Is Nothing Then Exit Sub
    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)

     '加进度条
    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 = 0
    End If
    pProgDlg.StepValue = 1
    pProgDlg.Scrolling = 0
    pProgDlg.ShowDialog
    pProgDlg.Message = "正在进创建shape文件..."