mdlspatialreferenece.bas

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

Attribute VB_Name = "mdlSpatialReferenece"
Option Explicit
Public g_PrjName As String
Public g_NOInfo As Integer  '3代表3度分带，6代表6度分带
Public g_NO As Integer '带号
Public g_IsAddNO As String   '是否加带号
Public optType As String  '保存转换类型

''建立beijing坐标系统
Public Function CreateBeijing54GCS() As ISpatialReference
On Error GoTo err
Dim SRFileName As String
'Dim fs As New FileSystemObject
SRFileName = App.Path & "\坐标系统\北京1954经纬度.prj"
'If fs.FileExists(SRFileName) Then
'   Dim pSpatRefFact As ISpatialReferenceFactory
'   Set pSpatRefFact = New SpatialReferenceEnvironment
'   Set CreateBeijing54GCS = pSpatRefFact.CreateESRISpatialReferenceFromPRJFile(SRFileName)
'   CreateBeijing54GCS.SetDomain -180, 180, -90, 90
''   pSpatRef.SetDomain -180, 180, -180, 180
'        CreateBeijing54GCS.SetMFalseOriginAndUnits 1, 1
'        CreateBeijing54GCS.SetZFalseOriginAndUnits 1, 1
        Dim pSpatRefFact As ISpatialReferenceFactory
        Dim pSpatRef As ISpatialReference
        Set pSpatRefFact = New SpatialReferenceEnvironment
        Set pSpatRef = pSpatRefFact.CreateESRISpatialReferenceFromPRJFile(SRFileName)
        pSpatRef.SetDomain -180, 180, -180, 180
        pSpatRef.SetMFalseOriginAndUnits 1, 1
        pSpatRef.SetZFalseOriginAndUnits 1, 1
        Set CreateBeijing54GCS = pSpatRef
        Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
'End If
'Set fs = Nothing
End Function
'作者:石峰
'建立日期：2005-07-13
'WGS1984坐标系统分带系统,基于高斯-克吕格坐标系统
'提供6度分带坐标系统
'------------------------------------------------
Public Function CreateWGS1984() As ISpatialReference
On Error GoTo err
    Dim SRFileName As String
    Dim fs As New FileSystemObject
    SRFileName = App.Path & "\坐标系统\GCS_WGS_1984.prj"
    If fs.FileExists(SRFileName) Then
       Dim pSpatRefFact As ISpatialReferenceFactory
       Set pSpatRefFact = New SpatialReferenceEnvironment
       Set CreateWGS1984 = pSpatRefFact.CreateESRISpatialReferenceFromPRJFile(SRFileName)
    End If
    Set fs = Nothing
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'*******************************************************
'函数名称：CreatePrj
'函数描述：根据分带信息创建平面空间参考
'参数说明：
'返回值：返回创建成功的平面参考
'*******************************************************
Public Function CreatePrj(prjName As String) As ISpatialReference
On Error GoTo err
    Dim SRFileName As String
    Dim fs As New FileSystemObject  '文件对象
    If prjName = "1954年北京经纬度平面" Then
        SRFileName = App.Path & "\坐标系统\1954年北京平面" & g_NO & "度带（" & g_NOInfo & "度分带" & g_IsAddNO & "加带号）.prj"
    ElseIf prjName = "GCS_WGS_1984平面" Then
        SRFileName = App.Path & "\坐标系统\WGS1984_" & g_NO & "度带(" & g_NOInfo & "度分带" & g_IsAddNO & "加带号).prj"
    End If
    If fs.FileExists(SRFileName) Then   '如果存在此文件
        Dim pSpatRefFact As ISpatialReferenceFactory
        Set pSpatRefFact = New SpatialReferenceEnvironment
        Set CreatePrj = pSpatRefFact.CreateESRISpatialReferenceFromPRJFile(SRFileName)
    Else
        MsgBox "系统找不到对应的坐标文件！", vbOKOnly + vbInformation, "提示"
        Set CreatePrj = Nothing
    End If
    Set fs = Nothing
    Exit Function
err:
    MsgBox "系统找不到对应的坐标文件！", vbOKOnly + vbInformation, "提示"
End Function