imageupdate00.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_Map As IMap
Private m_ActView As IActiveView
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_Map.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_Map.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
    
    '以基准等高线栅格的栅格大小和范围为环境基础
    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
    
'    gcBegin = 4800
'    gcEnd = 4900
'    dgj = 100
    
    elevMin = Val(txtMinElev.Text)
    elevMax = Val(txtMaxElev.Text)
    dgj = Val(txtDGJ.Text)
    Dim preNameRasOutput As String
    
    preNameRasOutput = txtOutRas
    If txtOutRas = "" Then preNameRasOutput = "Rest"
    
    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


    For gc = elevMin To elevMax Step dgj
    
        '分界线栅格
        'Set pConstRasterDGXFJ = pRMakerOp.MakeConstant(gc + dgj, False)
        Set pConstRasterDGXFJ = pRMakerOp.MakeConstant(gc, False)
        
        '分级的基准等高线栅格
        Set pRasterBaseFJ = pLogicalOp.GreaterThanEqual(pDGXBaseRaster, pConstRasterDGXFJ)
        Set pDEMRasterFJ = pLogicalOp.GreaterThanEqual(pDEMRaster, pConstRasterDGXFJ)
     
        '降低一个等高距作为DEM的分界线
        '分级的DEM栅格
        'Set pDEMRasterFJ = pLogicalOp.LessThan(pDEMRaster, pConstRasterDGXFJ)
        'If bLessOrEqual Then
        '    Set pDEMRasterFJ = pLogicalOp.BooleanNot(pLogicalOp.GreaterThan(pDEMRaster, pConstRasterDGXFJ))
        'Else
        '    Set pDEMRasterFJ = pLogicalOp.LessThan(pDEMRaster, pConstRasterDGXFJ)
        'End If
        
        '求异或图像
        'Set pRasterSum = pLogicalOp.BooleanXOr(pRasterBaseFJ, pDEMRasterFJ)
        'Set pRasterSum = pMathOp.Plus(pRasterSum, pMathOp.Times(pLogicalOp.BooleanXOr(pRasterBaseFJ, pDEMRasterFJ), pConstRasterDGXFJ))
        
        '为每一个高程带创建一个临时栅格，并加入到Map
        Set pRasterSum = pLogicalOp.BooleanXOr(pRasterBaseFJ, pDEMRasterFJ)
        
        Set pRasterLy = New RasterLayer
        pRasterLy.CreateFromRaster pRasterSum
        pRasterLy.Name = preNameRasOutput & gc
        m_Map.AddLayer pRasterLy
        'm_ActView.Refresh
      
    Next gc
    
    ' Create conditional operator
    'Dim pConOp As IConditionalOp
    'Set pConOp = New RasterConditionalOp
        
   ' Set pRasResult = pLogicalOp.BooleanXOr(pRasterBaseFJ, pDEMRasterFJ)
        
        ' Using a specified constant to replace the defined area
        ' Create a constant raster using RasterMaker object
        ' Get the constant raster
        ' Perform Con operation
    'pConOp.Con(pCondRaster, pConstRaster, pDGXBaseRaster)
    'Set pConstRaster1 = Nothing
    Set pConstRasterDGXFJ = Nothing
    Set pRMakerOp = Nothing
    
    ' End session
    pEnv.RestoreToPreviousDefaultEnvironment

    ' create a raster layer and add into Map for display
'    Set pRasterLy = New RasterLayer
'    pRasterLy.CreateFromRaster pRasterSum
'    pRasterLy.Name = "Result"
'    m_Map.AddLayer pRasterLy
'    m_ActView.Refresh
    'pCur.SetCursor 0
    Set pRasterSum = Nothing
    'Set pConOp = Nothing
    'Set pCur = Nothing
    
    m_ActView.Refresh
    
    Unload frmUpdate
    Exit Sub
ERH:
    MsgBox Err.Description
End Sub
Private Sub Form_Load()
    ' when loading the form, get Map and ActiveView object
    ' for displaying the result. Add layers in ArcMap to the
    ' Combo box
    Dim pMxDoc As IMxDocument
    Set pMxDoc = m_App.Document
    Set m_Map = pMxDoc.FocusMap
    Set m_ActView = pMxDoc.ActiveView
    ' adding layers to each comb box
    AddLayerToComboBox cboInputDGXBase, m_Map, "raster"
    AddLayerToComboBox cboDEM, m_Map, "raster"
    'AddLayerToComboBox cboImage, m_Map, "raster"
    ' set default to be using NoData and disable others
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set m_Map = Nothing
    Set m_App = Nothing
    Set m_ActView = Nothing
End Sub

Public Function SetRasterWorkspace(ByVal PathName As String) As IWorkspace
    ' Given a pathname, returns the raster workspace object for that path
    On Error GoTo ERH
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New RasterWorkspaceFactory
    Dim pWS As IWorkspace
    Set pWS = pWSF.OpenFromFile(PathName, 0)
    Set SetRasterWorkspace = pWS
    Exit Function
ERH:
    Set SetRasterWorkspace = Nothing
End Function
Function CheckSpatialAnalystLicense()
    ' This module is used to check in SpatialAnalyst license
    ' in a standalone VB application.
    On Error GoTo ERH
    Dim pLicManager As IExtensionManager
    Dim pLicAdmin As IExtensionManagerAdmin
    Set pLicManager = New ExtensionManager
    Set pLicAdmin = pLicManager
    
    ' Add license for Spatial Analyst
    Dim pUID As New UID
    pUID.Value = "esriCore.SAExtension.1"
    Dim v As Variant
    Call pLicAdmin.AddExtension(pUID, v)
    
    ' Enable the license
    Dim pExtension As IExtension
    Dim pExtensionConfig As IExtensionConfig
    Set pExtension = pLicManager.FindExtension(pUID)
    Set pExtensionConfig = pExtension
    pExtensionConfig.State = esriESEnabled
    Exit Function
ERH:
    MsgBox "Failed in License Checking" & Err.Description
End Function
Public Sub AddLayerToComboBox(cboBox As ComboBox, pMap As IMap, sLayerType As String)
    ' This function search for layers in ArcMap and add them
    ' to the Combo box
    On Error GoTo ERH
    Dim iLyrIndex As Long
    Dim iLayerCount As Integer
    Dim pLyr As ILayer
    
    cboBox.Clear
    ' get the number of layers in ArcMap
    iLayerCount = pMap.LayerCount
    If iLayerCount > 0 Then
        ' add those layers into combo box
        cboBox.Enabled = True
        For iLyrIndex = 0 To iLayerCount - 1
            Set pLyr = pMap.Layer(iLyrIndex)
            If sLayerType = "raster" Then
                If (TypeOf pLyr Is IRasterLayer) Then
                    cboBox.AddItem pLyr.Name
                    cboBox.ItemData(cboBox.ListCount - 1) = iLyrIndex
                End If
            ElseIf sLayerType = "feature" Then
                If (TypeOf pLyr Is IFeatureLayer) Then
                    cboBox.AddItem pLyr.Name
                    cboBox.ItemData(cboBox.ListCount - 1) = iLyrIndex
                End If
            Else
                cboBox.AddItem pLyr.Name
            End If
        Next iLyrIndex
        ' specify the default text shown in the combo box
        If (cboBox.ListCount > 0) Then
            cboBox.ListIndex = 0
            cboBox.Text = cboBox.List(0)
        End If
    End If
    Exit Sub
ERH:
    MsgBox "Add Layer to ComboBox:" & Err.Description
End Sub