clspoly2raster.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 = "clsAnalysisPoly2R"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'************************************************************************************************
'*********************** 将多边形转为栅格                                  ***********************
'*********************** ZHANG Wenjiang, 2004/04/14                       ***********************
'************************************************************************************************

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.picV2r.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 polygon2Raster
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


'************************************************************************************************'''
'''polygon2Raster，将多边形转为栅格图斑

'************************************************************************************************''''''
Public Sub polygon2Raster()
    On Error GoTo ERH
    
    Dim sWorkPath As String, sShapeFileName As String, sGridFileName As String
    Dim pOutRas1 As IRaster  'Dataset   'GeoDataset
    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
    
    frmPoly2Raster.Left = (Screen.Width - frmPoly2Raster.Width) / 2
    frmPoly2Raster.Top = (Screen.Height - frmPoly2Raster.Height) / 2
    frmPoly2Raster.Show vbModal

    If frmPoly2Raster.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")

        strPolygonFile = frmPoly2Raster.txtPolygon
        strGRIDFile = frmPoly2Raster.txtRefRaster
        strResultFile = frmPoly2Raster.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 = convertPolygon(strPolygonFile, strPolygonPath, strGRIDFile, strGRIDPath, strResultFile, strResultPath)
       
    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
    
    MsgBox "完成多边形提取！"
    Exit Sub
    
ERH:
    MsgBox "多边形提取失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub


'************************************************************************************************''''''
'''convertPolygon

'************************************************************************************************''''''
Public Function convertPolygon(strPolygonFile As String, strPolygonPath As String, strGRIDFile As String, strGRIDPath As String, strResultFile As String, strResultPath As String) As IRaster  'Dataset 'GeoDataset
    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)
    pFeaLyr.name = pFeaLyr.FeatureClass.AliasName
   
    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
    
    Set pWksF = New RasterWorkspaceFactory
    Set pWks = pWksF.OpenFromFile(strResultPath, 0)                         'sWorkPath
    ' Perform conversion
    Dim pGeoDs As IRasterDataset
    Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "GRID", pWks, strResultFile)
    
    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
 
    Dim tempRaster As IRaster
    Set tempRaster = pGeoDs.CreateDefaultRaster
    Set pZeroRaster = pMathOp.Minus(pGeoDs, pGeoDs)
    Dim pOutRas1 As IRasterDataset 'GeoDataset
    
    Dim resultRaster As IRaster
    Set resultRaster = pConditionalOp.Con(pLogicalOp.GreaterThanEqual(tempRaster, pZeroRaster), tempRaster)
    Set convertPolygon = resultRaster  'pGeoDS
        
    Set pEnv = Nothing
    Set pWks = Nothing
    Set pWksF = Nothing
    Set pFeaLyr = Nothing
    Set pTempDS = Nothing
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    
    Exit Function
ERH:
    MsgBox ERR.Description
End Function