转贴ＧＩＳＳＫＹ上的ＶＢ源码

楼主^#

更多发布于：2004-12-07 14:31

对GRID文件重新赋值
Sub RasSlice(pGeoDs As IGeoDataset, pOutRaster As IRaster, RangeFile As String)
pGeoDs：需要重新赋值的GRID文件的IGeoDataset格式数据层
pOutRaster：重新赋值后的GRID文件的IRater格式数据层
RangeFile：重新赋值的数据范围文件名
'GRID文件重新赋值
Sub RasSlice(pGeoDs As IGeoDataset, pOutRaster As IRaster, RangeFile As String)
' Create a Spatial operator
Dim pReclassOp As IReclassOp
Set pReclassOp = New RasterReclassOp
' Set output workspace
Dim pEnv As IRasterAnalysisEnvironment
Set pEnv = pReclassOp

' Perform Spatial operation
Set pOutRaster = pReclassOp.ReclassByASCIIFile(pGeoDs, RangeFile, False)
End Sub

RangeFile文件内容:
0.79 0.81 : 1
0.81 0.85 : 2
0.85 0.87 : 3
0.87 0.90 : 4
0.90 1 :5
用Shapefile文件挖GRID文件
Sub CutRasByShp(sworkPath As String, pRasLyr As IRasterLayer, sShapeFileName As String, sGridFileName As String, pOutRas1 As IGeoDataset)
sworkPath：打开的GRID文件路径
pRasLyr：要运算的GRID文件IrasterLayer格式数据层
sShapeFileName：用于切GRID文件的Shape文件名
sGridFileName：切后的GRID文件名
pOutRas1：切后的GRID文件的IGeoDataset格式数据层
'用SHP文件挖GRID文件
Sub CutRasByShp(sworkPath As String, pRasLyr As IRasterLayer, sShapeFileName As String, sGridFileName As String, pOutRas1 As IGeoDataset)
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
Dim pFeaLyr As IFeatureLayer
Dim pEnv As IRasterAnalysisEnvironment
Dim pWks As IRasterWorkspace
Dim pWksF As IWorkspaceFactory

'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sworkPath, 0)
'Create a new FeatureLayer and assign a shapefile to it
Set pFeaLyr = New FeatureLayer
Set pFeaLyr.FeatureClass = pFeatureWorkspace.OpenFeatureClass(sShapeFileName)
pFeaLyr.Name = pFeaLyr.FeatureClass.AliasName

Dim pTempDS As IGeoDataset
Set pTempDS = pFeaLyr.FeatureClass
' Convert to raster
Dim pConOp As IConversionOp
Set pConOp = New RasterConversionOp
Set pEnv = pConOp
Dim pProp As IRasterProps
Set pProp = pRasLyr.Raster
pEnv.SetCellSize esriRasterEnvValue, pProp.MeanCellSize.X
Dim sPath As String
sPath = sworkPath
' delete the existing file
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(sPath + "\" + "TempCov.img") Then
fs.Deletefile (sPath + "\" + "TempCov.img")
End If
Dim pWs As IWorkspace
Set pWksF = New RasterWorkspaceFactory
Set pWs = pWksF.OpenFromFile(sworkPath, 0)
' Perform conversion
Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "IMAGINE Image", pWs, "TempCov.img")

' perform extraction
Dim pOutRaster As IRaster
Dim pRasBandC As IRasterBandCollection
Dim pExtrOp As IExtractionOp
' Dim pOutRas1 As IGeoDataset
Set pExtrOp = New RasterExtractionOp
Set pOutRaster = pExtrOp.Raster(pRasLyr.Raster, pGeoDs)
Set pRasBandC = pOutRaster
Set pOutRas1 = pRasBandC.SaveAs(sGridFileName, pWs, "GRID")

Set pWs = Nothing
Set pTempDS = Nothing
Set pConOp = Nothing
Set pWorkspaceFactory = Nothing
Set pFeatureWorkspace = Nothing
Set pFeaLyr = Nothing
Set pEnv = Nothing
Set pWks = Nothing
Set pWksF = Nothing
End Sub
合并GRID文件
Sub MosaicGrid(pMosaicRaster() As IRaster, sPath As String, SubareaNumber As Integer, sOutName As String, pRaster As IRaster)
pMosaicRaster()：需要合并的GRID文件的IRater格式数据层
sPath：文件路径
SubareaNumber：合并文件的数目
sOutName：合并后GRID文件名
pRaster：合并后GRID文件的IRater格式数据层 
'合并GRID文件
Sub MosaicGrid(pMosaicRaster() As IRaster, sPath As String, SubareaNumber As Integer, sOutName As String, pRaster As IRaster)
　' Create input and output workspace
　Dim pWSF As IWorkspaceFactory
　Set pWSF = New RasterWorkspaceFactory
　Dim pInRWS As IRasterWorkspace
　Dim pOutRWS As IRasterWorkspace
　If Not pWSF.IsWorkspace(sPath) Then Exit Sub
　Set pInRWS = pWSF.OpenFromFile(sPath, 0)
　If Not pWSF.IsWorkspace(sPath) Then Exit Sub
　Set pOutRWS = pWSF.OpenFromFile(sPath, 0)
　Dim pRasProp As IRasterProps
　Set pRaster = pMosaicRaster(1)
　Set pRasProp = pRaster
　Dim CellSize As Double
　CellSize = (pRasProp.MeanCellSize.X + pRasProp.MeanCellSize.Y) / 2
　Dim pPrj As ISpatialReference
　Set pPrj = pRasProp.SpatialReference
　' Create a new raster
　Dim pInRaster As IRasterBandCollection
　Set pInRaster = New Raster
　' Add first dataset into raster
　Dim pBandCol As IRasterBandCollection
　Dim pBand As IRasterBand
　For I = 1 To SubareaNumber
　　Set pBandCol = pMosaicRaster(I)
　　Set pBand = pBandCol.Item(0)
　　pInRaster.AppendBand pBand
　Next I
　' Mosaic
　Dim pRasGeoProc As IRasterGeometryProc
　Set pRasGeoProc = New RasterGeometryProc
　Set pRaster = pRasGeoProc.Mosaic(sOutName, pOutRWS, "GRID", CellSize, pPrj, pInRaster)
　' ' Release memeory
　Set pRasGeoProc = Nothing
　Set pInRaster = Nothing
　Set pBand = Nothing
　Set pBandCol = Nothing
　Set pRasProp = Nothing
　Set pInRWS = Nothing
　Set pOutRWS = Nothing
　Dim pMxDoc As IMxDocument
　Dim pMap As IMap
　Dim pRasterLy As IRasterLayer
　Set pMxDoc = ThisDocument
　Set pMap = pMxDoc.FocusMap
　Set pRasterLy = New RasterLayer
　pRasterLy.CreateFromRaster pRaster
　pMap.AddLayer pRasterLy
　pMxDoc.ActiveView.Refresh
End Sub
将点状图层中各点x,y坐标输出到文本文件中
'将选中点状图层各点状要素的X,Y坐标输出到文本文件中
'输入参数为选中图层和输出文件名(包括路径)
'如果需要Z值,只需要在输出中修改一下就可以了
Public Function ExportXYCoor(inputLayer As IFeatureLayer, outputTextFile As String)
Dim pFCursor As IFeatureCursor
Dim pFeature As Ifeature
Set pFCursor = inputLayer.Search(Nothing, False)
Set pFeature = pFCursor.NextFeature

'创建文本文件
Dim Fsys As New FileSystemObject
Dim Tstream As TextStream
Set Tstream = Fsys.CreateTextFile(outputTextFile)

Dim I As Integer
Dim pPoint As Ipoint
Dim sOutputString As String

'遍历各要素,输出其坐标点
Do Until pFeature Is Nothing
　I = I + 1
　Set pPoint = pFeature.Shape
　sOutputString = I ; "," ; pPoint.X ; "," ; pPoint.Y
　Tstream.WriteLine (sOutputString)
　Set pFeature = pFCursor.NextFeature
Loop

End Function

喜欢0 评分0

举报回复

发帖回复

« 返回列表

您需要登录后才可以回帖，登录或者注册

返回顶部

转贴ＧＩＳＳＫＹ上的ＶＢ源码

最新喜欢：