clsevaluatewizard.cls

FloodEvaluation-程序是gis方面的程序

                                                                                       'j         i
            If m_bSumResultFirst Then vSafeArray1(i, j) = 0 'initialize result raster  'j         i
                                                                                       'j         i
            depth = pDepthBlock.GetVal(0, i, j)
            If pLUBlock.GetVal(0, i, j) = cropTypeID Then  '该种作物的分类值            'j         i
                selLossRate = lossRate(1)                                              'j         i
                                                                                       'j         i
                For k = 1 To numBreak ''''''''''''''''''''''''''''''''''''''''''''k    'j         i
                    If depth >= depthBreak(k) Then                               'k    'j         i
                       selLossRate = lossRate(k + 1)                             'k    'j         i
                       Exit For                                                  'k    'j         i
                    End If                                                       'k    'j         i
                Next k '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''k    'j         i
                                                                                       'j         i
                vSafeArray(i, j) = CSng(selLossRate * cropPrice / 666.7)               'j         i
                vSafeArray1(i, j) = vSafeArray1(i, j) + vSafeArray(i, j)               'j         i
                                                                                       'j         i
            End If                                                                     'j         i
                                                                                       'j         i
        Next j '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''j         i
                                                                                                 'i
    Next i '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''i
    
    If m_bSumResultFirst Then m_bSumResultFirst = False

    ' Write out the result
    pOutputRawPixel.Write pPnt, pOutputBlock
    pOutputRawPixel1.Write pPnt, pOutputBlock1
        
    Set pWSF = Nothing
    Set pOrigin = Nothing
    Set pPnt = Nothing
    Set pMouseCursor = Nothing
    
    Exit Sub
    
ERH:
    MsgBox "作物损失单项评估失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"

End Sub


'************************************************************************************************''''''
'''CutRasByShp，用多边形提取栅格图斑

'************************************************************************************************''''''
Public Function CutRasByShp(strPolygonFile As String, strPolygonPath As String, _
                            rasLanduse As IRaster, strGRIDPath As String) As IRaster 'GeoDataset
    On Error GoTo ERH
    
    Dim pWorkspaceFactory As IWorkspaceFactory
    Dim pFeatureWorkspace As IFeatureWorkspace
    Dim pFeaLyr As IFeatureLayer
    
    Dim pWks As IRasterWorkspace
    Dim pWksF As IWorkspaceFactory
    Dim pRasLyr As IRasterLayer
    
    Dim pEnv As IRasterAnalysisEnvironment
    
    'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strPolygonPath, 0)
    Set pFeaLyr = New FeatureLayer
    Set pFeaLyr.FeatureClass = pFeatureWorkspace.OpenFeatureClass(strPolygonFile)
   
'    Dim inputRaster As IRaster
'    Set inputRaster = OpenRasterDataset(strGRIDPath, strGRIDFile).CreateDefaultRaster
'
    Dim pTempDS As IGeoDataset
    Set pTempDS = pFeaLyr.FeatureClass
    Dim pConOp As IConversionOp
    Set pConOp = New RasterConversionOp
    Set pEnv = pConOp
    Dim pProp As IRasterProps
    Set pProp = rasLanduse
    pEnv.SetCellSize esriRasterEnvValue, pProp.MeanCellSize.X
    
    ' Delete the existing file
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strGRIDPath + "\" + "CovTemp") Then                'FileExists
        fs.Deletefolder (strGRIDPath + "\" + "CovTemp")                   'Deletefile
    End If
                
'    Dim pWks As IWorkspace
    Set pWksF = New RasterWorkspaceFactory
    Set pWks = pWksF.OpenFromFile(strGRIDPath, 0)
    Dim pGeoDs As IRasterDataset
    Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "GRID", pWks, "CovTemp") '转为栅格
    
    Dim pLogicalOp As ILogicalOp
    Dim pConditionalOp As IConditionalOp
    Set pLogicalOp = New RasterMathOps
    Set pConditionalOp = New RasterConditionalOp

    Dim pZeroRaster As IRaster
    Dim pMathOp As IMathSupportOp
    Set pMathOp = New RasterMathSupportOp
    
    Set pZeroRaster = pMathOp.Minus(pGeoDs, pGeoDs)
    Dim pOutRas1 As IRaster 'GeoDataset
    Set pOutRas1 = pConditionalOp.Con(pLogicalOp.GreaterThanEqual(pGeoDs, pZeroRaster), rasLanduse) '提取洪水范围内的LU

    Set CutRasByShp = pOutRas1
    
    Set pEnv = Nothing
    Set pWks = Nothing
    Set pWksF = Nothing
    Set pConOp = Nothing
    Set pFeaLyr = Nothing
    Set pTempDS = Nothing
    Set pMathOp = Nothing
    Set pLogicalOp = Nothing
    Set pConditionalOp = Nothing
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    
    Exit Function
ERH:
    MsgBox ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Function

'************************************************************************************************''''''
'''''' 记录作物评估属性
'************************************************************************************************''''''
Public Sub addCropLossInfo(inputRaster As IRaster, _
                           districtLyr As IFeatureLayer, _
                           adoCnn As ADODB.Connection)
On Error GoTo ERH

    Dim cropRS As ADODB.Recordset
    Set cropRS = GetWritableRS("evalTotalCrop", adoCnn)
    
    If Not bFloodInfoOK Then
        frmFloodInfo.Left = (Screen.Width - frmFloodInfo.Width) / 2
        frmFloodInfo.Top = (Screen.Height - frmFloodInfo.Height) / 2
        frmFloodInfo.Show vbModal
    End If

    Dim pExtractionOp As IExtractionOp
    Set pExtractionOp = New RasterExtractionOp
    Dim districtName As String, polySummary As Double, theArea As Long
    Dim pPolygon As IPolygon, pExtractRaster As IRaster

    Dim indexName As Integer
    indexName = districtLyr.FeatureClass.Fields.FindField("地区")
    
    '设置有关字段的索引号
'    Dim indexName As Integer, indexName1 As Integer, indexFloodLoss1 As Double
'    Dim pFields As IFields
'    Set pFields = pResultShpLyr.FeatureClass.Fields
'    indexFloodLoss1 = pFields.FindField("受灾损失")  '受灾损失

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

    Dim pOutCursor As IFeatureCursor
    Set pOutCursor = districtLyr.Search(pFilter, False)

    Dim polyFeat As IFeature
    Set polyFeat = pOutCursor.NextFeature
    theArea = 2
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not polyFeat Is Nothing

        Set pPolygon = polyFeat.Shape
        MsgBox polyFeat.Value(indexName)
'Dim pMxDoc As IMxDocument
'Set pMxDoc = m_pApp.Document
'Dim rasLyr As IRasterLayer
'Set rasLyr = New RasterLayer
'rasLyr.CreateFromRaster inputRaster 'pExtractRaster
'pMxDoc.FocusMap.AddLayer rasLyr   'pRL
'pMxDoc.ActiveView.Refresh
        Set pExtractRaster = pExtractionOp.Polygon(inputRaster, pPolygon, True)
        Call rasterSum2(pExtractRaster, polySummary, theArea)
MsgBox polySummary & theArea
        districtName = polyFeat.Value(indexName)
        Call AppendEvalTotalCropRecord(cropRS, theFloodName, theFloodDate, districtName, theArea, polySummary)
        Set polyFeat = pOutCursor.NextFeature

    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not polyFeat Is Nothing


'    Set pResultShpLyr = resultLyr
    Set pFilter = Nothing
    Set pOutCursor = Nothing
    Set pExtractionOp = Nothing

    Exit Sub      'exit sub to avoid error handler

ERH:
    MsgBox "记录作物损失统计失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub

'************************************************************************************************''''''
'''''' 记录单种作物评估属性
'************************************************************************************************''''''
Public Sub addOneCropLossInfo(inputRaster As IRaster, _
                           districtLyr As IFeatureLayer, _
                           cropName As String, _
                           adoCnn As ADODB.Connection)
On Error GoTo ERH

Dim cropRS As ADODB.Recordset
Set cropRS = GetWritableRS("evalOneCrop", adoCnn)

If Not bFloodInfoOK Then
    frmFloodInfo.Left = (Screen.Width - frmFloodInfo.Width) / 2
    frmFloodInfo.Top = (Screen.Height - frmFloodInfo.Height) / 2
    frmFloodInfo.Show vbModal
End If

    Dim pExtractionOp As IExtractionOp
    Set pExtractionOp = New RasterExtractionOp
    Dim districtName As String, polySummary As Double, theArea As Long
    Dim pPolygon As IPolygon, pExtractRaster As IRaster

    Dim indexName As Integer
    indexName = districtLyr.FeatureClass.Fields.FindField("地区")
    
    Dim pFilter As IQueryFilter
    Set pFilter = New QueryFilter
    pFilter.WhereClause = ""

    Dim pOutCursor As IFeatureCursor
    Set pOutCursor = districtLyr.Search(pFilter, False)

    Dim polyFeat As IFeature
    Set polyFeat = pOutCursor.NextFeature
    theArea = 0
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not polyFeat Is Nothing
    
        Set pPolygon = polyFeat.Shape
        Set pExtractRaster = pExtractionOp.Polygon(inputRaster, pPolygon, True)
        Call rasterSum(pExtractRaster, polySummary) ', theArea)
        
        districtName = polyFeat.Value(indexName)
        Call AppendEvalOneCropRecord(cropRS, theFloodName, theFloodDate, districtName, cropName, theArea, polySummary)
        Set polyFeat = pOutCursor.NextFeature

    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not polyFeat Is Nothing

'    Set pResultShpLyr = resultLyr
    Set pFilter = Nothing
    Set pOutCursor = Nothing
    Set pExtractionOp = Nothing

    Exit Sub      'exit sub to avoid error handler

ERH:
    MsgBox "记录作物损失统计失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub

 

'************************************************************************************************'''
' 评估面状财物
'************************************************************************************************'''
'************************************************************************************************'''
''''planarPropSum对面状财物进行评估
'************************************************************************************************'''
Public Function planarPropSum(pApp As IApplication, _
                              Optional ByRef pSdeFWS As IWorkspace = Nothing) As Boolean
    On Error GoTo ERH
    
    Dim sWorkPath As String, sShapeFileName As String, sGridFileName As String
    Dim pOutRas1 As IGeoDataset
    Dim fs
    Dim strResultPath As String, strResultFile As String, strTemp As String
    Dim itemName As String, itemPrice As Integer, numRatio As Single
    Dim pPlanarPropLyr As IFeatureLayer, pFloodRangeLyr As IFeatureLayer
    
    frmEvaluatePlane.Left = (Screen.Width - frmEvaluatePlane.Width) / 2
    frmEvaluatePlane.Top = (Screen.Height - frmEvaluatePlane.Height) / 2
    frmEvaluatePlane.strFloodArea = ""
    frmEvaluatePlane.strPlanarProp = ""
    frmEvaluatePlane.Show vbModal

    If frmEvaluatePlane.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")

        strResultFile = frmEvaluatePlane.txtPathResult          '统计的结果，shape格式
        itemName = frmEvaluatePlane.strItemName
        numRatio = CSng(frmEvaluatePlane.txtRatio)
        itemPrice = CInt(frmEvaluatePlane.strItemPrice)
        
        Set pPlanarPropLyr = frmEvaluatePlane.shpPlanarPropLyr
        Set pFloodRangeLyr = frmEvaluatePlane.shpFloodAreaLyr

        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

    Else
        MsgBox "放弃评估", vbInformation + vbOKOnly, "提示信息"
        planarPropSum = False
        Exit Function