clsevaluatewizard.cls

FloodEvaluation-程序是gis方面的程序

    End If
    
    Dim pMouseCursor As IMouseCursor
    Set pMouseCursor = New MouseCursor
    pMouseCursor.SetCursor 2
        
    Call planarSum(pFloodRangeLyr, pPlanarPropLyr, strResultFile, strResultPath, _
                   itemName, itemPrice, numRatio, pApp)
    
    '将计算结果（矢量）上传到SDE库
    If Not pSdeFWS Is Nothing Then
        If pSdeFWS.Type = esriRemoteDatabaseWorkspace Then
            Dim strSdeName As String
            strSdeName = Left(strResultFile, Len(strResultFile) - 4)
            Dim sdeProperSet As IPropertySet
            Set sdeProperSet = pSdeFWS.connectionProperties
            Call LoadShpfileToSDE(strResultFile, strResultPath, strSdeName, sdeProperSet, pSdeFWS)
        End If
    End If
    
    Set pMouseCursor = Nothing
    planarPropSum = True
    Exit Function
    
ERH:
    MsgBox "受灾统计失败0" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
    planarPropSum = False
End Function


'************************************************************************************************'''
''''planarSum
'************************************************************************************************'''
Public Sub planarSum(pFloodRangeLyr As IFeatureLayer, pPlanarPropLyr As IFeatureLayer, _
                     strResultFile As String, strResultPath As String, itemName As String, _
                     itemPrice As Integer, numRatio As Single, pApp As IApplication)
    
    On Error GoTo errHandle
    
    ' Create the RasterExtractionOp/MathOps object
    Dim pWorkspaceFactory As IWorkspaceFactory
    Dim pFeatureWorkspace As IFeatureWorkspace
    
    Dim pSpaRef As ISpatialReference
    Set pSpaRef = GetLayerSourceSpatialRef(pPlanarPropLyr)      'New UnknownCoordinateSystem
    
'    Set pFeatureWorkspace = Nothing
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strResultPath, 0)
    Dim pFlds As IFields
    Set pFlds = CreateFeatureFields(esriGeometryPolygon, True, False, pSpaRef, itemName)
    
    Call AppendField(pFlds, "地区", esriFieldTypeString, False)
    Call AppendField(pFlds, "财物总量", esriFieldTypeInteger, False)
    Call AppendField(pFlds, "面积", esriFieldTypeDouble, False)
    Call AppendField(pFlds, "受灾面积", esriFieldTypeDouble, False)
    Call AppendField(pFlds, "受灾数量", esriFieldTypeInteger, False)
    Call AppendField(pFlds, "受灾损失", esriFieldTypeDouble, False)
    
    Dim pCLSID As UID
    Set pCLSID = New UID
    pCLSID.Value = "esricore.Feature"
    Dim pFClass As IFeatureClass
    Set pFClass = pFeatureWorkspace.CreateFeatureClass(Left(strResultFile, Len(strResultFile) - 4), _
    pFlds, pCLSID, Nothing, esriFTSimple, "Shape", "")
    
    '设置有关字段的索引号
    Dim indexName As Integer, indexProp As Integer, indexFloodLoss1 As Integer
    Dim indexName1 As Integer, indexProp1 As Integer, indexFloodProp1 As Integer, indexFloodArea1 As Integer, indexArea1 As Integer
    Dim pFields As IFields
    Set pFields = pPlanarPropLyr.FeatureClass.Fields
    indexName = pFields.FindField("地区")                   '政区名称
    indexProp = pFields.FindField("财物总量")               '政区人口
    
    indexName1 = pFlds.FindField("地区")                    '政区名称
    indexProp1 = pFlds.FindField("财物总量")                '政区人口
    indexArea1 = pFlds.FindField("面积")                    '政区面积
    indexFloodArea1 = pFlds.FindField("受灾面积")           '受灾面积
    indexFloodProp1 = pFlds.FindField("受灾数量")           '受灾人口
    indexFloodLoss1 = pFlds.FindField("受灾损失")           '受灾人口
'    MsgBox indexName & "-" & indexName1 & "-" & indexProp1 & "-" & indexArea1 & "-" & indexProp
    
    Dim pOutCursor As IFeatureCursor
    Set pOutCursor = pFClass.Insert(True)
    Dim pOutBuffer As IFeatureBuffer
    Set pOutBuffer = pFClass.CreateFeatureBuffer

    Dim pFilter As IQueryFilter
    Set pFilter = New QueryFilter
    pFilter.WhereClause = ""

    Dim pFloodCursor As IFeatureCursor, pPropCursor As IFeatureCursor
    Set pPropCursor = pPlanarPropLyr.Search(pFilter, False)

    Dim sumArea As Double
    Dim pTopologOp As ITopologicalOperator, pGeoResult As IGeometry
    Dim pPropArea As IArea, pAndArea As IArea
    Dim pPropPoly As IPolygon, pFloodPoly As IPolygon
    Dim pPropFeat As IFeature, pFloodFeat As IFeature
    
    Set pPropFeat = pPropCursor.NextFeature
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not pPropFeat Is Nothing
    
        Set pTopologOp = pPropFeat.Shape
        Set pFloodCursor = pFloodRangeLyr.Search(pFilter, False)
        Set pFloodFeat = pFloodCursor.NextFeature
        sumArea = 0
        
        Do While Not pFloodFeat Is Nothing
            Set pFloodPoly = pFloodFeat.Shape
            Set pGeoResult = pTopologOp.Intersect(pFloodPoly, esriGeometry2Dimension)
            Set pAndArea = pGeoResult
            sumArea = sumArea + pAndArea.Area
            Set pFloodFeat = pFloodCursor.NextFeature
        Loop
        
        Set pOutBuffer.Shape = pPropFeat.Shape
        Set pPropArea = pPropFeat.Shape
        
        pOutBuffer.Value(indexName1) = pPropFeat.Value(indexName)                                     '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexProp1) = pPropFeat.Value(indexProp)                                     '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexArea1) = pPropArea.Area                                                 '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexFloodArea1) = sumArea                                                   '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexFloodProp1) = pPropFeat.Value(indexProp) * sumArea / pPropArea.Area     '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexFloodLoss1) = pOutBuffer.Value(indexFloodProp1) * itemPrice             '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        
        pOutCursor.InsertFeature pOutBuffer
        Set pPropFeat = pPropCursor.NextFeature
    
    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not filterFeat Is Nothing
     
     
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    Dim pPolygonLayer As IFeatureLayer
    Set pPolygonLayer = New FeatureLayer
    Set pPolygonLayer.FeatureClass = pFClass
    Call setFeatureLayerRenderer(pPolygonLayer, vbBlue)
    
    pPolygonLayer.name = "受灾分布"
    pMxDoc.FocusMap.AddLayer pPolygonLayer   'pRL
    pMxDoc.ActiveView.Refresh
'    Set pPolygonLayer = Nothing
    
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    Set pOutBuffer = Nothing
    Set pOutCursor = Nothing
    
    Exit Sub 'exit sub to avoid error handler

errHandle:
    MsgBox "受灾统计失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
 
End Sub

 
 



'**************************************************************************************************************
'''evaluateSum
'**************************************************************************************************************
'************************************************************************************************''''''
'''''' evaluateSum,调用createAndPlusFirst、plusAnother创建基于行政区的输出图层并对栅格、矢量评估结果进行统计
'************************************************************************************************''''''
Public Function evaluateSum(pApp As IApplication, _
                       Optional ByRef pSdeFWS As IWorkspace = Nothing, _
                       Optional ByRef adoCnn As ADODB.Connection = Nothing) As Boolean
    On Error GoTo ERH
      
'    Set pResultShpLyr = New FeatureLayer
    Dim bContinue As Boolean
    bContinue = createAndPlusFirst
    
    If Not bContinue Then Exit Function
    
    Dim nResult As Integer
    nResult = MsgBox("评价其他损失项目", vbYesNo)
    
    While nResult = vbYes
            
        Call plusAnother
        nResult = MsgBox("继续评价其他项目", vbYesNo)

    Wend
    
    Call setFeatureLayerRenderer(pResultShpLyr, vbBlack)
    
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    pResultShpLyr.name = "洪损统计"
    pMxDoc.FocusMap.AddLayer pResultShpLyr
    pMxDoc.ActiveView.Refresh
    
    '将计算结果（矢量）上传到SDE库
    If Not pSdeFWS Is Nothing Then
        If pSdeFWS.Type = esriRemoteDatabaseWorkspace Then
            Dim strSdeName As String
            strSdeName = Left(m_strResultFile, Len(m_strResultFile) - 4)
            Dim sdeProperSet As IPropertySet
            Set sdeProperSet = pSdeFWS.connectionProperties
            Call LoadShpfileToSDE(m_strResultFile, m_strResultPath, strSdeName, sdeProperSet, pSdeFWS)
        End If
    End If
        
    Call addSumInfo(adoCnn)
    Set pResultShpLyr = Nothing
    evaluateSum = True
    Exit Function
    
ERH:
    MsgBox "损失统计失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
    evaluateSum = False
End Function


'************************************************************************************************''''''
'''''' polygonSum,先创建输出矢量文件，然后统计第一个图层
'************************************************************************************************''''''
Public Function createAndPlusFirst() As Boolean
    On Error GoTo ERH
    
    Dim strResultPath As String, strResultFile As String, strTemp As String
    Dim pDistrictLyr As IFeatureLayer, inputLyr As ILayer
    Dim fs
    
    frmEvaluateSum.Left = (Screen.Width - frmEvaluateSum.Width) / 2
    frmEvaluateSum.Top = (Screen.Height - frmEvaluateSum.Height) / 2
    frmEvaluateSum.txtEvaluateRaster = ""
    frmEvaluateSum.txtPolygon = ""
    frmEvaluateSum.Show vbModal

    If frmEvaluateSum.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")
        
        Set pDistrictLyr = frmEvaluateSum.shpPolygonLyr
        Set inputLyr = frmEvaluateSum.lossLyr
        strResultFile = frmEvaluateSum.txtPathResult

        If fs.FileExists(strResultFile) Then '
             fs.DeleteFile (strResultFile)
        End If
        
        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + ".dbf") Then '
             fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + ".dbf")
        End If
        
        Call SplitPath(strResultFile, strResultPath, strTemp)
        strResultFile = strTemp
        m_txtTotalLossSde = Left(strTemp, Len(strTemp) - 4)

        m_strResultFile = strResultFile
        m_strResultPath = strResultPath
        
    Else
        MsgBox "放弃区域统计", vbInformation + vbOKOnly, "提示信息"
        GoTo ERH
    End If
    
    Dim pMouseCursor As IMouseCursor
    Set pMouseCursor = New MouseCursor
    pMouseCursor.SetCursor 2
                       
    Dim bRet As Boolean
    
    bRet = createResultLyr(pDistrictLyr, strResultPath, strResultFile)
    If bRet = False Then
        MsgBox "统计出错", vbInformation + vbOKOnly, "提示信息"
        createAndPlusFirst = False
        Exit Function
    End If
    
    If TypeOf inputLyr Is IFeatureLayer Then
        bRet = plusLossFeatLyr(inputLyr)
    Else
        If TypeOf inputLyr Is IRasterLayer Then
             bRet = plusLossRasterLyr(inputLyr)
        Else
             MsgBox "输入图层有误", vbInformation + vbOKOnly, "提示信息"
             createAndPlusFirst = False
             Exit Function
        End If
    End If
    
    If bRet = False Then
        MsgBox "统计出错", vbInformation + vbOKOnly, "提示信息"
        createAndPlusFirst = False
        Exit Function
    End If
    
    createAndPlusFirst = True
    Set pMouseCursor = Nothing
    
    Exit Function 'exit sub to avoid error handler

ERH:
    MsgBox "洪损统计失败1" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
    createAndPlusFirst = False
    
End Function

'************************************************************************************************''''''