frmdisplaycrop.frm

FloodEvaluation-程序是gis方面的程序

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmDisplayCrop 
   Caption         =   "作物受灾损失信息"
   ClientHeight    =   4590
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7200
   Icon            =   "frmDisplayCrop.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4590
   ScaleWidth      =   7200
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdOK 
      Caption         =   "完 成"
      Height          =   375
      Left            =   2400
      TabIndex        =   1
      Top             =   4080
      Width           =   855
   End
   Begin VB.CommandButton cmdAdd 
      Caption         =   "添 加"
      Height          =   375
      Left            =   3960
      TabIndex        =   0
      Top             =   4080
      Width           =   855
   End
   Begin MSComctlLib.ListView lstView 
      Height          =   3855
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   6975
      _ExtentX        =   12303
      _ExtentY        =   6800
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
End
Attribute VB_Name = "frmDisplayCrop"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public m_adoCnn As ADODB.Connection
Public m_cropRS As ADODB.Recordset
Public m_theCropTable As String
Public m_cropName As String
Public bForModal As Boolean

Private Sub Form_Load()
On Error GoTo ERH
    
    If m_adoCnn Is Nothing Then
       MsgBox "连接有误" + Chr(13) + ERR.Description, vbInformation + vbYesonly, "信息提示"
       Exit Sub
    End If
   
    Set m_cropRS = GetWritableRS(m_theCropTable, m_adoCnn)

    If m_cropRS Is Nothing Then
       MsgBox "连接有误" + Chr(13) + ERR.Description, vbInformation + vbYesonly, "信息提示"
       Exit Sub
    End If

    Call ShowTable(m_cropRS, lstView)
    
    Exit Sub
    
ERH:
    MsgBox "显示作物受灾信息失败" + Chr(13) + ERR.Description, vbInformation + vbYesonly, "信息提示"
    
End Sub

Private Sub cmdOK_Click()
    bForModal = True
    Me.Hide
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ERH
            
    Dim pDistrictLyr As IFeatureLayer, pRasCropLoss As IRaster
    frmForCropInfo.Left = (Screen.Width - frmForCropInfo.Width) / 2
    frmForCropInfo.Top = (Screen.Height - frmForCropInfo.Height) / 2
    frmForCropInfo.Show vbModal

    If g_bForCropDisplay Then 'frmForCropInfo.flagOK Then

        Set pDistrictLyr = frmForCropInfo.shpPolygonLyr
        Set pRasCropLoss = frmForCropInfo.cropLossLyr.Raster
        
        m_cropName = frmForCropInfo.txtCropLoss
        Dim strResultPath As String, strTemp As String
        Call SplitPath(m_cropName, strResultPath, strTemp)
        If Len(strTemp) > 10 Then
            m_cropName = Left(strTemp, Len(strTemp) - 10)
        Else
            m_cropName = Left(strTemp, Len(strTemp) - 4)
        End If

        If pDistrictLyr Is Nothing Or pRasCropLoss Is Nothing Then '
             MsgBox "图层选择有误", vbInformation + vbOKOnly, "提示信息"
             Exit Sub
        End If
        
    Else
        MsgBox "放弃评估", vbInformation + vbOKOnly, "提示信息"
        Exit Sub
    End If
    
    Select Case m_theCropTable
        Case "evalTotalCrop"     ' set up a marker symbol
            Call addCropLossInfo(pRasCropLoss, pDistrictLyr, m_adoCnn)
      
        Case "evalOneCrop"    ' set up a line symbol
            Call addOneCropInfo(pRasCropLoss, pDistrictLyr, m_adoCnn)
    
        Case Else
            MsgBox "数据表名称有误", vbInformation + vbOKOnly, "提示信息"
            Exit Sub
    End Select
    
    Exit Sub      'exit sub to avoid error handler

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

End Sub


'************************************************************************************************''''''
'''''' 记录作物评估属性
'************************************************************************************************''''''
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(m_theCropTable, 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 bFloodExist As Boolean
    bFloodExist = recordExist(m_theCropTable, "FloodDate", theFloodDate, m_adoCnn)
    
    Dim bWriteTable As Boolean
    bWriteTable = True
    If bFloodExist Then
        Dim ret As Integer
        ret = MsgBox("对不起，洪水信息已经存在，" & Chr(13) & "如果需要刷新吗？", vbInformation + vbYesNo, "刷新信息")
        
        If ret = vbYes Then
            Call delRecords(m_theCropTable, "FloodDate", theFloodDate, m_adoCnn)
        Else
            bWriteTable = False
        End If
    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 = 2
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not polyFeat Is Nothing

        Set pPolygon = polyFeat.Shape
        Set pExtractRaster = pExtractionOp.Polygon(inputRaster, pPolygon, True)
        Call rasterSum2(pExtractRaster, 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

MsgBox "finished input"
    Exit Sub      'exit sub to avoid error handler

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

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

    Dim cropRS As ADODB.Recordset
    Set cropRS = GetWritableRS(m_theCropTable, 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 bFloodExist As Boolean
    bFloodExist = recordExist(m_theCropTable, "FloodDate", theFloodDate, m_adoCnn)
    
    Dim bWriteTable As Boolean
    bWriteTable = True
    If bFloodExist Then
        Dim ret As Integer
        ret = MsgBox("对不起，洪水信息已经存在，" & Chr(13) & "如果需要刷新吗？", vbInformation + vbYesNo, "刷新信息")
        
        If ret = vbYes Then
            Call delRecords(m_theCropTable, "FloodDate", theFloodDate, m_adoCnn)
        Else
            bWriteTable = False
        End If
    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
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not polyFeat Is Nothing

        Set pPolygon = polyFeat.Shape
        Set pExtractRaster = pExtractionOp.Polygon(inputRaster, pPolygon, True)
        Call rasterSum2(pExtractRaster, polySummary, theArea)
        districtName = polyFeat.Value(indexName)
        Call AppendEvalOneCropRecord(cropRS, theFloodName, theFloodDate, districtName, m_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

MsgBox "finished input"
    Exit Sub      'exit sub to avoid error handler

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