Attribute VB_Name = "Module1"
Public Sub drgclipper()

Dim pMxDoc As IMxDocument
Set pMxDoc = Application.Document

Dim pMap As IMap
Set pMap = pMxDoc.FocusMap

Dim pLayer As ILayer
Dim pRLayer As IRasterLayer
Dim pRasterProps As IRasterProps
Dim pProjSpatRef As ISpatialReference
Dim pPCS As IProjectedCoordinateSystem
Dim pGCS As IGeographicCoordinateSystem
Dim pGeoSpatRef As ISpatialReference
Dim pEnv As IEnvelope
Dim pLowerRight As IPoint
Dim UnprojLR As IPoint
Dim pPtColl As IPointCollection
Dim pPoint(4) As IPoint
Dim pDensPoly As IPolygon
Dim pProjPoly As IPolygon
Dim pExtractionOp As IExtractionOp
Dim pInputDataset As IGeoDataset
Dim pRasterAnalysisEnvironment As IRasterAnalysisEnvironment
Dim pOutputDataset As IRaster
Dim pDataset As IDataset
Dim pWS As IWorkspace
Dim pDRG As String, pPathName As String, pOutName As String
Dim dp As Long
Dim pRBC As IRasterBandCollection
Dim pRB As IRasterBand
Dim pRasterDataset As IRasterDataset
Dim pRDS As IRasterDataset
Dim pR As IRaster
Dim pRBC2 As IRasterBandCollection
Dim pRB2 As IRasterBand
Dim pRCM As IRasterColormap
Dim rv As Integer, gv As Integer, bv As Integer
Dim pActiveView As IActiveView
Dim pRasLyr As IRasterLayer
Dim pRLG As ILegendGroup
Dim pRLI As ILegendInfo
Dim pContView As IContentsView

For i = 0 To pMap.LayerCount - 1
    Set pLayer = pMap.Layer(i)

    If (TypeOf pLayer Is IRasterLayer And pLayer.Name Like "*.*") Then
        Set pRLayer = pLayer
    
        'get spatial reference information of DRG
        Set pRasterProps = pRLayer.Raster
        Set pProjSpatRef = pRasterProps.SpatialReference
        
        If (pProjSpatRef Is Nothing) Then
        
            MsgBox "Cannot clip DRG without spatial reference information.", 48
            
        Else
            Set pPCS = pProjSpatRef
            Set pGCS = pPCS.GeographicCoordinateSystem
            Set pGeoSpatRef = pGCS
            
            'obtain southeast corner of DRG
            Set pEnv = pRasterProps.Extent
            Set pLowerRight = pEnv.LowerRight
            Set pLowerRight.SpatialReference = pProjSpatRef
            Set UnprojLR = pLowerRight
            UnprojLR.Project pGeoSpatRef
            ux = UnprojLR.X
            uy = UnprojLR.Y
            
            'width of DRG
            drgwid = pEnv.Width
            
            If drgwid <= 50000 Then '24K DRGs
            
                'obtain southeast corner of neatline
                For ax = 0 To -1 Step -0.125
                    If ((ux - Fix(ux)) > ax) Then
                        xf = Fix(ux) + ax
                        Exit For
                    End If
                Next
                For ay = 0 To 1 Step 0.125
                    If ((uy - Fix(uy)) < ay) Then
                        yf = Fix(uy) + ay
                        Exit For
                    End If
                Next
                
                'construct clipping polygon
                Set pPtColl = New Polygon
        
                For j = 0 To 4
                    Set pPoint(j) = New Point
                Next
                pPoint(0).PutCoords xf, yf
                pPoint(1).PutCoords (xf - 0.125), yf
                pPoint(2).PutCoords (xf - 0.125), (yf + 0.125)
                pPoint(3).PutCoords xf, (yf + 0.125)
                pPoint(4).PutCoords xf, yf
                pPtColl.AddPoints 5, pPoint(0)
            
            ElseIf (drgwid > 50000 And drgwid < 140000) Then '100K DRGs
           
                'obtain southeast corner of neatline
                xf = Round(ux)
                For ay = 0 To 1 Step 0.5
                    If ((uy - Fix(uy)) < ay) Then
                        yf = Fix(uy) + ay
                        Exit For
                    End If
                Next
                
                'construct clipping polygon
                Set pPtColl = New Polygon
        
                For j = 0 To 4
                    Set pPoint(j) = New Point
                Next
                pPoint(0).PutCoords xf, yf
                pPoint(1).PutCoords (xf - 1), yf
                pPoint(2).PutCoords (xf - 1), (yf + 0.5)
                pPoint(3).PutCoords xf, (yf + 0.5)
                pPoint(4).PutCoords xf, yf
                pPtColl.AddPoints 5, pPoint(0)
                     
            Else ' 250K DRGs
           
                'obtain southeast corner of neatline
                xf = Round(ux)
                yf = Round(uy)
                
                'construct clipping polygon
                Set pPtColl = New Polygon
        
                For j = 0 To 4
                    Set pPoint(j) = New Point
                Next
                pPoint(0).PutCoords xf, yf
                pPoint(1).PutCoords (xf - 2), yf
                pPoint(2).PutCoords (xf - 2), (yf + 1)
                pPoint(3).PutCoords xf, (yf + 1)
                pPoint(4).PutCoords xf, yf
                pPtColl.AddPoints 5, pPoint(0)
            
            End If
            
            'densify clipping polygon
            Set pDensPoly = pPtColl
            pDensPoly.Densify 0.03125, 0
            Set pDensPoly.SpatialReference = pGeoSpatRef
                    
            'project clipping polygon
            Set pProjPoly = pDensPoly
            pProjPoly.Project pProjSpatRef
                        
            'name and path for output grid
            Set pDataset = pRLayer
            Set pWS = pDataset.Workspace
            pDRG = pDataset.Name
            dp = InStr(pDRG, ".")
            pOutName = "clp" & Left(pDRG, dp - 1)
            pOutName = Replace(pOutName, "_", "")
            If (Len(pOutName) > 13) Then
                pOutName = Left(pOutName, 13)
            End If
            pPathName = pWS.PathName
            
            Set FSO = CreateObject("Scripting.FileSystemObject")
            
            Do While (FSO.FolderExists(pPathName & pOutName) _
                        Or Not Dir(pPathName & pOutName & ".*") = "")
                
                pOutName = InputBox("File " & pOutName & _
                                    " already exists. Enter new file name", , pOutName)
                If (Len(pOutName) > 13) Then
                    pOutName = Left(pOutName, 13)
                End If
   
            Loop
            
            'clip DRG
            Set pExtractionOp = New RasterExtractionOp
            Set pInputDataset = pRLayer.Raster
            Set pRasterAnalysisEnvironment = pExtractionOp
            pRasterAnalysisEnvironment.SetExtent esriRasterEnvValue, pProjPoly.Envelope
            Set pOutputDataset = pExtractionOp.Polygon(pInputDataset, pProjPoly, True)
            
            'output file
            Set pRBC = pOutputDataset
            Set pRB = pRBC.Item(0)
            Set pRasterDataset = pRB.RasterDataset
            Set pRDS = pRasterDataset.Copy(pOutName, pWS)
            
            'create external colormap file
            Set pR = pRLayer.Raster
            Set pRBC2 = pR
            Set pRB2 = pRBC2.Item(0)
            Set pRCM = pRB2.Colormap
            Set fs = CreateObject("Scripting.FileSystemObject")
            Set a = fs.CreateTextFile(pPathName & pOutName & ".clr", True)
            For v = 0 To 255
                rv = Round(pRCM.RedValues(v) * 256)
                gv = Round(pRCM.GreenValues(v) * 256)
                bv = Round(pRCM.BlueValues(v) * 256)
                a.WriteLine (v & " " & rv & " " & gv & " " & bv)
            Next
            a.Close
            
            'remove original and add clipped to map
            pMap.DeleteLayer pRLayer
            Set pRasLyr = New RasterLayer
            pRasLyr.CreateFromDataset pRDS
            pMap.AddLayer pRasLyr
            pMap.MoveLayer pRasLyr, i
            
            'collapse legend
            Set pRLI = pRasLyr
            Set pRLG = pRLI.LegendGroup(0)
            pRLG.Visible = False
            
            'Refresh contents to reflect changes
            Set pContView = pMxDoc.CurrentContentsView
            pContView.Refresh (0)
            Set pActiveView = pMap
            pActiveView.PartialRefresh esriViewGeography, Nothing, Nothing
            
        End If
        
    End If
    
Next

Set pMxDoc = Nothing
Set pMap = Nothing
Set pLayer = Nothing
Set pRLayer = Nothing
Set pRasterProps = Nothing
Set pProjSpatRef = Nothing
Set pPCS = Nothing
Set pGCS = Nothing
Set pGeoSpatRef = Nothing
Set pEnv = Nothing
Set pLowerRight = Nothing
Set UnprojLR = Nothing
Set pPtColl = Nothing
Set pPoint(4) = Nothing
Set pDensPoly = Nothing
Set pProjPoly = Nothing
Set pExtractionOp = Nothing
Set pInputDataset = Nothing
Set pRasterAnalysisEnvironment = Nothing
Set pOutputDataset = Nothing
Set pDataset = Nothing
Set pWS = Nothing
Set pRBC = Nothing
Set pRB = Nothing
Set pRasterDataset = Nothing
Set pRDS = Nothing
Set pR = Nothing
Set pRBC2 = Nothing
Set pRB2 = Nothing
Set pRCM = Nothing
Set pActiveView = Nothing
Set pRasLyr = Nothing
Set pRLG = Nothing
Set pRLI = Nothing
Set pContView = Nothing

End Sub