imageupdate.frm

栅格数据处理程序

VERSION 5.00
Begin VB.Form frmUpdate 
   Caption         =   "Image Update"
   ClientHeight    =   4125
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5490
   LinkTopic       =   "Form1"
   ScaleHeight     =   4125
   ScaleWidth      =   5490
   StartUpPosition =   1  'CenterOwner
   Begin VB.TextBox txtOutRas 
      Height          =   375
      Left            =   3480
      TabIndex        =   14
      Text            =   "Result"
      Top             =   3240
      Width           =   1335
   End
   Begin VB.CheckBox chkLessOrEqual 
      Caption         =   "小于等于"
      Height          =   375
      Left            =   240
      TabIndex        =   13
      Top             =   3240
      Value           =   1  'Checked
      Width           =   1335
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "Cancel"
      Height          =   375
      Left            =   4440
      TabIndex        =   7
      Top             =   3720
      Width           =   855
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      Height          =   375
      Left            =   3120
      TabIndex        =   6
      Top             =   3720
      Width           =   1095
   End
   Begin VB.Frame Frame1 
      Caption         =   "精度统计的高程范围"
      Height          =   1815
      Left            =   240
      TabIndex        =   4
      Top             =   1320
      Width           =   4695
      Begin VB.TextBox txtDGJ 
         Height          =   375
         Left            =   1920
         TabIndex        =   12
         Text            =   "50"
         Top             =   1200
         Width           =   2295
      End
      Begin VB.TextBox txtMinElev 
         Height          =   375
         Left            =   1920
         TabIndex        =   8
         Text            =   "0"
         Top             =   240
         Width           =   2295
      End
      Begin VB.TextBox txtMaxElev 
         Height          =   375
         Left            =   1920
         TabIndex        =   5
         Text            =   "0"
         Top             =   720
         Width           =   2295
      End
      Begin VB.Label lab3 
         Caption         =   "等高距："
         Height          =   255
         Left            =   360
         TabIndex        =   11
         Top             =   1320
         Width           =   1095
      End
      Begin VB.Label Label3 
         Caption         =   "最大高程："
         Height          =   255
         Left            =   360
         TabIndex        =   10
         Top             =   720
         Width           =   1095
      End
      Begin VB.Label lab1 
         Caption         =   "最小高程："
         Height          =   255
         Left            =   360
         TabIndex        =   9
         Top             =   360
         Width           =   1335
      End
   End
   Begin VB.ComboBox cboDEM 
      Height          =   315
      Left            =   1680
      TabIndex        =   3
      Text            =   "Combo2"
      Top             =   840
      Width           =   3255
   End
   Begin VB.ComboBox cboInputDGXBase 
      Height          =   315
      Left            =   1680
      TabIndex        =   2
      Text            =   "Combo1"
      Top             =   360
      Width           =   3255
   End
   Begin VB.Label Label4 
      Caption         =   "输出的栅格名前缀"
      Height          =   375
      Left            =   1800
      TabIndex        =   15
      Top             =   3360
      Width           =   1455
   End
   Begin VB.Label Label2 
      Caption         =   "DEM栅格"
      Height          =   255
      Left            =   240
      TabIndex        =   1
      Top             =   840
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "基准等高线栅格"
      Height          =   255
      Left            =   240
      TabIndex        =   0
      Top             =   360
      Width           =   1335
   End
End
Attribute VB_Name = "frmUpdate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_App As IApplication
Private m_pMap As IMap
Private m_ActView As IActiveView
Private m_pMxDoc As IMxDocument
Private m_GeoIn As IGeoDataset

Public Sub init(pApp As IApplication)
    Set m_App = pApp
End Sub

Private Sub cmdCancel_Click()
    Unload frmUpdate
End Sub

Private Sub cmdOK_Click()
    ' Declare the input and output objects
    On Error GoTo ERH
    
    ' Set up cursor
'    Dim pCur As IMouseCursor
'    Set pCur = New MouseCursor
'    pCur.SetCursor 2
    
    Dim pDGXBaseRaster As IRaster ' for input raster
    Dim pDEMRaster As IRaster ' for input raster
    Dim pRepLaceRaster As IRaster ' for raster used to replace with
    Dim pDefinedAreaDS As IGeoDataset ' dataset that defined the area to
                                      ' to be replaced with
    Dim pRasResult As IRaster ' the result
    
    ' Create a Rasterworkspace
    Dim sPath As String
    sPath = Environ("TEMP") ' Get temp directory
    Dim pWS As IWorkspace
    Set pWS = SetRasterWorkspace(sPath)
    
    '基准等高线栅格
    Dim pRasterLy As IRasterLayer
    Dim pFeatureLy As IFeatureLayer
    Dim pLy As ILayer
    Set pLy = m_pMap.Layer(cboInputDGXBase.ItemData(cboInputDGXBase.ListIndex))
    If TypeOf pLy Is IRasterLayer Then
        Set pRasterLy = pLy
        Set pDGXBaseRaster = pRasterLy.Raster
    Else
        MsgBox "基准等高线栅格不能为空."
        Exit Sub
    End If
    
    '待检查的DEM栅格
    Set pLy = m_pMap.Layer(cboDEM.ItemData(cboDEM.ListIndex))
    If TypeOf pLy Is IRasterLayer Then
        Set pRasterLy = pLy
        Set pDEMRaster = pRasterLy.Raster
    Else
        MsgBox "待检查的DEM栅格不能为空"
        Exit Sub
    End If
    
    Set m_GeoIn = pRDS.CreateDefaultRaster
    
    '以基准等高线栅格的栅格大小和范围为环境基础
    Dim pRasterProp As IRasterProps
    Dim pExtent As IEnvelope
    Dim vCell As Double
    Set pRasterProp = pDGXBaseRaster
    Set pExtent = pRasterProp.Extent
    vCell = (pRasterProp.MeanCellSize.X + pRasterProp.MeanCellSize.Y) / 2
    
    'Check Spatial Analyst license
    CheckSpatialAnalystLicense
    
    ' Create RasterAnalysis environment
    Dim pEnv As IRasterAnalysisEnvironment
    Set pEnv = New RasterAnalysis
    pEnv.SetCellSize esriRasterEnvValue, vCell
    pEnv.SetExtent esriRasterEnvValue, pExtent
    Set pEnv.OutWorkspace = pWS
    ' Set to default so that it work for all the Ops in this session
    pEnv.SetAsNewDefaultEnvironment
    
 
    'Create a conditional raster using ILogicalOp interface
    ' the raster is true for the defined area and false for area that is
    ' within the extent but out side of the defined area.
    ' Create Logical operator
    'Dim pCondRaster As IGeoDataset
    Dim pRasterSum As IRaster
    Dim pDEMRasterFJ As IRaster
    Dim pRasterBaseFJ As IRaster
    Dim pConstRasterDGXFJ As IRaster
    Dim pLogicalOp As ILogicalOp
    Set pLogicalOp = New RasterMathOps
    ' Perform the computation
    
    '构造1/0常数影像
    Dim pRMakerOp As IRasterMakerOp
    Set pRMakerOp = New RasterMakerOp
    Set pRasterSum = pRMakerOp.MakeConstant(0, True)
    
    Dim elevMin As Long
    Dim elevMax As Long
    Dim dgj As Long
    Dim gc As Long
    
    '从Map中获取存放结果的属性表
    Dim pStaticTable As ITable
    
    Set pStaticTable = GetResultDataTable()
    If pStaticTable Is Nothing Then
       Exit Sub
    End If
    
    '统计区间
    elevMin = Val(txtMinElev.Text)
    elevMax = Val(txtMaxElev.Text)
    dgj = Val(txtDGJ.Text)
    
    Dim preNameRasOutput As String
    
    preNameRasOutput = Trim(txtOutRas.Text)
    If preNameRasOutput = "" Then preNameRasOutput = "Result"
    
    Dim bLessOrEqual As Boolean
    If (chkLessOrEqual.Value = 1) Then
        bLessOrEqual = True
    Else: bLessOrEqual = False
    End If
    
    If dgj <= 0 Then
        MsgBox "等高距必须大于或等于0"
        Exit Sub
    End If
    
    If elevMin > elevMax Then
        MsgBox "最小和最大高程值填写错误！"
        Exit Sub
    End If
    
    Dim pMathOp As IMathOp
    Set pMathOp = New RasterMathOps

    Dim pRasBandCollect As IRasterBandCollection
    Dim pRasBand As IRasterBand
    Dim pTable As ITable
    Dim m_GeoIn As IGeoDataset
    Dim iZoneCount As Long
    Dim iZoneIndex As Long
    Dim fieldIndexValue, fieldIndexCount As Long
    Dim Count0, Count1 As Long
    Dim pCursor As ICursor
    Dim pRowBuf As IRowBuffer
    Dim fdIdxCount0 As Long
    Dim fdIdxCount1 As Long
    Dim fdIdxElev As Long
    Dim s As String
    
    '插入光标
    Set pCursor = pStaticTable.Insert(True)
     
    If pCursor Is Nothing Then
       Err.Raise vbObjectError + 1, "GetLogRow", "Could not open Cursor"
    End If
  
    fdIdxCount0 = pStaticTable.Fields.FindField("count0")
    fdIdxCount1 = pStaticTable.Fields.FindField("count1")
    fdIdxElev = pStaticTable.Fields.FindField("Elev")
    If fdIdxCount0 < 0 Or fdIdxCount1 < 0 Or fdIdxElev < 0 Then
        MsgBox "结果表中缺少字段count0，count1，Elev"
        Exit Sub
    End If

    ' Change cursor while calculating
    Dim pCur As IMouseCursor
    Set pCur = New MouseCursor
    pCur.SetCursor 2
    
    '逐层次处理等高线
    For gc = elevMin To elevMax Step dgj
    
        '分界线栅格
        Set pConstRasterDGXFJ = pRMakerOp.MakeConstant(gc, False)
        
        '分级的基准等高线栅格,求异或运算,计算面积差异
        Set pRasterBaseFJ = pLogicalOp.GreaterThanEqual(pDGXBaseRaster, pConstRasterDGXFJ)
        Set pDEMRasterFJ = pLogicalOp.GreaterThanEqual(pDEMRaster, pConstRasterDGXFJ)
        
        '为每一个高程带创建一个临时栅格，并加入到Map
        Set pRasterSum = pLogicalOp.BooleanXOr(pRasterBaseFJ, pDEMRasterFJ)
        
        '作滤波处理,融合4邻接像元
        Dim pEnv As IRasterAnalysisEnvironment
        Set pop = New RasterGeneralizeOp
        
        
        Set pRasterLy = New RasterLayer
        pRasterLy.CreateFromRaster pRasterSum
        pRasterLy.Name = preNameRasOutput & gc
        m_pMap.AddLayer pRasterLy
        
        'm_ActView.Refresh
        
        '从分段栅格中取出0-1个数存入表pStaticTable
        Set m_GeoIn = pRasterLy.Raster
        Set pRasBandCollect = m_GeoIn
        Set pRasBand = pRasBandCollect.Item(0)