Resample raster datasets to same cell size and align

Created:4/24/2001
Description:

This sample uses geometryproc object to resample raster datasets in a directory to same cell size and align each other on exact cell positions, this can be used as preprocessing for mosaicking rasters in ArcSDE because only those rasters with same cell size and align perfectly can be mosaicked in ArcSDE.

How to use:
  1. Call this procedure from VB or VBA.
Private Sub Resample(sdir As String)
	      
   ' This procedure resamples rasters in a directory to match the cell size of the first raster
   ' in the directory and to align along cells.
	    
  On Error GoTo er
  Dim pWsFact As IWorkspaceFactory
  Dim pWs As IWorkspace
  Dim pEnumRasters As IEnumDataset
  Dim pRasterDs As IRasterDataset
  Dim pRasterProp As IRasterProps
  Dim xmin As Double, ymin As Double
  Dim pGeometryProc As IRasterGeometryProc
  Dim dX As Double, dY As Double, dx0 As Double, dy0 As Double
  Dim lScale As Double
  Dim pBandc As IRasterBandCollection
  Dim pRaster As IRaster
  Dim pSourcePoints As IPointCollection
  Dim pTargetPoints As IPointCollection
  Dim pPoint As IPoint	
	   
  ' Get enumrasterdatasets in the directory	 
  Set pWsFact = New RasterWorkspaceFactory
  Set pWs = pWsFact.OpenFromFile(sdir, 0)
  Set pEnumRasters = pWs.Datasets(esriDTRasterDataset)
  	   
  ' Get extent, cell size of first one	 
  Set pRasterDs = pEnumRasters.Next
  Set pBandc = pRasterDs.CreateDefaultRaster
  Set pRasterProp = pBandc.Item(0)
  With pRasterProp.Extent	   
    ' lowerleft corner	 
    xmin = .xmin
    ymin = .ymin	   
    ' set scale factor for small cell size cases	 
    lScale = 10 ^ 10	   
    ' calculate x and y cellsize	 
    dX = (.XMax - .xmin) * lScale / (pRasterProp.Width)
    dY = (.YMax - .ymin) * lScale / pRasterProp.Height
  End With
  	   
  ' Loop through all rasterdatasets and resample	 
  Set pGeometryProc = New RasterGeometryProc
  Set pRasterDs = pEnumRasters.Next
  Do While Not pRasterDs Is Nothing
	   
    ' get rasterprops	 
    Set pRaster = pRasterDs.CreateDefaultRaster
    Set pBandc = pRaster
    Set pRasterProp = pBandc.Item(0)
    	   
    ' x and y difference from the first raster	 
    With pRasterProp.Extent
      dx0 = (.xmin - xmin) * lScale
      dy0 = (.ymin - ymin) * lScale
    End With
    	   
    ' residue for x, y, at most half pixel	 
    dx0 = dx0 / dX - CLng(dx0 / dX)
    dy0 = dy0 / dY - CLng(dy0 / dY)
    dx0 = dx0 * dX / lScale
    dy0 = dy0 * dY / lScale
	   
    ' collections of source and target points for two point transform	 
    Set pSourcePoints = New Multipoint
    Set pTargetPoints = New Multipoint
    Set pPoint = New Point
	       
    ' use lowerleft and upperright points for two point adjust	 
    With pRasterProp.Extent
      pSourcePoints.AddPoint .LowerLeft
      pSourcePoints.AddPoint .UpperRight
      pPoint.PutCoords .xmin - dx0, .ymin - dy0
      pTargetPoints.AddPoint pPoint
      Set pPoint = New Point
      pPoint.PutCoords .xmin - dx0 + dX / lScale * pRasterProp.Width, .ymin - dy0 + dY / lScale * pRasterProp.Height
      pTargetPoints.AddPoint pPoint
    End With
   	   
    ' two point adjust	 
    pGeometryProc.TwoPointsAdjust pSourcePoints, pTargetPoints, pRaster
       
    pGeometryProc.Register pRaster
	   
    ' get next one	 
    Set pRasterDs = pEnumRasters.Next
  Loop
  	   
  ' cleanup	 
  Set pWsFact = Nothing
  Set pWs = Nothing
  Set pEnumRasters = Nothing
  Set pRasterDs = Nothing
  Set pRasterProp = Nothing
  Set pBandc = Nothing
  Set pGeometryProc = Nothing
  Set pRaster = Nothing
  Set pSourcePoints = Nothing
  Set pTargetPoints = Nothing
  Set pPoint = Nothing
  
  Exit Sub
  
er:
  MsgBox Err.Description
End Sub