frmshptrans.frm

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

    Dim I As Long
    Dim fName As String '文件的全名
    Dim DName As String '文件名
    Dim DPath As String '文件路径
    '循环选择的文件
    For I = 1 To pSelCol.Count
        Dim pGWObj As CGWGxObject
        Set pGWObj = pSelCol.Item(I)
        If pGWObj.DataType = esriDTFeatureClass Then
            Dim j As Integer
            Dim isExist As Boolean
            isExist = False
            '以下循环为了不转换同一个文件
            For j = 1 To LvwPath.ListItems.Count
                If UCase(pGWObj.DataFullName) = UCase(LvwPath.ListItems.Item(j).SubItems(1)) Then '如果存在文件，就不加栽
                    isExist = True
                End If
            Next j
            If isExist = False Then
                Dim nItem As ListItem
                Dim SRName As String
                fName = pGWObj.DataFullName
                DName = pGWObj.DataName
                DPath = Left(fName, Len(fName) - Len(DName))    '得到路径
                SRName = getFileSRName(DPath, DName)
'                If SRName <> "1954年北京经纬度" And SRName <> "GCS_WGS_1984" And SRName <> "Beijing_1954" Then
'                    MsgBox "本转换工具仅限于对坐标参考为GCS_WGS_1984或北京54的shape文件转换！", vbInformation + vbOKOnly, "提示"
'                    Exit For
'                End If
                Set nItem = LvwPath.ListItems.Add(, , I, 1, 1)  '加如列表
                
                nItem.SubItems(1) = fName    '文件名
                nItem.SubItems(2) = SRName '获得空间参考名
                nItem.SubItems(3) = getFileSRType(DPath, DName) '获得空间参考类型
            End If
        End If
    Next I
    RefreshNO  '刷新排列序号
    LvwPath.SelectedItem = Nothing
    Exit Sub
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统 "
End Sub

Private Sub cmdDef_Click()
    If optDef.Value = False Then
        optDef.Value = True
    Else
        frmDefineCoord.Show vbModal  '打开自定义转换参数设置窗体
    End If
End Sub

Private Sub cmdDel_Click()
On Error Resume Next
    If LvwPath.ListItems.Count = 0 Then
        MsgBox "所有的项都被删除!", vbInformation + vbOKOnly, "提示"
        Exit Sub
    End If
    If LvwPath.SelectedItem Is Nothing Then
        MsgBox "请选择要删除的项!", vbInformation + vbOKOnly, "提示"
        Exit Sub
    End If
    Dim iMark As Long
    
    iMark = LvwPath.SelectedItem.Index
    LvwPath.ListItems.Remove (LvwPath.SelectedItem.Index) '删除选择的项
    If iMark < LvwPath.ListItems.Count - 1 Then
      LvwPath.ListItems.Item(iMark + 1).Selected = True
    Else
      LvwPath.ListItems.Item(1).Selected = True
    End If
    LvwPath.Refresh
    
    RefreshNO '刷新排列序号
    'LvwPath.SelectedItem = Nothing
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdPro_Click()
    If optPro.Value = False Then
        optPro.Value = True
    Else
        frmProSet.Show vbModal  '打开自定义转换参数设置窗体
    End If
End Sub

Private Sub cmdSelectPath_Click()
    txtPath.Text = BrowseForFolder(Me.hWnd, "选择输出文件存放路径", txtPath.Text) '打开选择文件夹的对话框
End Sub
 
Private Sub cmdShowReport_Click()
On Error Resume Next
    If cmdShowReport.Caption = "显示报告(&R)" Then
        cmdShowReport.Caption = "隐藏报告(&H)"   '隐藏报告
        Me.Height = Me.Height + 2250
    Else
        cmdShowReport.Caption = "显示报告(&R)"
        Me.Height = Me.Height - 2250     '显示报告
    End If
End Sub

Private Sub cmdTrans_Click()
On Error GoTo err
    If LvwPath.ListItems.Count < 1 Then
        MsgBox "没有要转换的文件！", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    Dim fs As New FileSystemObject  '文件对象
    If Not fs.FolderExists(txtPath.Text) Then
        MsgBox "目标路径无效！", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    Dim I As Long
    Dim pWFactory As IWorkspaceFactory
    Dim pFWorkspace As IFeatureWorkspace '建立工作空间
    Dim pFClass As IFeatureClass
    Dim tempPath As String '文件路径
    Dim tempName As String  '文件名
    Dim SRName As String
'    Dim PrjNo As Long
    For I = LvwPath.ListItems.Count To 1 Step -1  '循环整个列表
        tempPath = fs.GetParentFolderName(LvwPath.ListItems.Item(I).SubItems(1))
        tempName = fs.GetFileName(LvwPath.ListItems.Item(I).SubItems(1))
        tempName = Left(tempName, Len(tempName) - 4)
        Set pWFactory = New ShapefileWorkspaceFactory
        Set pFWorkspace = pWFactory.OpenFromFile(tempPath, 0) '打开文件
        Set pFClass = pFWorkspace.OpenFeatureClass(tempName) '从工作空间中打开要素
        Dim pGeoDataset As IGeoDataset
        Set pGeoDataset = pFClass
        Dim pSpatial As ISpatialReference
        Set pSpatial = pGeoDataset.SpatialReference '获得旧文件的空间参考
        SRName = pSpatial.Name
        Dim pInFeatureLayer As IFeatureLayer
        Set pInFeatureLayer = New FeatureLayer
        Set pInFeatureLayer.FeatureClass = pFClass
'        PrjNo = getPrjNo(pSpatial)
        InitPara   '
        If optG54 = True Then        '向1954年北京经纬度转换
            If TypeOf pSpatial Is IProjectedCoordinateSystem Then        '如果是平面坐标
                If getOldGeoPrjName(pSpatial) = "Beijing_1954" Or getOldGeoPrjName(pSpatial) = "北京1954经纬度" Or getOldGeoPrjName(pSpatial) = "1954年北京经纬度" Then
                    ProToGeoTrans pInFeatureLayer, txtPath.Text, tempName, mpSF54GCS '转换文件（平面到地理）
                Else
                    AddReport tempName & "坐标转换失败，对于向1954年北京经纬度的转换，源文件只能是GCS_WGS_1984或1954下的平面坐标！"
                    MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                End If
            ElseIf TypeOf pSpatial Is IGeographicCoordinateSystem Then     '如果是地理坐标
                If SRName = "GCS_WGS_1984" Then
                    g_bIsTo54 = True
                    GeoToGeoTrans pInFeatureLayer, txtPath.Text, tempName, mpSF54GCS  '地理坐标之间转换
                Else
                    AddReport tempName & "坐标转换失败，对于向1954年北京经纬度的转换，源文件只能是GCS_WGS_1984或1954下的平面坐标！"
                    MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                End If
            End If
        End If
        If optG84 = True Then        'GCS_WGS_1984
            If TypeOf pSpatial Is IProjectedCoordinateSystem Then        '如果是平面坐标
                If getOldGeoPrjName(pSpatial) = "GCS_WGS_1984" Then
                    ProToGeoTrans pInFeatureLayer, txtPath.Text, tempName, mpSF84GCS  '转换文件
                Else
                    AddReport tempName & "坐标转换失败，对于向GCS_WGS_1984的转换，源文件只能是GCS_WGS_1984下的平面坐标或Beijing_1954！"
                    MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                End If
            ElseIf TypeOf pSpatial Is IGeographicCoordinateSystem Then
                If SRName = "Beijing_1954" Or SRName = "1954年北京经纬度" Or SRName = "北京1954经纬度" Then
                    g_bIsTo54 = False      '向84坐标转换
                    GeoToGeoTrans pInFeatureLayer, txtPath.Text, tempName, mpSF84GCS
                Else
                    AddReport tempName & "坐标转换失败，对于向GCS_WGS_1984的转换，源文件只能是GCS_WGS_1984下的平面坐标或Beijing_1954！"
                    MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                End If
            End If
        End If
        If optPro.Value = True Then  '向平面坐标转换
            If g_PrjName = "" Then
                MsgBox "平面坐标转换参数无设置！", vbInformation + vbOKOnly, "系统"
                Exit Sub
            End If
            If TypeOf pSpatial Is IProjectedCoordinateSystem Then        '如果是平面坐标
                g_NO = getPrjNo(pSpatial) ' 得到此空间参考的带号
                g_IsAddNO = getAddNO(pSpatial)
                If optType <> "ProToPro" Then
                    MsgBox "平面坐标转换参数设置错误！", vbInformation + vbOKOnly, "系统"
                    Exit Sub
                End If
'                g_PrjName = getOldGeoPrjName(pSpatial)   '得到此平面参考的的地理参考名字
                If g_PrjName = "1954年北京经纬度平面" Then
                    If getOldGeoPrjName(pSpatial) = "GCS_WGS_1984" Then
                        g_bIsTo54 = True    '向54平面转换
                        ProToProtrans pInFeatureLayer, txtPath.Text, tempName
                    Else
                        AddReport tempName & "坐标转换失败，对于向1954年北京平面的转换，源文件只能是GCS_WGS_1984下的平面坐标或Beijing_1954！"
                        MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                    End If
                ElseIf g_PrjName = "GCS_WGS_1984平面" Then
                    If getOldGeoPrjName(pSpatial) = "Beijing_1954" Or getOldGeoPrjName(pSpatial) = "1954年北京经纬度" Then
                        g_bIsTo54 = False  '向84平面转换
                        ProToProtrans pInFeatureLayer, txtPath.Text, tempName
                    Else
                        AddReport tempName & "坐标转换失败，对于向GCS_WGS_1984平面的转换，源文件只能是GCS_WGS_1984或Beijing_1954下的平面坐标！"
                        MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                    End If
                End If
                
            ElseIf TypeOf pSpatial Is IGeographicCoordinateSystem Then
'                g_PrjName = pSpatial.Name  '得到此空间参考的名字
                If optType <> "GeoToPro" Then
                    MsgBox "平面坐标转换参数设置错误！", vbInformation + vbOKOnly, "系统"
                    Exit Sub
                End If
                If g_PrjName = "1954年北京经纬度平面" Then
                    If SRName = "Beijing_1954" Or SRName = "1954年北京经纬度" Or SRName = "北京1954经纬度" Then
                        GeoToProtrans pInFeatureLayer, txtPath.Text, tempName
                    Else
                        AddReport tempName & "坐标转换失败，对于向1954年北京平面的转换，源文件只能是GCS_WGS_1984下的平面坐标或Beijing_1954！"
                        MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                    End If
                ElseIf g_PrjName = "GCS_WGS_1984平面" Then
                    If SRName = "GCS_WGS_1984" Then
                        GeoToProtrans pInFeatureLayer, txtPath.Text, tempName
                    Else
                        AddReport tempName & "坐标转换失败，对于向GCS_WGS_1984平面的转换，源文件只能是GCS_WGS_1984或Beijing_1954下的平面坐标！"
                        MsgBox tempName & "坐标转换失败，详细请查看报告！", vbInformation + vbOKOnly, "系统"
                    End If
                End If
            End If
        End If
        If optDef.Value = True Then   '自定义坐标
            If miConvMode = 0 Then
                MsgBox "自定义转换参数无设置！", vbOKOnly + vbInformation, "提示"
                Exit Sub
            End If
            DefineGeoToGeotrans pInFeatureLayer, txtPath.Text, tempName
        End If
    Next I
    Exit Sub
err:
    MsgBox "坐标转换失败！", vbInformation + vbOKOnly, "系统"
End Sub

Private Sub Form_Load()
    WindowsXPC1.FrameControl = False
    WindowsXPC1.InitSubClassing
    Me.Height = Me.Height - 2250  '隐藏转换报告
End Sub

Private Sub Form_Unload(Cancel As Integer)
    WindowsXPC1.EndWinXPCSubClassing
End Sub


'*******************************************************
'函数名称：RefreshNO
'函数描述：重新排列序号
'参数说明：
'返回值：
'*******************************************************
Public Sub RefreshNO()
On Error Resume Next
    Dim I As Long
    I = 1
    Do
        If LvwPath.ListItems.Item(I) Is Nothing Then
            Exit Do
        End If
        LvwPath.ListItems.Item(I) = I  '排列序号
        I = I + 1
    Loop
End Sub

Private Sub optDef_Click()
    frmDefineCoord.Show vbModal  '打开自定义转换参数设置窗体
End Sub

Private Sub optPro_Click()
    frmProSet.Show vbModal  '打开自定义转换参数设置窗体
End Sub
''*******************************************************
'函数名称：getOldGeoPrjName
'函数描述：通过平面坐标得到其原来的地理参考
'参数说明：pSpatial：空间参考
'返回值：
'*******************************************************
Public Function getOldGeoPrjName(pSpatial As ISpatialReference) As String
    If TypeOf pSpatial Is IProjectedCoordinateSystem Then
        Dim pPro As IProjectedCoordinateSystem
        Set pPro = pSpatial
        getOldGeoPrjName = pPro.GeographicCoordinateSystem.Name '得到地理参考名字
    End If
End Function