bastrans.bas

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

'*******************************************************
'函数名称：PointDefTrans
'函数描述：自定义点转换
'参数说明：pInPoint：点要素
'返回值：返回转换后的点
'*******************************************************
Public Function PointDefTrans(pInPoint As IPoint) As IPoint
On Error GoTo err
    Dim nX0 As Double, nY0 As Double
    Dim nx1 As Double, ny1 As Double
    nX0 = pInPoint.X  '获取点坐标x的值
    nY0 = pInPoint.Y '获取点坐标x的值
    BLCoorTrans54to84DefineEx nX0, nY0, miConvMode, nx1, ny1   '通过模型进行点转换
'    Dim pOutPoint As IPoint
'    Set pOutPoint = New Point
    pInPoint.X = nx1
    pInPoint.Y = ny1
    Set PointDefTrans = pInPoint
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'
'*******************************************************
'函数名称：PointTrans
'函数描述：通过模型进行点转换
'参数说明：pInPoint：点要素
'返回值：返回转换后的点
'*******************************************************
Public Function PointTrans(pInPoint As IPoint) As IPoint
On Error GoTo err
    Dim nX0 As Double, nY0 As Double
    Dim nx1 As Double, ny1 As Double
    nX0 = pInPoint.X
    nY0 = pInPoint.Y
    If g_bIsGeo Then
        If g_bIsTo54 Then
            BLCoorTrans84to54Ex nX0, nY0, nx1, ny1          '转换坐标
        Else
            BLCoorTrans54to84Ex nX0, nY0, nx1, ny1          '转换坐标
        End If
    Else
        If g_bIsTo54 Then
            CoorTrans84to54 nX0, nY0, nx1, ny1          '转换坐标
        Else
            CoorTrans54to84 nX0, nY0, nx1, ny1          '转换坐标
        End If
    End If
'    Dim pOutPoint As IPoint
'    Set pOutPoint = New Point
'
'
'    pOutPoint.PutCoords nx1, ny1    '重新生成点
'    pOutPoint.Z = pInPoint.Z
'    Set pOutPoint.SpatialReference = pInPoint.SpatialReference
    pInPoint.X = nx1
    pInPoint.Y = ny1
'    pInPoint.GeoNormalize
    Set PointTrans = pInPoint
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'
'*******************************************************
'函数名称：PolylineTrans84to54
'函数描述：通过模型进行84到54的线转换
'参数说明：pInPolyline:线要素
'返回值：返回转换后的线
'*******************************************************
Public Function PolylineTrans(pInPolyline As IPolyline) As IPolyline
On Error GoTo err
    Dim pInGeoCol As IGeometryCollection
    Set pInGeoCol = pInPolyline
    Dim pInPoint As IPoint
    Dim pInGeo As IGeometry
    Dim pPtCol As IPointCollection
    Dim i, j As Long
    For i = 0 To pInGeoCol.GeometryCount - 1  '循环Geometry
        Set pInGeo = pInGeoCol.Geometry(i)
        Set pPtCol = pInGeo
        For j = 0 To pPtCol.PointCount - 1
            Set pInPoint = pPtCol.Point(j)
            Set pInPoint = PointTrans(pInPoint)  '对每个点进行转换
             pPtCol.ReplacePoints j, 1, 1, pInPoint
        Next j
    Next i
    Set PolylineTrans = pInPolyline
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'*******************************************************
'函数名称：PolylineDefTrans
'函数描述：自定义的线转换
'参数说明：pInPolyline:线要素
'返回值：返回转换后的线
'*******************************************************
Public Function PolylineDefTrans(pInPolyline As IPolyline) As IPolyline
On Error GoTo err
    Dim pInGeoCol As IGeometryCollection
    Set pInGeoCol = pInPolyline
    Dim pInPoint As IPoint
    Dim pInGeo As IGeometry
    Dim pPtCol As IPointCollection
    Dim i, j As Long
    For i = 0 To pInGeoCol.GeometryCount - 1 '循环Geometry
        Set pInGeo = pInGeoCol.Geometry(i)
        Set pPtCol = pInGeo
        For j = 0 To pPtCol.PointCount - 1
            Set pInPoint = pPtCol.Point(j)
            Set pInPoint = PointDefTrans(pInPoint) '对每个点进行转换
             pPtCol.ReplacePoints j, 1, 1, pInPoint
        Next j
    Next i
    Set PolylineDefTrans = pInPolyline
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function

'*******************************************************
'函数名称：PolygonTrans
'函数描述：通过模型进行面转换
'参数说明：pInPolygon：面要素
'返回值：返回转换后的面
'*******************************************************
Public Function PolygonTrans(pInPolygon As IPolygon) As IPolygon
On Error GoTo err
    Dim pInGeoCol As IGeometryCollection
    Set pInGeoCol = pInPolygon
    Dim pInPoint As IPoint
    Dim pInGeo As IGeometry
    Dim pPtCol As IPointCollection
    Dim i, j As Long
    For i = 0 To pInGeoCol.GeometryCount - 1  '循环每个Geometry
        Set pInGeo = pInGeoCol.Geometry(i)
        Set pPtCol = pInGeo
        For j = 0 To pPtCol.PointCount - 1
            Set pInPoint = pPtCol.Point(j)
            Set pInPoint = PointTrans(pInPoint) '对每个点进行转换
             pPtCol.ReplacePoints j, 1, 1, pInPoint
        Next j
    Next i
    Set PolygonTrans = pInPolygon
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'*******************************************************
'函数名称：PolygonDefTrans
'函数描述：自定义转换
'参数说明：pInPolygon：面要素
'返回值：返回转换后的面
'*******************************************************
Public Function PolygonDefTrans(pInPolygon As IPolygon) As IPolygon
On Error GoTo err
    Dim pInGeoCol As IGeometryCollection
    Set pInGeoCol = pInPolygon
    Dim pInPoint As IPoint
    Dim pInGeo As IGeometry
    Dim pPtCol As IPointCollection
    Dim i, j As Long
    For i = 0 To pInGeoCol.GeometryCount - 1 '循环Geometry
        Set pInGeo = pInGeoCol.Geometry(i)
        Set pPtCol = pInGeo
        For j = 0 To pPtCol.PointCount - 1  '循环每个点
            Set pInPoint = pPtCol.Point(j)
            Set pInPoint = PointDefTrans(pInPoint) '对每个点进行转换
            pPtCol.ReplacePoints j, 1, 1, pInPoint '用新的点代替
        Next j
    Next i
    Set PolygonDefTrans = pInPolygon
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'
'*******************************************************
'函数名称：getFileSRType
'函数描述：获得参考类型
'参数说明：FilePath：shape文件路径 FileName:shape文件名
'返回值：文件空间参考类型
'*******************************************************
Public Function getFileSRType(FilePath As String, FileName As String) As String
On Error GoTo err
    Dim pWFactory As IWorkspaceFactory
    Dim pFWorkspace As IFeatureWorkspace
    Set pWFactory = New ShapefileWorkspaceFactory
    Set pFWorkspace = pWFactory.OpenFromFile(FilePath, 0) '打开工作空间
    Set pFClass = pFWorkspace.OpenFeatureClass(FileName)
    Dim pGeoDataset As IGeoDataset
    Set pGeoDataset = pFClass
    Dim pSpatial As ISpatialReference
    Set pSpatial = pGeoDataset.SpatialReference
    If TypeOf pSpatial Is IProjectedCoordinateSystem Then '平面坐标
        getFileSRType = "平面坐标"
    ElseIf TypeOf pSpatial Is IGeographicCoordinateSystem Then '地理坐标
        getFileSRType = "地理坐标"
    Else
        getFileSRType = "无坐标参考"
    End If
    Set pWFactory = Nothing
    Set pFWorkspace = Nothing
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'
'*******************************************************
'函数名称：getFileSRName
'函数描述：获得参考名
'参数说明：FilePath：shape文件路径 FileName:shape文件名
'返回值：空间参考名
'*******************************************************
Public Function getFileSRName(FilePath As String, FileName As String) As String
On Error GoTo err
    Dim pWFactory As IWorkspaceFactory
    Dim pFWorkspace As IFeatureWorkspace
    Set pWFactory = New ShapefileWorkspaceFactory
    Set pFWorkspace = pWFactory.OpenFromFile(FilePath, 0) '打开Shape文件
    Set pFClass = pFWorkspace.OpenFeatureClass(FileName)
    Dim pGeoDataset As IGeoDataset
    Set pGeoDataset = pFClass
    Dim pSpatial As ISpatialReference
    Set pSpatial = pGeoDataset.SpatialReference
    getFileSRName = pSpatial.Name  '得到空间参考名
    '清空
    Set pWFactory = Nothing
    Set pFWorkspace = Nothing
    Exit Function
err:
    MsgBox "没有找到对应的Shape文件", vbInformation + vbOKOnly, "提示"
    err.Clear
End Function
'平面获取其分带带号
'*******************************************************
'函数名称：getPrjNo
'函数描述：平面获取其分带带号
'参数说明：pSpatial：空间参考
'返回值：空间参考带号
'*******************************************************
Public Function getPrjNo(pSpatial As ISpatialReference) As Long
On Error GoTo err
    If TypeOf pSpatial Is IProjectedCoordinateSystem Then '平面坐标
        Dim pPro As IProjectedCoordinateSystem2
        Set pPro = pSpatial
        If g_NOInfo = 3 Then  '3度分带
            getPrjNo = (pPro.CentralMeridian(True)) / 3
        ElseIf g_NOInfo = 6 Then '6度分带
            getPrjNo = (pPro.CentralMeridian(True) + 3) / 6
        End If
    End If
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function

'*******************************************************
'函数名称：getAddNO
'函数描述：如果x的值长度大于6，说明加带号，等于6，说明不加带号
'参数说明：pFeature：任意要素
'返回值：返回是否加带号
'*******************************************************

Public Function getAddNO(pSpatial As ISpatialReference) As String
On Error GoTo err
'    Dim lX As Long
'    lX = pFeature.Extent.XMax
'    If Len(CStr(lX)) > 6 Then '大于6
'        getAddNO = ""
'    ElseIf Len(CStr(lX)) = 6 Then '等于6
'        getAddNO = "不"
'    End If

    If TypeOf pSpatial Is IProjectedCoordinateSystem Then
        Dim pPro As IProjectedCoordinateSystem
        Set pPro = pSpatial
        If pPro.FalseEasting > 500000 Then
            getAddNO = ""
        Else
            getAddNO = "不"
        End If
    End If
    Exit Function
err:
    MsgBox err.Description, vbInformation + vbOKOnly, "系统"
End Function
'*******************************************************
'函数名称：AddReport
'函数描述：增加报告记录
'参数说明：RPContent ：报告内容
'返回值：
'*******************************************************
Public Sub AddReport(RPContent As String)
On Error Resume Next
    ReportNum = ReportNum + 1  '记录序号增加1
    Dim nItem As ListItem
    Set nItem = frmShpTrans.lstReport.ListItems.Add(, , ReportNum)
    nItem.SubItems(1) = RPContent
End Sub