bascoortransmodel.bas

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

        Exit Function
    End If
    If mpSF84Pcs Is Nothing Then
        Exit Function
    End If
        Set mpwgs84Pnt = New Point
    Set mpBJ54Pnt.SpatialReference = mpSF54Pcs
    Set mpwgs84Pnt.SpatialReference = mpSF84GCS
    '将北京54坐标系下点转换为经纬度坐标
    mpBJ54Pnt.X = dX0
    mpBJ54Pnt.Y = dY0
    mpBJ54Pnt.Project mpSF54GCS
    Dim Dx As Double
    Dim Dy As Double
    Dx = mpBJ54Pnt.X
    Dy = mpBJ54Pnt.Y
    '从北京54经纬度转换为wgs1984经纬度
    If Not BLCoorTrans54to84Ex(Dx, Dy, Dx, Dy) Then Exit Function
'    Debug.Print Dx, Dy
    
    '从wgs1984经纬度转换为wgs1984平面坐标系下

    mpwgs84Pnt.X = Dx
    mpwgs84Pnt.Y = Dy
    mpwgs84Pnt.Project mpSF84Pcs
'    Debug.Print mpwgs84Pnt.X, mpwgs84Pnt.Y
    
    dX1 = mpwgs84Pnt.X
    dY1 = mpwgs84Pnt.Y
    
    'return
    CoorTrans54to84 = True
    
    
    Exit Function
errHandler:
    Debug.Print err.Description
    MsgBox "坐标转换发生错误" & vbCrLf & "错误描述:" & err.Description
    err.Clear
    CoorTrans54to84 = False
End Function
'********************************************************************
'目的： 实现84坐标系到54坐标系的转换（平面坐标）
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'返回：
'       dX1：返回54的横坐标
'       dY1：返回54的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function CoorTrans84to54(ByVal dX0 As Double, ByVal dY0 As Double, dX1 As Double, dY1 As Double) As Boolean
    On Error GoTo errHandler:
    CoorTrans84to54 = False

    If mpSF54GCS Is Nothing Then
        Exit Function
    End If
    If mpSF84GCS Is Nothing Then
        Exit Function
    End If
    If mpSF54Pcs Is Nothing Then
        Exit Function
    End If
    If mpSF84Pcs Is Nothing Then
        Exit Function
    End If
    Set mpBJ54Pnt.SpatialReference = mpSF54GCS
    Set mpwgs84Pnt.SpatialReference = mpSF84Pcs
    mpwgs84Pnt.X = dX0
    mpwgs84Pnt.Y = dY0
    
    '转换84平面坐标到经纬度坐标系下
    mpwgs84Pnt.Project mpSF84GCS
    Dim Dx As Double
    Dim Dy As Double
    Dx = mpwgs84Pnt.X
    Dy = mpwgs84Pnt.Y
'    Debug.Print Dx, Dy
    
    '转换wgs84经纬度到北京54经纬度
    BLCoorTrans84to54Ex Dx, Dy, Dx, Dy
    mpBJ54Pnt.X = Dx
    mpBJ54Pnt.Y = Dy
    mpBJ54Pnt.Project mpSF54Pcs
    dX1 = mpBJ54Pnt.X
    dY1 = mpBJ54Pnt.Y
'    Debug.Print dX1, dY1
    CoorTrans84to54 = True
    Exit Function
errHandler:
    Debug.Print err.Description
    err.Clear
    CoorTrans84to54 = False
    MsgBox "坐标转换发生错误" & vbCrLf & "错误描述:" & err.Description
End Function
'********************************************************************
'目的： 实现54坐标系到84自定义参数坐标的转换
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'       dx,dy,dz,ex,ey,ez,mm 坐标转换参数
'返回：
'       dX1：返回84的横坐标
'       dY1：返回84的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function CoorTrans54to84Define(ByVal dX0 As Double, ByVal dY0 As Double, ByVal lNo As Long, _
                                      ByVal Dx As Double, ByVal Dy As Double, ByVal dz As Double, _
                                      ByVal ex As Double, ByVal ey As Double, ByVal ez As Double, _
                                      ByVal mm As Double, _
                                      ByVal dOldA As Double, ByVal doldF As Double, ByVal dNewA As Double, ByVal dNewF As Double, _
                                      dX1 As Double, dY1 As Double) As Boolean
  'ShiFeng add
  '自定义的坐标转换，使用七参数转换方法
  On Error GoTo hErr
  CoorTrans54to84Define = False
  Dim dH1 As Double
  
'  If lNo > 0 Then
'    '平面坐标系统
'    'mpCoordConvt.SenvenConvert dBB, dLL, dh, ddx, ddy, dDz, dEx, dEy, dEz, dM, dA1, dF1, dB0, dL0, dH0
'    '需要作平面和地理之间的转换工作，目前还不支持
'    '需要与巩讨论一下
'  Else
    mpCoordConvt.SenvenConvert dX0, dY0, 0, Dx, Dy, dz, ex, ey, ez, mm, dOldA, doldF, dNewA, dNewF, dX1, dY1, dH1
'    Debug.Print dX1, dY1
'  End If
  CoorTrans54to84Define = True
  Exit Function
hErr:
  Debug.Print "CoorTrans54to84Define" & err.Description
End Function
'********************************************************************
'目的： 实现84坐标系到54坐标系自定义参数的转换
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       iCovMode:转换方法,1-新北京54到WGS84,2-新北京54到TWD97
'       去掉dx,dy,dz,ex,ey,ez,mm 坐标转换参数的输入，由自己得到
'返回：
'       dX1：返回54的横坐标
'       dY1：返回54的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function CoorTransDefineEx(ByVal dX0 As Double, ByVal dY0 As Double, ByVal iCovMode As Integer, dX1 As Double, dY1 As Double) As Boolean
  On Error GoTo errHandler
  CoorTransDefineEx = False
  If iCovMode = 1 Then
    '新北京54到WGS84
    If CoorTrans54to84Define(dX0, dY0, -1, m_dDx_1, m_dDy_1, m_dDz_1, m_dEx_1, m_dEy_1, m_dEz_1, m_dm_1, m_dBJ54A_1, m_dBJ54F_1, m_dWGS84A_1, m_dWGS84F_1, dX1, dY1) Then
        CoorTransDefineEx = True
    End If
    
  ElseIf iCovMode = 2 Then
    '新北京54到TWD97
    If CoorTrans54to84Define(dX0, dY0, -1, m_dDx_2, m_dDy_2, m_dDz_2, m_dEx_2, m_dEy_2, m_dEz_2, m_dm_2, m_dBJ54A_2, m_dBJ54F_2, m_dTWD67A_2, m_dTWD67F_2, dX1, dY1) Then
        If CoorTrans54to84Define(dX1, dY1, -1, m_dDx_3, m_dDy_3, m_dDz_3, m_dEx_3, m_dEy_3, m_dEz_3, m_dm_3, m_dTwd67A_3, m_dTwd67F_3, m_dTwd97A_3, m_dTwd97F_3, dX1, dY1) Then
            CoorTransDefineEx = True
        End If
    End If
  End If
'  CoorTransDefineEx = True
  Exit Function
errHandler:
  Debug.Print err.Description
End Function

Public Function BLCoorTrans54to84DefineEx(ByVal dX0 As Double, ByVal dY0 As Double, ByVal iCovMode As Integer, dX1 As Double, dY1 As Double) As Boolean
  On Error GoTo errHandler
  BLCoorTrans54to84DefineEx = False
  Dim dH0 As Double
  
  If iCovMode = 1 Then
    '1-新北京54到WGS84
    SeventConvertEx2 dX0, dY0, 1000, m_dDx_1, m_dDy_1, m_dDz_1, m_dEx_1, m_dEy_1, m_dEz_1, m_dm_1, m_dBJ54A_1, m_dBJ54F_1, m_dWGS84A_1, m_dWGS84F_1, dX1, dY1, dH0
  ElseIf iCovMode = 2 Then
    '新北京54到TWD97
    SeventConvertEx2 dX0, dY0, 1000, m_dDx_2, m_dDy_2, m_dDz_2, m_dEx_2, m_dEy_2, m_dEz_2, m_dm_2, m_dBJ54A_2, m_dBJ54F_2, m_dTwd67A_3, m_dTwd67F_3, dX1, dY1, dH0
    SeventConvertEx2 dX1, dY1, 1000, m_dDx_3, m_dDy_3, m_dDz_3, m_dEx_3, m_dEy_3, m_dEz_3, m_dm_3, m_dTwd67A_3, m_dTwd67F_3, m_dTwd97A_3, m_dTwd97F_3, dX1, dY1, dH0
  End If
  BLCoorTrans54to84DefineEx = True
  Exit Function
errHandler:
  BLCoorTrans54to84DefineEx = False
  Debug.Print err.Description
End Function
Public Function SeventConvertEx2(dBB As Double, dLL As Double, dh As Double, ddx As Double, _
                              ddy As Double, dDz As Double, dEx As Double, dEy As Double, _
                              dEz As Double, dM As Double, dA As Double, dF As Double, _
                              dA1 As Double, dF1 As Double, dB0 As Double, dL0 As Double, dH0 As Double) As Boolean
  On Error GoTo hErr
  SeventConvertEx2 = False
  mpCoordConvt.SenvenConvert dBB, dLL, dh, ddx, ddy, dDz, dEx, dEy, dEz, dM, dA, dF, dA1, dF1, dB0, dL0, dH0
  SeventConvertEx2 = True
  Exit Function
hErr:
  Debug.Print "SeventConvertEx2" & err.Description
  
End Function