clsevaluateother.cls

FloodEvaluation-程序是gis方面的程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsEvaluateOther"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'************************************************************************************************
'*********************** 其他设施、财物等洪水淹没损失评估                   ***********************
'*********************** The result is raster cells                       ***********************
'*********************** ZHANG Wenjiang, 2004/04/19                       ***********************
'************************************************************************************************

Option Explicit

Dim m_pCommand As ICommand
Dim m_pTool As ITool
Dim m_pSketchTool As ISketchTool
Dim pApp As IApplication

Dim itempName As String
Implements ICommand

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
  ICommand_Bitmap = frmResources.picUnderline.Picture
End Property

Private Property Get ICommand_Caption() As String
  ICommand_Caption = "其他项目评估"
End Property

Private Property Get ICommand_Category() As String
  ICommand_Category = "洪损评估"
End Property

Private Property Get ICommand_Checked() As Boolean
  ICommand_Checked = False
End Property

Private Property Get ICommand_Enabled() As Boolean
  ICommand_Enabled = True
End Property

Private Property Get ICommand_HelpContextID() As Long

End Property

Private Property Get ICommand_HelpFile() As String

End Property

Private Property Get ICommand_Message() As String
    ICommand_Message = "其他项目评估"
End Property

Private Property Get ICommand_Name() As String
    ICommand_Name = "CustomSketch.SketchTool"
End Property

Private Sub ICommand_OnClick()
    Call EvaluateLoss
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
On Error GoTo ErrorHandler:
  
    Set pApp = hook
    Set m_pCommand = CreateObject("esricore.SketchTool")
    m_pCommand.OnCreate hook
    Set m_pTool = m_pCommand
    Set m_pSketchTool = m_pCommand
    Exit Sub
    
ErrorHandler:
    MsgBox "OnCreate - " & ERR.Description
    Exit Sub
End Sub

Private Property Get ICommand_Tooltip() As String
    ICommand_Tooltip = "其他项目评估"
End Property


'************************************************************************************************''''
'''EvaluateLoss对损失进行评估，调用oneItemSum具体实现

'************************************************************************************************'''
Public Sub EvaluateLoss()
    On Error GoTo ERH
    
    Dim sWorkPath As String, sShapeFileName As String, sGridFileName As String
    Dim pOutRas1 As IGeoDataset
    Dim fs
    Dim itemName As String, itemFileName As String, numItemPrice As Integer
    Dim strResultFile As String, strResultPath As String, strTemp As String
    Dim pRasDepth As IRaster, pShpItemDistrLyr As IFeatureLayer
    
    frmEvaluateOther.Left = (Screen.Width - frmEvaluateOther.Width) / 2
    frmEvaluateOther.Top = (Screen.Height - frmEvaluateOther.Height) / 2
    frmEvaluateOther.Show vbModal

    If frmEvaluateOther.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")

        strResultFile = frmEvaluateOther.txtPathResult
        
        Set pRasDepth = frmEvaluateOther.pRasDepthLyr.Raster
        Set pShpItemDistrLyr = frmEvaluateOther.pShpItemDistrLyr
        
        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 "放弃评估"
        GoTo ERH
    End If
    
    frmLossRateDetail.Left = (Screen.Width - frmLossRateDetail.Width) / 2
    frmLossRateDetail.Top = (Screen.Height - frmLossRateDetail.Height) / 2

    frmLossRateDetail.cmdContinue.Visible = False
    frmLossRateDetail.Show vbModal  '''''''''''''''''''''''''''''''''''''''指定作物的洪水损失率
    If frmLossRateDetail.bOKFlag Then
'        itemName = frmLossRateDetail.strCropName
        itemName = frmLossRateDetail.strCropName
        itemFileName = frmLossRateDetail.strCropName
        numItemPrice = CInt(frmLossRateDetail.strRicePrice)
    Else
        MsgBox "放弃评估"
        GoTo ERH
    End If
            
'    Call oneItemSum(strPolygonFile, strPolygonPath, strGRIDFile, strGRIDPath, strResultFile, strResultPath)
    
    Dim displayLyr As IFeatureLayer
    Set displayLyr.FeatureClass = OpenShapeFile(strResultPath, strResultFile)
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    pMxDoc.FocusMap.AddLayer displayLyr
    pMxDoc.ActiveView.Refresh

    Exit Sub
    
ERH:
    MsgBox "单项评估失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub


'************************************************************************************************''''
'''oneItemSum对损失进行评估

'************************************************************************************************'''
Public Sub oneItemSum(strPolygonFile As String, strPolygonPath As String, strGRIDFile As String, strGRIDPath As String, strResultFile As String, strResultPath As String, itemName As String)
    
    On Error GoTo errHandle
    
    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 pRasterDS  As IRasterDataset
    Set pRasterDS = OpenRasterDataset(strGRIDPath, strGRIDFile)
    Dim inputRaster As IRaster
    Set inputRaster = pRasterDS.CreateDefaultRaster
    
    Dim pRasterBandCollection As IRasterBandCollection
    Set pRasterBandCollection = inputRaster
    Dim pRasterBand As iRasterBand
    Set pRasterBand = pRasterBandCollection.Item(0)
    Dim pInputRasProps As IRasterProps
    Set pInputRasProps = pRasterBand
    
    Dim pExtractionOp As IExtractionOp
    Dim pLogicalOp As ILogicalOp
    Dim pConditionalOp As IConditionalOp
    Dim pMathOp As IMathSupportOp
    Set pExtractionOp = New RasterExtractionOp
    Set pLogicalOp = New RasterMathOps
    Set pConditionalOp = New RasterConditionalOp
    Set pMathOp = New RasterMathSupportOp
    
    Dim strName As String
    Dim pPolygon As IPolygon
    Dim pExtractRaster As IRaster, pZeroRaster As IRaster
    
    Dim pRMOp As IRasterMakerOp
    Set pRMOp = New RasterMakerOp
    Set pZeroRaster = pRMOp.MakeConstant(-1, True)
    
    Dim pSpaRef As ISpatialReference
    Set pSpaRef = GetLayerSourceSpatialRef(pFeaLyr)
    
    Set pFeatureWorkspace = Nothing
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strResultPath, 0)
    Dim pFlds As IFields
    Set pFlds = CreateFeatureFields(esriGeometryPolygon, True, False, pSpaRef, itemName)
    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 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 pFeatCursor As IFeatureCursor
    Set pFeatCursor = pFeaLyr.Search(pFilter, False)

    Dim filterFeat As IFeature
    Set filterFeat = pFeatCursor.NextFeature
    Dim pArea As IArea
    Dim itemCount As Integer, numArea As Long
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not filterFeat Is Nothing
        Set pPolygon = filterFeat.Shape
        Set pArea = pPolygon
        Set pOutBuffer.Shape = pPolygon
        Set pExtractRaster = pExtractionOp.Polygon(inputRaster, pPolygon, True)
        numArea = rasPatchArea(pExtractRaster)                    '计算栅格图斑面积
        pOutBuffer.Value(3) = numArea / pArea.Area * numItemPrice '* itemCount
        pOutCursor.InsertFeature pOutBuffer
        Set filterFeat = pFeatCursor.NextFeature
    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not filterFeat Is Nothing
    
    Set pExtractionOp = Nothing
    Set pLogicalOp = Nothing
    Set pConditionalOp = Nothing
    Set pMathOp = Nothing
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    Set pFeaLyr = Nothing
    Set pFeatCursor = Nothing
    Set pOutBuffer = Nothing
    Set pOutCursor = Nothing
    Set pRMOp = Nothing
    
    Exit Sub 'exit sub to avoid error handler

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