[讨论] TIN to Raster

 
<P>为什么生成的栅格图像是黑乎乎一片呢？</P>
<P>而且高程值也不对</P>
<P>' Supported pixel types limited to float and long because output currently limited to native ESRI Grid<BR>' This routine handles cancel tracking so passed TIN should not have its CancelTracker set.<BR>Public Function TinToRaster(pTin As ITinAdvanced, eRastConvType As esriRasterizationType, _<BR>  sDir As String, sName As String, ePixelType As rstPixelType, cellsize As Double, pExtent As IEnvelope, _<BR>  bPerm As Boolean) As IRasterDataset<BR>      <BR>  ' The origin used by CreateRasterDataset is the lower left cell corner.<BR>  ' The extent passed is that of the TIN's.<BR>  ' Define the raster origin and number of rows and columns so that the raster<BR>  ' is of sufficient extent to capture area defined by passed envelope. The cell<BR>  ' center is located at the origin.<BR>  Dim pOrigin As IPoint<BR>  Set pOrigin = pExtent.LowerLeft<BR>  pOrigin.X = pOrigin.X - (cellsize * 0.5)<BR>  pOrigin.Y = pOrigin.Y - (cellsize * 0.5)<BR>  <BR>  Dim nCol As Long, nRow As Long<BR>  nCol = Round(pExtent.Width / cellsize) + 1<BR>  nRow = Round(pExtent.Height / cellsize) + 1<BR>  <BR>  Dim pGDS As IGeoDataset<BR>  Set pGDS = pTin<BR>  Dim pSR As ISpatialReference2<BR>  Set pSR = pGDS.SpatialReference<BR>  <BR>  Dim pRDS As IRasterDataset<BR>  Set pRDS = CreateRasterSurf(sDir, sName, "GRID", pOrigin, nCol, nRow, cellsize, cellsize, ePixelType, pSR, bPerm)<BR>    <BR>  DoEvents<BR>  <BR>  Dim pRawPixels As IRawPixels<BR>  Set pRawPixels = GetRawPixels(pRDS, 0)<BR>  <BR>  Dim pCache As stdole.IUnknown<BR>  Set pCache = pRawPixels.AcquireCache<BR>      <BR>  Dim pTinSurf As ITinSurface<BR>  Set pTinSurf = pTin<BR>    <BR>  Dim pRasterProps As IRasterProps<BR>  Set pRasterProps = pRawPixels<BR>  <BR>  Dim nodataFloat As Single<BR>  Dim nodataInt As Long<BR>      <BR>  Dim dZMin As Double<BR>  dZMin = pTin.Extent.ZMin<BR>      <BR>  Dim vNoData As Variant<BR>  If (ePixelType = PT_FLOAT) Then<BR>    vNoData = CSng(dZMin - 1)<BR>  Else<BR>    vNoData = CLng(dZMin - 1)<BR>  End If<BR>  <BR>  pRasterProps.NoDataValue = vNoData<BR>    <BR>  Dim pOffset As IPnt<BR>  Set pOffset = New DblPnt<BR>  <BR>  ' Set blocksize. Restrict how large it is as not to consume too much memory for<BR>  ' big output datasets.<BR>  Dim lMaxBlockX As Long<BR>  lMaxBlockX = 2048<BR>  If (nCol < lMaxBlockX) Then<BR>    lMaxBlockX = nCol<BR>  End If<BR>  <BR>  Dim lMaxBlockY As Long<BR>  lMaxBlockY = 2048<BR>  If (nRow < lMaxBlockY) Then<BR>    lMaxBlockY = nRow<BR>  End If<BR>  <BR>  Dim pBlockSize As IPnt<BR>  Set pBlockSize = New DblPnt<BR>  pBlockSize.X = lMaxBlockX<BR>  pBlockSize.Y = lMaxBlockY<BR>    <BR>  Dim pPixelBlock As IPixelBlock3<BR>  Set pPixelBlock = pRawPixels.CreatePixelBlock(pBlockSize)<BR>    <BR>  Dim blockArray As Variant<BR>  blockArray = pPixelBlock.PixelDataByRef(0)<BR>  <BR>  ' Set up cancel tracking and progress bar<BR>  Dim pCancel As ITrackCancel<BR>  Set pCancel = New CancelTracker<BR>  pCancel.CancelOnClick = False<BR>  pCancel.CancelOnKeyPress = True<BR>  Dim pApp As IApplication<BR>  Set pApp = New AppRef<BR>  Dim pProg As IStepProgressor<BR>  Set pProg = pApp.StatusBar.ProgressBar<BR>  pCancel.Progressor = pProg<BR>  Dim lBlockCount As Long<BR>  lBlockCount = Round((nCol / lMaxBlockX) + 0.49) * Round((nRow / lMaxBlockY) + 0.49)<BR>  pProg.Message = "Rasterizing. Press ESC to cancel..."<BR>  pProg.Position = 0<BR>  If (lBlockCount = 1) Then ' tin querypixelblock can do the tracking/progressing with 1 block<BR>    pProg.Show<BR>    Set pTin.TrackCancel = pCancel<BR>  Else ' more than 1 block requires this routine, rather than tin function, to track/progress<BR>    pProg.MinRange = 0<BR>    pProg.MaxRange = lBlockCount<BR>    pProg.StepValue = 1<BR>    pProg.Show<BR>  End If<BR>  DoEvents ' make sure the bar and the text get updated on screen<BR>  <BR>  Dim pBlockOrigin As IPoint<BR>  Set pBlockOrigin = New Point<BR>  <BR>  Dim lColOffset As Long<BR>  Dim lRowOffset As Long<BR>        <BR>  ' Left to right, top to bottom, iteration of pixel blocks.<BR>  For lRowOffset = 0 To (nRow - 1) Step lMaxBlockY<BR>  <BR>    For lColOffset = 0 To (nCol - 1) Step lMaxBlockX<BR>  <BR>      ' See if pixelblock needs to be resized in X for last column chunk.<BR>      ' RawPixel.Write will clip the pixelblock if it's too big, so the resize<BR>      ' isn't absolutely necessary, but resizing will eliminate unecessary<BR>      ' effort for TIN's QueryPixelBlock.<BR>      If ((nCol - lColOffset) < lMaxBlockX) Then<BR>        pBlockSize.X = (nCol - lColOffset)<BR>        Set pPixelBlock = pRawPixels.CreatePixelBlock(pBlockSize)<BR>        blockArray = pPixelBlock.PixelDataByRef(0)<BR>      End If<BR>            <BR>      ' QueryPixelBlock takes an origin representing the upper left cell center.<BR>      ' Calculate that cell center's position here. Calculate it based on the<BR>      ' raster's origin (lower left) and current row/col offset.<BR>      pBlockOrigin.X = pOrigin.X + (lColOffset * cellsize) + (cellsize * 0.5)<BR>      pBlockOrigin.Y = pOrigin.Y + ((nRow - lRowOffset) * cellsize) - (cellsize * 0.5)<BR>      <BR>      pTinSurf.QueryPixelBlock pBlockOrigin.X, pBlockOrigin.Y, cellsize, cellsize, eRastConvType, vNoData, blockArray<BR>                      <BR>      pOffset.X = lColOffset<BR>      pOffset.Y = lRowOffset<BR>      <BR>      ' The offset for 'write' is the upper left of the pixel block by col/row number.<BR>      ' Base is 0.<BR>      pRawPixels.Write pOffset, pPixelBlock<BR>                  <BR>      If (lBlockCount > 1) Then<BR>        If (Not pCancel.Continue) Then GoTo Cancel<BR>      Else<BR>        If (pTin.ProcessCancelled) Then GoTo Cancel<BR>      End If<BR>      <BR>    Next lColOffset<BR>    <BR>    ' See if pixelblock size needs to be reset for columns<BR>    Dim bReset As Boolean<BR>    bReset = False<BR>    If (pBlockSize.X <> lMaxBlockX) Then<BR>      pBlockSize.X = lMaxBlockX<BR>      bReset = True<BR>    End If<BR>      <BR>    ' See if pixelblock size needs to be reset for rows<BR>    If ((nRow - lRowOffset) < lMaxBlockY) Then<BR>      pBlockSize.Y = (nRow - lRowOffset)<BR>      bReset = True<BR>    End If<BR>        <BR>    If (bReset) Then<BR>      Set pPixelBlock = pRawPixels.CreatePixelBlock(pBlockSize)<BR>      blockArray = pPixelBlock.PixelDataByRef(0)<BR>    End If<BR>        <BR>  Next lRowOffset<BR>            <BR>  'pProg.Message = "Returning cache..."<BR>  pRawPixels.ReturnCache pCache<BR>  Set pCache = Nothing<BR>  <BR>  ' need this for some reason with temporary integer grids<BR>  'If (Not bPerm) And (ePixelType = PT_LONG) Then<BR>'    pProg.Message = "Stats..."<BR>'    Dim pBand As iRasterBand<BR>'    Set pBand = pRawPixels<BR>'    Dim pStats As IRasterStatistics<BR>'    Set pStats = pBand.Statistics<BR>'    pStats.Recalculate<BR>  'End If<BR>  <BR>  'If (bPerm) Then<BR>    ' flush edits to disk by freeing all pointers<BR>    'pProg.Message = "Freeing and opening..."<BR>    Set pRDS = Nothing<BR>    Set pRawPixels = Nothing<BR>    Set pPixelBlock = Nothing<BR>    Set pRasterProps = Nothing<BR>    blockArray = 0<BR>    Set pRDS = OpenRasterDataset(sDir, sName)<BR>  'End If<BR>  <BR>  pApp.StatusBar.HideProgressBar<BR>  <BR>  If (lBlockCount = 1) Then<BR>    Set pTin.TrackCancel = Nothing<BR>  End If<BR>  <BR>  Set TinToRaster = pRDS<BR>  Exit Function<BR>  <BR>Cancel:<BR>  pApp.StatusBar.HideProgressBar<BR>  Set TinToRaster = Nothing<BR>End Function</P>
<P>Public Function OpenRasterDataset(sDir As String, sFile As String) As IRasterDataset</P>
<P>    'Open the raster dataset with the given name.<BR>    'sDir is the directory the file resides<BR>    'sFile is the filename<BR>    <BR>    Dim pWsFact As IWorkspaceFactory<BR>    Dim pWs As IRasterWorkspace<BR>    Dim pRasterDataset As IRasterDataset</P>
<P><BR>    'Open the workspace<BR>    Set pWsFact = New RasterWorkspaceFactory<BR>    Set pWs = pWsFact.OpenFromFile(sDir, 0)</P>
<P>    <BR>    'Open the raster dataset<BR>    Set pRasterDataset = pWs.OpenRasterDataset(sFile)</P>
<P><BR>    'Return<BR>    Set OpenRasterDataset = pRasterDataset</P>
<P>    Set pWsFact = Nothing<BR>    Set pWs = Nothing<BR>    Set pRasterDataset = Nothing</P>
<P>End Function<BR><BR>Public Function GetRawPixels(pRDS As IRasterDataset, band As Long) As IRawPixels<BR>    <BR>    Dim pBandCollection As IRasterBandCollection<BR>    Set pBandCollection = pRDS<BR>    <BR>    Dim pRasterBand As IRasterBand<BR>    Set pRasterBand = pBandCollection.Item(band)<BR>    <BR>    Set GetRawPixels = pRasterBand<BR>    <BR>End Function</P>
<P>Public Function CreateRasterSurf(ByVal sDir As String, ByVal sName As String, ByVal sFormat As String, _<BR>ByVal pOrigin As IPoint, ByVal nCol As Long, ByVal nRow As Long, ByVal cellsizeX As Double, ByVal cellsizeY As Double, _<BR>ByVal ePixelType As rstPixelType, ByVal pSR As ISpatialReference2, ByVal bPerm As Boolean) As IRasterDataset</P>
<P>    Dim rWksFac As IWorkspaceFactory<BR>    Set rWksFac = New RasterWorkspaceFactory</P>
<P>    Dim wks As IWorkspace<BR>    Set wks = rWksFac.OpenFromFile(sDir, 0)</P>
<P>    Dim rWks As IRasterWorkspace2<BR>    Set rWks = wks</P>
<P>    Dim numbands As Long<BR>    numbands = 1</P>
<P>    Dim pRDS As IRasterDataset<BR>    Set pRDS = rWks.CreateRasterDataset(sName, sFormat, pOrigin, nCol, nRow, cellsizeX, cellsizeY, numbands, ePixelType, pSR, bPerm)</P>
<P>    Set CreateRasterSurf = pRDS<BR>    <BR>End Function<BR></P>

TIN图层是好好的，没有什么问题，但是raster生成出来就是不能看，麻烦哪位大侠给个建议吧！～

有本ARCOBJECTS二次开发上有关vc处理tin to raster的程序，你可以看看