mosaicrastercom.bas

利用VB、Java、C++实现的AE镶嵌工具。

Attribute VB_Name = "basMosaicRaster"

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]


Option Explicit
'Public m_App As IApplication

Public Function OpenRasterDataset(sDir As String, sRasterDs As String) As IRasterDataset
  ' Open raster dataset in a workspace
  On Error GoTo er
  Dim pWsFact As IWorkspaceFactory
  Dim pWs As IRasterWorkspace
  
  Set pWsFact = New RasterWorkspaceFactory
  Set pWs = pWsFact.OpenFromFile(sDir, 0)
  Set OpenRasterDataset = pWs.OpenRasterDataset(sRasterDs)

  Set pWsFact = Nothing
  Set pWs = Nothing
  Exit Function
er:
  MsgBox "Open Raster Dataset Error :" + Err.Description
  
End Function

Public Function GetExtension(sFileName As String) As String
  Dim iPos As Integer
  Dim sName As String
  iPos = InStr(sFileName, ".")
  If iPos > 0 Then sName = Mid(sFileName, iPos, Len(sFileName)) Else sName = ""
  GetExtension = sName
End Function

Public Function GetIntersectionExtents(ByVal pRasterBandCol As IRasterBandCollection) As IEnvelope
  ' This function extract intersections of all bands in a band collection
  Dim pExtent As IEnvelope
  Dim pRasterProp As IRasterProps
  Dim i As Integer
  
  On Error GoTo er
  ' loop through all the bands and get intersection
  For i = 0 To pRasterBandCol.Count - 1
    Set pRasterProp = pRasterBandCol.Item(i)
    If i = 0 Then
      Set pExtent = pRasterProp.Extent
    Else
      pExtent.Intersect pRasterProp.Extent
    End If
  Next i
  
  Set GetIntersectionExtents = pExtent
  Set pExtent = Nothing
  Set pRasterProp = Nothing
  Exit Function
er:
  MsgBox "Error getting intersection"
End Function

Public Function GetFormatFromExt(sExt As String) As String
  ' Get format string from extension
  Select Case sExt:
    Case ".img": GetFormatFromExt = "IMAGINE Image"
                 Exit Function
    Case ".IMG": GetFormatFromExt = "IMAGINE Image"
                 Exit Function
    Case ".TIF": GetFormatFromExt = "TIFF"
                 Exit Function
    Case ".tif": GetFormatFromExt = "TIFF"
                 Exit Function
    Case "": GetFormatFromExt = "GRID"
             Exit Function
default:     MsgBox "Invalid raster format"
  End Select
End Function

Public Function GetVBSupportedPixelType(iPixeltype As Integer)
  ' change pixeltype for those not supported by VB
  If iPixeltype <= 4 Then
      GetVBSupportedPixelType = 3
  ElseIf iPixeltype <= 6 Then
      GetVBSupportedPixelType = 6
  ElseIf iPixeltype <= 8 Then
      GetVBSupportedPixelType = 8
  ElseIf iPixeltype > 9 Then
      GetVBSupportedPixelType = 9
  End If
End Function

Public Function AddRasterLayerToComboBox(cboBox As ComboBox, pMap As IMap) As IRasterLayer
    On Error GoTo erh
    cboBox.Clear
    Dim iLyrIndex As Long
    Dim pLyr As ILayer
    ' Add raster layers into  Combobox
    Dim iLayerCount As Integer
    iLayerCount = pMap.LayerCount
    If iLayerCount > 0 Then
        cboBox.Enabled = True
        For iLyrIndex = 0 To iLayerCount - 1
            Set pLyr = pMap.Layer(iLyrIndex)
            If (TypeOf pLyr Is IRasterLayer) Then
                cboBox.AddItem pLyr.Name
                cboBox.ItemData(cboBox.ListCount - 1) = iLyrIndex
            End If
        Next iLyrIndex
        If (cboBox.ListCount > 0) Then
            cboBox.ListIndex = 0
            cboBox.Text = pMap.Layer(cboBox.ItemData(0)).Name
            Set AddRasterLayerToComboBox = pMap.Layer(cboBox.ItemData(0))
        End If
    End If
    Exit Function
erh:
    Set AddRasterLayerToComboBox = Nothing
End Function
Public Function IsIntersect(pExt1 As IEnvelope, pExt2 As IEnvelope) As Boolean
    If ((pExt1.XMax > pExt2.XMin And pExt1.XMax < pExt2.XMax) Or _
       (pExt1.XMin > pExt2.XMin And pExt1.XMin < pExt2.XMax)) And _
       ((pExt1.YMax > pExt2.YMin And pExt1.YMax < pExt2.YMax) Or _
       (pExt1.YMin > pExt2.YMin And pExt1.YMin < pExt2.YMax)) Then
       IsIntersect = True
    Else
        IsIntersect = False
    End If
End Function
Public Function SetRasterWorkspace(sPath As String) As IWorkspace
' Given a pathname, returns the raster workspace object for that path
    On Error GoTo ErrorSetWorkspace
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New RasterWorkspaceFactory
'    If pWSF.IsWorkspace(sPath) Then
        Set SetRasterWorkspace = pWSF.OpenFromFile(sPath, 0)
        Set pWSF = Nothing
'    End If
    Exit Function
ErrorSetWorkspace:
    Set SetRasterWorkspace = Nothing
End Function

Public Sub ClipRasterWithDefinedCellSize(CellSize As Double, pExt As IEnvelope, ByRef pRaster As IRaster)
    
    'Calculate height and width of the new raster
    Dim Col As Integer, Row As Integer
    With pExt
            Col = Int((.XMax - .XMin) / CellSize)
            Row = Int((.YMax - .YMin) / CellSize)
    End With
    
    ' adjust the extent
    Dim pLL As IPoint, pUR As IPoint
    Dim pNewExtent As IEnvelope
    Set pUR = New Point
    Set pNewExtent = New Envelope
    Set pLL = pExt.LowerLeft
    pUR.X = pLL.X + Col * CellSize
       pUR.Y = pLL.Y + Row * CellSize
    pNewExtent.LowerLeft = pLL
    pNewExtent.UpperRight = pUR
    
    'Put the new extent first
    Dim pRasterProps As IRasterProps
    Set pRasterProps = pRaster
    pRasterProps.Extent = pNewExtent
    
    'Then put height and width
    pRasterProps.Height = Row
    pRasterProps.Width = Col
End Sub
Public Function DeleteFiles(sPath As String, sName As String)
  On Error GoTo erh
  Dim FSO
  Set FSO = CreateObject("scripting.filesystemobject")
  If FSO.FileExists(sPath & "\" & sName) = True Then
    MsgBox "file exists"
    Dim pNameList() As String
    pNameList = Split(sName, ".")
    sName = pNameList(0)
    FSO.DeleteFile sPath & "\" & sName & ".*"
    MsgBox "file deleted"
  End If
erh:
End Function
Public Function GetMosaicTypeIndex(sText As String) As Integer
    Select Case sText
    Case "MT_FIRST"
        GetMosaicTypeIndex = 1
    Case "MT_LAST"
        GetMosaicTypeIndex = 2
    Case "MT_MIN"
        GetMosaicTypeIndex = 3
    Case "MT_MAX"
        GetMosaicTypeIndex = 4
    Case "MT_MEAN"
        GetMosaicTypeIndex = 5
    Case "MT_BLEND"
        GetMosaicTypeIndex = 6
    End Select
End Function
Public Function GetResampleTypeIndex(sText As String) As Integer
    Select Case sText
    Case "NearestNeighbor"
        GetResampleTypeIndex = 0
    Case "BilinearInterpolation"
        GetResampleTypeIndex = 1
    Case "CubicConvolution"
        GetResampleTypeIndex = 2
    End Select
End Function
Public Function GetColormapModeIndex(sText As String) As Integer
    Select Case sText
    Case "MM_FIRST"
        GetColormapModeIndex = 0
    Case "MM_LAST"
        GetColormapModeIndex = 1
    Case "MM_MATCH"
        GetColormapModeIndex = 2
    Case "MM_REJECT"
        GetColormapModeIndex = 3
    End Select
End Function
Public Function GetDataTypeIndex(sText As String) As Integer
    Select Case sText
    Case "1 bit"
        GetDataTypeIndex = 0
    Case "2 bit"
        GetDataTypeIndex = 1
    Case "4 bit"
        GetDataTypeIndex = 2
    Case "unsigned 8 bit"
        GetDataTypeIndex = 3
    Case "signed 8 bit"
        GetDataTypeIndex = 4
     Case "unsigned 16 bit"
        GetDataTypeIndex = 5
    Case "signed 16 bit"
        GetDataTypeIndex = 6
    Case "unsigned 32 bit"
        GetDataTypeIndex = 7
    Case "signed 32 bit"
        GetDataTypeIndex = 8
    Case "float"
        GetDataTypeIndex = 9
    Case "double"
        GetDataTypeIndex = 10
   End Select
End Function