bascoortransmodel.bas

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

Attribute VB_Name = "basCoorTransModel"

'-------------定义子定义坐标转换参数全局变量---------------------
'*包括三种坐标系统的参数变量转换参数,ShiFeng Add
'2005-09-21
Public miConvMode As Integer '转换模式 1-北京54到WGS84之间的转换；2-北京54到TWD97之间转换
'定义北京54到WGS84之间的转换参数
Public m_dDx_1 As Double, m_dDy_1 As Double, m_dDz_1 As Double
Public m_dEx_1 As Double, m_dEy_1 As Double, m_dEz_1 As Double
Public m_dm_1 As Double
Public m_dBJ54A_1 As Double, m_dBJ54F_1 As Double
Public m_dWGS84A_1 As Double, m_dWGS84F_1 As Double
'定义北京54到TWD67转换的参数
Public m_dDx_2 As Double, m_dDy_2 As Double, m_dDz_2 As Double
Public m_dEx_2 As Double, m_dEy_2 As Double, m_dEz_2 As Double
Public m_dm_2 As Double
Public m_dBJ54A_2 As Double, m_dBJ54F_2 As Double
Public m_dTWD67A_2 As Double, m_dTWD67F_2 As Double
'TWD67再到TWD97转换的参数
Public m_dDx_3 As Double, m_dDy_3 As Double, m_dDz_3 As Double
Public m_dEx_3 As Double, m_dEy_3 As Double, m_dEz_3 As Double
Public m_dm_3 As Double
Public m_dTwd67A_3 As Double, m_dTwd67F_3 As Double
Public m_dTwd97A_3 As Double, m_dTwd97F_3 As Double
'保留以前的参数变量定义，使用函数将参数值进行动态的设置给这些变量
'm_dDx, m_dDy, m_dDz, m_dEx, m_dEy, m_dEz, m_dm, m_dOldA, m_dOldF, m_dNewA, m_dNewF
Public m_dDx As Double, m_dDy As Double, m_dDz As Double
Public m_dEx As Double, m_dEy As Double, m_dEz As Double
Public m_dm As Double
Public m_dOldA As Double, m_dOldF As Double
Public m_dNewA As Double, m_dNewF As Double


Public mpSF54GCS As esriGeometry.ISpatialReference    '北京54地理参考
Public mpSF84GCS As esriGeometry.ISpatialReference     '84地理参考
Public mpSF54Pcs As esriGeometry.ISpatialReference     '54下平面坐标
Public mpSF84Pcs As esriGeometry.ISpatialReference    '84下平面坐标
Dim mpBJ54Pnt As esriGeometry.IPoint    '54平面参考下的点
Dim mpwgs84Pnt As esriGeometry.IPoint   '84平面参考下的点
Public mpCoordConvt As TWCOORDCONVERTERLib.CoordConverter   '定义模型
'************************************
'初始化坐标转换需要的参数
'************************************
Public Function InitPara() As Boolean
  On Error GoTo errHandler
  InitPara = False
  Set mpSF54GCS = CreateBeijing54GCS() '创建北京54地理坐标
  Set mpSF84GCS = CreateWGS1984()      '创建WGS84地理坐标
  Set mpCoordConvt = New TWCOORDCONVERTERLib.CoordConverter  ' 初始化转换模型
                     '对于平面参考
''    Set mpSF54Pcs = GetSpatialReferenceBJ54N(lNo)
'    Set mpSF84Pcs = GetSpatialReference84N(lNo)

  Set mpBJ54Pnt = New esriGeometry.Point  '初始化点
  Set mpwgs84Pnt = New Point
  InitPara = True
  Exit Function
errHandler:
  
End Function
'经纬度
'********************************************************************
'目的： 实现54坐标系到84坐标系的转换（经纬度）
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'返回：
'       dX1：返回84的横坐标
'       dY1：返回84的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function BLCoorTrans54to84(ByVal dX0 As Double, ByVal dY0 As Double, ByRef dX1 As Double, ByRef dY1 As Double) As Boolean
    On Error GoTo errHandler:
    BLCoorTrans54to84 = False
    Dim dh As Double
    dh = 0
    Dim dTmp1 As Double
    Dim dTmp2 As Double
    mpCoordConvt.Bj54ToTwd67 dY0, dX0, dY1, dX1
    
    dTmp1 = dX1
    dTmp2 = dY1
    mpCoordConvt.Twd67ToTwd97 dTmp2, dTmp1, 500, dY1, dX1, dh
'    Debug.Print dTmp1, dTmp2, dX1, dY1, "bj54-twd97"
    BLCoorTrans54to84 = True
    Exit Function
errHandler:
    BLCoorTrans54to84 = False
    Debug.Print err.Description
    MsgBox "坐标转换发生错误" & vbCrLf & "错误描述:" & err.Description
End Function
'********************************************************************
'目的： 实现54坐标系到84坐标系的转换（经纬度）,直接使用王所长提供程序
'       通过试验，直接转换的精度更高一些
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'返回：
'       dX1：返回84的横坐标
'       dY1：返回84的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function BLCoorTrans54to84Ex(ByVal dX0 As Double, ByVal dY0 As Double, ByRef dX1 As Double, ByRef dY1 As Double) As Boolean
    On Error GoTo errHandler:
    BLCoorTrans54to84Ex = False
    Dim dh As Double
    dh = 0
    Dim dTmp1 As Double
    Dim dTmp2 As Double
    mpCoordConvt.Bj54ToTwd97 dY0, dX0, dY1, dX1
'    Debug.Print dX0, dY0
'    Debug.Print dX1, dY1
'    dTmp1 = dX1
'    dTmp2 = dY1
'    mpCoordConvt.Twd67ToTwd97 dTmp2, dTmp1, 500, dY1, dX1, dh
    BLCoorTrans54to84Ex = True
    Exit Function
errHandler:
    BLCoorTrans54to84Ex = False
    Debug.Print err.Description
    MsgBox "坐标转换发生错误" & vbCrLf & "错误描述:" & err.Description
End Function
'********************************************************************
'目的： 实现84坐标系到54坐标系的转换（经纬度）
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'返回：
'       dX1：返回54的横坐标
'       dY1：返回54的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function BLCoorTrans84to54(ByVal dX0 As Double, ByVal dY0 As Double, ByRef dX1 As Double, ByRef dY1 As Double) As Boolean
    On Error GoTo errHandler:
    BLCoorTrans84to54 = False
    Dim dh As Double
    Dim dTmp1 As Double
    Dim dTmp2 As Double
    dh = 0
    mpCoordConvt.Twd97ToTwd67 dY0, dX0, 500, dY1, dX1, dh
    dTmp1 = dX1
    dTmp2 = dY1
    mpCoordConvt.Twd67ToBj54 dTmp2, dTmp1, dY1, dX1
    BLCoorTrans84to54 = True
    Exit Function
errHandler:
    BLCoorTrans84to54 = False
    MsgBox "坐标转换发生错误" & vbCrLf & "错误描述:" & err.Description
 End Function
 '********************************************************************
'目的： 实现84坐标系到54坐标系的转换（经纬度）,直接进行转换
'       通过试验，直接转换的精度更高一些
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'返回：
'       dX1：返回54的横坐标
'       dY1：返回54的纵坐标
'       成功转换返回true，否则false
'***********************************************************************
Public Function BLCoorTrans84to54Ex(ByVal dX0 As Double, ByVal dY0 As Double, ByRef dX1 As Double, ByRef dY1 As Double) As Boolean
    On Error GoTo errHandler:
    BLCoorTrans84to54Ex = False
    Dim dh As Double
    Dim dTmp1 As Double
    Dim dTmp2 As Double
    dh = 0
    mpCoordConvt.Twd97ToBj54 dY0, dX0, dY1, dX1
'    dTmp1 = dX1
'    dTmp2 = dY1
'    mpCoordConvt.Twd67ToBj54 dTmp2, dTmp1, dY1, dX1
    BLCoorTrans84to54Ex = True
    Exit Function
errHandler:
    BLCoorTrans84to54Ex = False
    MsgBox "坐标转换发生错误" & vbCrLf & "错误描述:" & err.Description
 End Function
'Public Declare Function Test Lib "EpCoorTransformModel.dll" Alias "TestA" (no As Long)
'********************************************************************
'目的： 实现54坐标系到84坐标系的转换（平面坐标）
'输入：
'       dX0：横坐标
'       dY0：纵坐标
'       lNo：带号
'返回：
'       dX1：返回84的横坐标
'       dY1：返回84的纵坐标
'       成功转换返回true，否则false
' 说明：
'       代号
'***********************************************************************
Public Function CoorTrans54to84(ByVal dX0 As Double, ByVal dY0 As Double, dX1 As Double, dY1 As Double) As Boolean
    On Error GoTo errHandler:
    CoorTrans54to84 = False
    
    If mpSF54GCS Is Nothing Then
        Exit Function
    End If
    If mpSF84GCS Is Nothing Then
        Exit Function
    End If
    If mpSF54Pcs Is Nothing Then