clspolyextract.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 = "clsAnalysisPolyExtract"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

'************************************************************************************************
'*********************** 使用多边形提取栅格相应范围栅格                     ***********************
'*********************** ZHANG Wenjiang, 2004/01/16                       ***********************
'************************************************************************************************

Option Explicit

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

Implements ICommand

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
  ICommand_Bitmap = frmResources.picPolyExtract.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 polygonSelect
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
On Error GoTo ErrorHandler:
  
    Set 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


'************************************************************************************************''''''
'''polygonSelect，调用cutRasByShp从栅格土层上提取图斑

'************************************************************************************************''''''
Public Sub polygonSelect()
    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
    frmPolygonSelect.Left = (Screen.Width - frmPolygonSelect.Width) / 2
    frmPolygonSelect.Top = (Screen.Height - frmPolygonSelect.Height) / 2
    frmPolygonSelect.Show vbModal
    
    If frmPolygonSelect.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")

        strPolygonFile = frmPolygonSelect.strPathPolygon
        strGRIDFile = frmPolygonSelect.strPathGRID
        strResultFile = frmPolygonSelect.strPathResult

        If Not fs.FileExists(strPolygonFile) Then '
            MsgBox "指定多边形文件不存在，请查实"
            Exit Sub
        End If

        If Not fs.FolderExists(Left(strGRIDFile, Len(strGRIDFile) - 4)) Then '
            MsgBox "指定栅格文件不存在，请查实"
        End If
       
        Call SplitPath(strPolygonFile, strPolygonPath, strTemp)
        strPolygonFile = strTemp
        Call SplitPath(strGRIDFile, strGRIDPath, strTemp)
        strGRIDFile = Left(strTemp, Len(strTemp) - 4)

        If fs.FolderExists(Left(strResultFile, Len(strResultFile) - 4)) Then '
            MsgBox strResultFile & "已存在，将被覆盖"
            fs.Deletefolder (Left(strResultFile, Len(strResultFile) - 4)) '
        End If

        If fs.FileExists(strResultFile) Then '
            fs.DeleteFile (strResultFile) '
        End If

        Call SplitPath(strResultFile, strResultPath, strTemp)
        strResultFile = Left(strTemp, Len(strTemp) - 4)

    Else
        MsgBox "放弃多边形提取"
        GoTo ERH
    End If
        
    Set pOutRas1 = CutRasByShp(strPolygonFile, strPolygonPath, strGRIDFile, strGRIDPath)
    
    Dim pRWks As IWorkspace, pRWksF As IWorkspaceFactory
    Set pRWksF = New RasterWorkspaceFactory
    Set pRWks = pRWksF.OpenFromFile(strResultPath, 0)
    
    Dim pBC As IRasterBandCollection
    Set pBC = pOutRas1
    Call pBC.SaveAs(strResultFile, pRWks, "GRID")
    
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    Dim pRasLyr As IRasterLayer
    Set pRasLyr = New RasterLayer
    
    pRasLyr.CreateFromRaster pOutRas1
    pRasLyr.name = "多边形提取"
    pMxDoc.FocusMap.AddLayer pRasLyr
    pMxDoc.ActiveView.Refresh
    
    Set pRWksF = Nothing
    Set pRasLyr = Nothing
    
'    MsgBox "完成多边形提取！"
    Exit Sub
    
ERH:
    MsgBox "多边形提取失败" & Chr(13) & err.Description, vbInformation + vbOKOnly, "提示信息"
End Sub


'************************************************************************************************''''''
'''CutRasByShp，用多边形提取栅格图斑

'************************************************************************************************''''''
Public Function CutRasByShp(strPolygonFile As String, strPolygonPath As String, strGRIDFile As String, strGRIDPath As String) As IGeoDataset
    On Error GoTo ERH
    
    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
    
    'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strPolygonPath, 0)
    Set pFeaLyr = New FeatureLayer
    Set pFeaLyr.FeatureClass = pFeatureWorkspace.OpenFeatureClass(strPolygonFile)
   
    Dim inputRaster As IRaster
    Set inputRaster = OpenRasterDataset(strGRIDPath, strGRIDFile).CreateDefaultRaster
    
    Dim pTempDS As IGeoDataset
    Set pTempDS = pFeaLyr.FeatureClass
    Dim pConOp As IConversionOp
    Set pConOp = New RasterConversionOp
    Set pEnv = pConOp
    Dim pProp As IRasterProps
    Set pProp = inputRaster
    pEnv.SetCellSize esriRasterEnvValue, pProp.MeanCellSize.X
    
    ' Delete the existing file
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strGRIDPath + "\" + "CovTemp") Then                'FileExists
        fs.Deletefolder (strGRIDPath + "\" + "CovTemp")                   'Deletefile
    End If
                
'    Dim pWks As IWorkspace
    Set pWksF = New RasterWorkspaceFactory
    Set pWks = pWksF.OpenFromFile(strGRIDPath, 0)                       'sWorkPath
    Dim pGeoDs As IRasterDataset
    Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "GRID", pWks, "CovTemp")
    
    Dim pLogicalOp As ILogicalOp
    Dim pConditionalOp As IConditionalOp
    Set pLogicalOp = New RasterMathOps
    Set pConditionalOp = New RasterConditionalOp

    Dim pZeroRaster As IRaster
    Dim pMathOp As IMathSupportOp
    Set pMathOp = New RasterMathSupportOp
    
    Set pZeroRaster = pMathOp.Minus(pGeoDs, pGeoDs)
    Dim pOutRas1 As IGeoDataset
    Set pOutRas1 = pConditionalOp.Con(pLogicalOp.GreaterThanEqual(pGeoDs, pZeroRaster), inputRaster)

    Set CutRasByShp = pOutRas1
    
    Set pEnv = Nothing
    Set pWks = Nothing
    Set pWksF = Nothing
    Set pConOp = Nothing
    Set pFeaLyr = Nothing
    Set pTempDS = Nothing
    Set pMathOp = Nothing
    Set pLogicalOp = Nothing
    Set pConditionalOp = Nothing
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    
    Exit Function
ERH:
    MsgBox err.Description
End Function