clsevaluateutilities.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 = "clsEvaluateUtilities"
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 m_pApp As IApplication

'Dim itemName 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 EvaluateLines(m_pApp)
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
On Error GoTo ErrorHandler:
  
    Set m_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 EvaluateLines(pApp As IApplication)
    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, numPrice As Integer, strTemp As String
    Dim strResultFile As String, strResultPath As String
    Dim pShpRangeLyr As IFeatureLayer, pShpItemDistrLyr As IFeatureLayer, pShpDistrictLyr As IFeatureLayer
    
    frmEvaluateUtilities.Left = (Screen.Width - frmEvaluateUtilities.Width) / 2
    frmEvaluateUtilities.Top = (Screen.Height - frmEvaluateUtilities.Height) / 2
    frmEvaluateUtilities.Show vbModal

    If frmEvaluateUtilities.flagOK Then

        strResultFile = frmEvaluateUtilities.txtPathResult
        itemName = frmEvaluateUtilities.strItemName
        itemFileName = frmEvaluateUtilities.strItemName
        numPrice = CInt(frmEvaluateUtilities.strItemPrice)
        
        Set pShpItemDistrLyr = frmEvaluateUtilities.pShpItemDistrLyr
        Set pShpRangeLyr = frmEvaluateUtilities.pShpRangeLyr
        Set pShpDistrictLyr = frmEvaluateUtilities.pShpDistrictLyr
        
        Set fs = CreateObject("Scripting.FileSystemObject")
        
        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + "-line.shp") Then '
             fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + "-line.shp")
        End If
        
        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + "-line.dbf") Then '
             fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + "-line.dbf")
        End If
        
        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + "-line.shx") Then '
             fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + "-line.shx")
        End If
        
        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + "-line.sbx") Then '
             fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + "-line.sbx")
        End If
        
        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + "-line.sbn") Then '
             fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + "-line.sbn")
        End If
        
        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
       
        '删除临时文件夹
        If fs.FileExists(strResultPath + "\tempOverlay.dbf") Then '
             fs.DeleteFile (strResultPath + "\tempOverlay.dbf")
        End If
        
        If fs.FileExists(strResultPath + "\tempOverlay.shp") Then '
             fs.DeleteFile (strResultPath + "\tempOverlay.shp")
        End If
       
    Else
        MsgBox "放弃评估"
        Exit Sub
    End If
'    Call lineLoss(itemName, itemFileName, numItemPrice, strResultFile, strResultPath, pShpRangeLyr, pShpDistrictLyr, pShpItemDistrLyr)

    Dim polyOverlayLyr As IFeatureLayer, lineOverlayLyr As IFeatureLayer
    Set polyOverlayLyr = New FeatureLayer
    Set lineOverlayLyr = New FeatureLayer
    
    Set polyOverlayLyr.FeatureClass = Intersect("tempOverlay.shp", strResultPath, pShpDistrictLyr, pShpRangeLyr)
    Set lineOverlayLyr.FeatureClass = Intersect(Left(strResultFile, Len(strResultFile) - 4) + "-line.shp", strResultPath, polyOverlayLyr, pShpItemDistrLyr)
    
    Call lineLoss(itemName, itemFileName, numPrice, strResultFile, strResultPath, pShpDistrictLyr, lineOverlayLyr)
    
    Dim aColor As IRgbColor
    Set aColor = New RgbColor
    aColor.Red = 255
    aColor.Green = 0
    aColor.Blue = 0
    'aColor.Transparency = 50
    
    Call setFeatureLayerRenderer(lineOverlayLyr, vbBlue) 'setLineSymbol(lineOverlayLyr, 2, aColor)
    
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    lineOverlayLyr.name = "受灾" & itemName
    pMxDoc.FocusMap.AddLayer lineOverlayLyr 'displayLyr
    pMxDoc.ActiveView.Refresh

    If fs.FileExists(strResultPath + "\tempOverlay.shx") Then fs.DeleteFile (strResultPath + "\tempOverlay.dbf")
    If fs.FileExists(strResultPath + "\tempOverlay.sbx") Then fs.DeleteFile (strResultPath + "\tempOverlay.sbx")
    If fs.FileExists(strResultPath + "\tempOverlay.sbn") Then fs.DeleteFile (strResultPath + "\tempOverlay.sbn")
    If fs.FileExists(strResultPath + "\tempOverlay.dbf") Then fs.DeleteFile (strResultPath + "\tempOverlay.dbf")
    If fs.FileExists(strResultPath + "\tempOverlay.shp") Then fs.DeleteFile (strResultPath + "\tempOverlay.shp")

    Exit Sub
    
ERH:
    MsgBox "线状设施评估失败0 " & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub


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

'************************************************************************************************'''
Public Sub lineLoss(itemName As String, itemFileName As String, numItemPrice As Integer, _
strResultFile As String, strResultPath As String, _
pShpDistrict As IFeatureLayer, pShpLineOverlay As IFeatureLayer)
    
    On Error GoTo errHandle
    
    '区域内受灾长度
    Dim pSpaRef As ISpatialReference
    Set pSpaRef = GetLayerSourceSpatialRef(pShpDistrict)
    Dim pWorkspaceFactory As IWorkspaceFactory
    Dim pFeatureWorkspace As IFeatureWorkspace
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strResultPath, 0)
    Dim pFlds0 As IFields
    Set pFlds0 = CreateFeatureFields(esriGeometryPolygon, True, False, pSpaRef, itemFileName)
    
    Call AppendField(pFlds0, "地区", esriFieldTypeString, False)
    Call AppendField(pFlds0, "受灾长度", esriFieldTypeInteger, False)
    Call AppendField(pFlds0, "受灾损失", esriFieldTypeDouble, False)
    
    Dim indexName As Integer, indexName0 As Integer, indexFloodLen0 As Integer, indexFloodLoss0 As Integer
    indexName = pShpDistrict.FeatureClass.Fields.FindField("地区")          '政区名称
    indexName0 = pFlds0.FindField("地区")              '政区名称
    indexFloodLen0 = pFlds0.FindField("受灾长度")          '政区名称
    indexFloodLoss0 = pFlds0.FindField("受灾损失")          '政区名称
    Dim pCLSID0 As UID
    Set pCLSID0 = New UID
    pCLSID0.Value = "esricore.Feature"
    Dim pFClass0 As IFeatureClass
    Set pFClass0 = pFeatureWorkspace.CreateFeatureClass(Left(strResultFile, Len(strResultFile) - 4), _
    pFlds0, pCLSID0, Nothing, esriFTSimple, "Shape", "")
    
    '设施受灾情况，跨区域分布
    Dim pOutCursor0 As IFeatureCursor
    Set pOutCursor0 = pFClass0.Insert(True)
    Dim pOutBuffer0 As IFeatureBuffer
    Set pOutBuffer0 = pFClass0.CreateFeatureBuffer

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

    Dim pDistrictCursor As IFeatureCursor, pLineCursor As IFeatureCursor
    Set pDistrictCursor = pShpDistrict.Search(pFilter, False)
       
    Dim pCurve As ICurve, sumLen As Long, filterName As String
    
    Dim pDistrictFeat As IFeature, pLineFeat As IFeature
    Set pDistrictFeat = pDistrictCursor.NextFeature
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not pDistrictFeat Is Nothing
    
'       Set pTopologOp = pDistrictFeat.Shape
        filterName = pDistrictFeat.Value(indexName)
        pSearchFilter.WhereClause = "地区 = '" & filterName & "'"
        Set pLineCursor = pShpLineOverlay.Search(pSearchFilter, False)
        Set pLineFeat = pLineCursor.NextFeature
        sumLen = 0
        
        Do While Not pLineFeat Is Nothing
            Set pCurve = pLineFeat.Shape
            sumLen = sumLen + pCurve.Length
            Set pLineFeat = pLineCursor.NextFeature
        Loop
         
        Set pOutBuffer0.Shape = pDistrictFeat.Shape
        pOutBuffer0.Value(indexName0) = pDistrictFeat.Value(indexName)                          '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer0.Value(indexFloodLen0) = sumLen                                              '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer0.Value(indexFloodLoss0) = sumLen * numItemPrice / 1000                       '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutCursor0.InsertFeature pOutBuffer0
       
        Set pDistrictFeat = pDistrictCursor.NextFeature
    
    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not filterFeat Is Nothing

    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    Set pDistrictCursor = Nothing
    Set pOutBuffer0 = Nothing
    Set pOutCursor0 = Nothing
    
    Exit Sub 'exit sub to avoid error handler

errHandle:
    MsgBox "线状设施评估失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
 
End Sub