clsfloodpopulation.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 = "clsEvaluatePopulation"
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/16                       ***********************
'************************************************************************************************

Option Explicit

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

Implements ICommand

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
  ICommand_Bitmap = frmResources.picABC.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()
    Dim adoCnn As ADODB.Connection
    Set adoCnn = Nothing
    Set adoCnn = ConnectOracle
    
    Dim pFSdeWS As IFeatureWorkspace
    Set pFSdeWS = Nothing
    Set pFSdeWS = SDEConnect("foundway", "port:5150", "sde", "lan811", "myDB")
    Call populationSum(m_pApp, pFSdeWS, adoCnn)
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, vbInformation + vbOKOnly, "提示信息"
    Exit Sub
End Sub

Private Property Get ICommand_Tooltip() As String
    ICommand_Tooltip = "受灾人口统计"
End Property


'************************************************************************************************'''
''''populationSum对受灾人口进行估计，具体工作由populateSum来实现
'************************************************************************************************'''
Public Sub populationSum(pApp As IApplication, _
                         Optional ByRef pSdeFWS As IWorkspace = Nothing, _
                         Optional ByRef adoCnn As ADODB.Connection)
    On Error GoTo ERH
    
    Dim sWorkPath As String, sShapeFileName As String, sGridFileName As String
    Dim pOutRas1 As IGeoDataset
    Dim fs
    Dim strPolygonPath As String, strGRIDPath As String, strResultPath As String
    Dim strPolygonFile As String, strGRIDFile As String, strResultFile As String, strTemp As String
    
    Dim pFeatPopLyr As IFeatureLayer, pFeatFloodRangeLyr As IFeatureLayer
    
    frmEvaluatePopulation.Left = (Screen.Width - frmEvaluatePopulation.Width) / 2
    frmEvaluatePopulation.Top = (Screen.Height - frmEvaluatePopulation.Height) / 2
    frmEvaluatePopulation.strFloodArea = ""
    frmEvaluatePopulation.strPopulate = ""
    frmEvaluatePopulation.Show vbModal

    If frmEvaluatePopulation.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")

        strResultFile = frmEvaluatePopulation.txtPathResult          '统计的结果，shape格式
        
        Set pFeatPopLyr = frmEvaluatePopulation.shpPopulateLyr
        Set pFeatFloodRangeLyr = frmEvaluatePopulation.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
        m_txtPopuSde = Left(strTemp, Len(strTemp) - 4)
        m_txtAreaSde = Left(strTemp, Len(strTemp) - 4)

    Else
        MsgBox "放弃评估", vbInformation + vbOKOnly, "提示信息"
        Exit Sub
    End If
    
    Dim pMouseCursor As IMouseCursor
    Set pMouseCursor = New MouseCursor
    pMouseCursor.SetCursor 2
    
    If Not bFloodInfoOK Then
        frmFloodInfo.Left = (Screen.Width - frmFloodInfo.Width) / 2
        frmFloodInfo.Top = (Screen.Height - frmFloodInfo.Height) / 2
        frmFloodInfo.Show vbModal
    End If
    
    Call populateSum(pFeatFloodRangeLyr, pFeatPopLyr, strResultFile, strResultPath, pApp, adoCnn)
    
    '将计算结果（矢量）上传到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
       
    MsgBox "完成受灾人口统计", vbInformation + vbOKOnly, "提示信息"
    Exit Sub
    
ERH:
    MsgBox "受灾人口统计失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub


'************************************************************************************************'''
''''populateSum具体实现对受灾人口的统计
'************************************************************************************************'''
Public Sub populateSum(pFloodRangeLyr As IFeatureLayer, _
                       pPopulateLyr As IFeatureLayer, _
                       strResultFile As String, _
                       strResultPath As String, _
                       pApp As IApplication, _
                       adoCnn As ADODB.Connection)
    
    On Error GoTo errHandle
    
    ' Create the RasterExtractionOp/MathOps object
    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
        
    Dim pSpaRef As ISpatialReference
    Set pSpaRef = GetLayerSourceSpatialRef(pPopulateLyr)      '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, "受灾人口")
    
    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)
    
    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, indexPopu As Integer
    Dim indexName1 As Integer, indexPopu1 As Integer, indexFloodPopu1 As Integer, indexFloodArea1 As Integer, indexArea1 As Integer
    Dim pFields As IFields
    Set pFields = pPopulateLyr.FeatureClass.Fields
    indexName = pFields.FindField("地区")          '政区名称
    indexPopu = pFields.FindField("人口")          '政区人口
    indexName1 = pFlds.FindField("地区")           '政区名称
    indexPopu1 = pFlds.FindField("人口")           '政区人口
    indexArea1 = pFlds.FindField("面积")           '政区面积
    indexFloodArea1 = pFlds.FindField("受灾面积")  '受灾面积
    indexFloodPopu1 = pFlds.FindField("受灾人口")  '受灾人口
    
    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, pPopuCursor As IFeatureCursor
    Set pPopuCursor = pPopulateLyr.Search(pFilter, False)

    Dim sumArea As Double
    Dim pTopologOp As ITopologicalOperator, pGeoResult As IGeometry
    Dim pPopuArea As IArea, pAndArea As IArea
    Dim pPopuPoly As IPolygon, pFloodPoly As IPolygon
    Dim pPopuFeat As IFeature, pFloodFeat As IFeature
    Set pPopuFeat = pPopuCursor.NextFeature
    
    If adoCnn Is Nothing Then
       MsgBox "连接数据库有误", vbInformation + vbOKOnly, "提示信息"
       Exit Sub
    End If
    
    Dim popuRS As ADODB.Recordset, areaRS As ADODB.Recordset
    Set popuRS = GetWritableRS("evalPopu", adoCnn)
    Set areaRS = GetWritableRS("evalArea", adoCnn)
    
    Dim bFloodExist1 As Boolean, bFloodExist2 As Boolean
    bFloodExist1 = recordExist("evalPopu", "FloodDate", theFloodDate, adoCnn)
    bFloodExist2 = recordExist("evalArea", "FloodDate", theFloodDate, adoCnn)
    
    Dim bWriteTable As Boolean
    bWriteTable = True
    If bFloodExist1 Or bFloodExist2 Then
        Dim ret As Integer
        ret = MsgBox("对不起，洪水信息已经存在，" & Chr(13) & "如果需要刷新吗？", vbInformation + vbYesNo, "刷新信息")
        
        If ret = vbYes Then
            If bFloodExist1 Then Call delRecords("evalPopu", "FloodDate", theFloodDate, adoCnn)
            If bFloodExist2 Then Call delRecords("evalArea", "FloodDate", theFloodDate, adoCnn)
        Else
            bWriteTable = False
        End If
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not pPopuFeat Is Nothing
    
        Set pTopologOp = pPopuFeat.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 = pPopuFeat.Shape
        Set pPopuArea = pPopuFeat.Shape
        
        pOutBuffer.Value(indexPopu1) = pPopuFeat.Value(indexPopu)                                     '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexName1) = pPopuFeat.Value(indexName)                                     '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexArea1) = pPopuArea.Area                                                 '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexFloodPopu1) = pPopuFeat.Value(indexPopu) * sumArea / pPopuArea.Area     '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        pOutBuffer.Value(indexFloodArea1) = sumArea                                                   '统计出该区域内淹没的面积，需乘以人口密度才为受灾人口
        
        If bWriteTable Then
            Call AppendEvalPopuRecord(popuRS, theFloodName, theFloodDate, pOutBuffer.Value(indexName1), _
                                      pOutBuffer.Value(indexPopu1), pOutBuffer.Value(indexFloodPopu1))
            Call AppendEvalAreaRecord(areaRS, theFloodName, theFloodDate, pOutBuffer.Value(indexName1), _
                                      pOutBuffer.Value(indexArea1), pOutBuffer.Value(indexFloodArea1))

'        Else
'            Dim bRefresh As Boolean
'            bRefresh = MsgBox("对不起,洪水信息已经存在," & Chr(13) & "如果需要刷新吗", vbInformation + vbYesNo, "刷新信息")
'            If bRefresh Then
'                 Call delRecords("evalPopu", "FloodDate", theFloodDate, AdoCnn)
'            End If
        End If

        pOutCursor.InsertFeature pOutBuffer
        Set pPopuFeat = pPopuCursor.NextFeature
    
    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not filterFeat Is Nothing
                           
    Dim pPolygonLayer As IFeatureLayer
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    Set pPolygonLayer = New FeatureLayer
    Set pPolygonLayer.FeatureClass = pFClass
    pPolygonLayer.name = "受灾人口"
    
    Call setFeatureLayerRenderer(pPolygonLayer, vbGreen)
    
    pMxDoc.FocusMap.AddLayer pPolygonLayer   'pRL
    pMxDoc.ActiveView.Refresh
'    Set pPolygonLayer = Nothing
    
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    Set pFeaLyr = 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