modarcgisdlg.bas

FloodEvaluation-程序是gis方面的程序

Attribute VB_Name = "modArcGISDialogs"

'************************************************************************************************
''' ESRI打开、保存对话框
'************************************************************************************************
Option Explicit

'************************************************************************************************
'   调用GXDialog打开图层：栅格、矢量、TIN
'************************************************************************************************
Public Function BrowseToOpenLayer(sPointLinePolyRasterTIN As String, ByRef sReturnPath As String, sDlgTitle As String) As ILayer
  On Error GoTo BrowseForLayer_ERR
  
  Dim pOpenDialog As IGxDialog
  Dim pFilter As IGxObjectFilter
  Dim pSelection As IEnumGxObject
  Dim pGxObject As IGxObject
  Dim pFeatureLayer As IFeatureLayer
  Dim pRasterLayer As IRasterLayer
  Dim sTitle As String
  Dim pDS As IGxDataset
  
  ' define filter for proper layer types:
  Select Case UCase(sPointLinePolyRasterTIN)
    Case "POINT"
      Set pFilter = New GxFilterPointFeatureClasses
      sTitle = "打开点文件"
    Case "LINE"
      Set pFilter = New GxFilterPolylineFeatureClasses
      sTitle = "打开线文件"
    Case "POLY"
      Set pFilter = New GxFilterPolygonFeatureClasses
      sTitle = "打开多边形文件"
    Case "RASTER"
      Set pFilter = New GxFilterRasterDatasets
      sTitle = "打开栅格文件"
    Case "TIN"
    ' todo: TIN implementation
      Exit Function
    Case Else
      Exit Function
  End Select
  
  ' create the dialog, set proper filter:
  Set pOpenDialog = New GxDialog
  
  With pOpenDialog
    .AllowMultiSelect = False
    .Title = sDlgTitle 'sTitle
    Set .ObjectFilter = pFilter
      
    ' open the dialog:
    If .DoModalOpen(0, pSelection) Then
    
      pSelection.Reset
      Set pGxObject = pSelection.Next
      
      ' build the return layer, depending on type:
      If TypeOf pGxObject Is GxDataset Then
        
        Set pDS = pGxObject
        
        Select Case UCase(sPointLinePolyRasterTIN)
          Case "POINT", "LINE", "POLY"
            Set pFeatureLayer = New FeatureLayer
            Set pFeatureLayer.FeatureClass = pDS.Dataset
            pFeatureLayer.name = pDS.Dataset.name
            sReturnPath = EnsureBackslash(pDS.Dataset.Workspace.pathName) & pDS.DatasetName.name
            Set BrowseToOpenLayer = pFeatureLayer

          Case "RASTER"
            Set pRasterLayer = New RasterLayer
            pRasterLayer.CreateFromDataset pDS.Dataset
            pRasterLayer.name = pDS.Dataset.name
            sReturnPath = EnsureBackslash(pDS.Dataset.Workspace.pathName) & pDS.DatasetName.name
            Set BrowseToOpenLayer = pRasterLayer
            
        End Select

      End If
         
    End If
      
  End With

  Exit Function
    
BrowseForLayer_ERR:
  Debug.Assert 0
    
End Function

'************************************************************************************************
'   调用GXDialog保存图层
'************************************************************************************************
Public Function BrowseToSaveFeatureLayer(sShapeFileGDB As String) As String
  On Error GoTo BrowseForLayer_ERR
  
  Dim pSaveDialog As IGxDialog
  Dim pFilter As IGxObjectFilter
  Dim pSelection As IEnumGxObject
  Dim pGxObject As IGxObject
  Dim pFeatureLayer As IFeatureLayer
  Dim pRasterLayer As IRasterLayer
  Dim sTitle As String
  Dim pDS As IGxDataset
  
  ' define filter for proper layer types:
  Select Case UCase(sShapeFileGDB)
    Case "SHAPEFILE", "SHAPE", "SHP"
      Set pFilter = New GxFilterShapefiles
      sTitle = "Save Shapefile"
    Case "GDB", "PGDB"
      'todo: GDB implementation
      Exit Function
    Case Else
      Exit Function
  End Select
  
  ' create the dialog, set proper filter:
  Set pSaveDialog = New GxDialog
  
  With pSaveDialog
    .AllowMultiSelect = False
    .Title = sTitle
    Set .ObjectFilter = pFilter
      
    ' Save the dialog:
    If .DoModalSave(0) Then
      Select Case UCase(sShapeFileGDB)
        Case "SHAPE", "SHP", "SHAPEFILE"
          BrowseToSaveFeatureLayer = EnsureBackslash(.FinalLocation.FullName) & .name
      End Select
    End If
  End With

  Exit Function
    
BrowseForLayer_ERR:
  Debug.Print ERR.Description
  Debug.Assert 0
  Resume Next
  
End Function

'************************************************************************************************
'   returns the path minus the file name:
'   ie. returns "c:\temp" from "c:\temp\table.dbf"
'************************************************************************************************
Public Function ParseForFileDir(sPath As String) As String

  Dim i As Integer
  Dim s As String
  
  On Error GoTo TableDir_ERR
  
  For i = Len(sPath) To 1 Step -1
    s = Mid(sPath, i, 1)
    If s = "\" Then Exit For
  Next
  
  If i > 1 Then ParseForFileDir = Mid(sPath, 1, i - 1)
  
  Exit Function
    
TableDir_ERR:
  Debug.Assert 0
  Debug.Print "TableDir_ERR: " & ERR.Description
  
End Function

'************************************************************************************************
' returns the directory that the file in the path resides in
' ie . returns "Temp.dbf" from "c:\temp\table.dbf"
'************************************************************************************************
Public Function ParseForFileName(ByVal sFilePath As String, Optional bNoExtension As Boolean) As String

  Dim i As Integer
  Dim s As String
  Dim iBeg As Integer
  Dim sName As String
  
  On Error GoTo GetFileName_ERR

  sFilePath = RemoveQuotes(sFilePath)
  For i = Len(sFilePath) To 1 Step -1
    s = Mid(sFilePath, i, 1)
    ' stop when when you get first backslash (s="\"):
    If s = "\" Then Exit For
  Next
  
  iBeg = i + 1
  
  If iBeg - 1 = Len(sFilePath) Then 'is a root dir
    sName = Left(sFilePath, 1)
  Else
    sName = Mid(sFilePath, iBeg)
  End If
  
  If bNoExtension Then
    If Len(sName) > 3 Then
      ' If there is an extension:
      If Mid(sName, Len(sName) - 3, 1) = "." Then
        If Len(sName) > 4 Then
          ParseForFileName = Mid(sName, 1, Len(sName) - 4)
        Else
          ParseForFileName = ""
        End If
      Else
          ParseForFileName = sName
      End If
    Else
    ' no extension- filename is only 3 characters:
      ParseForFileName = sName
    End If
  Else
    ParseForFileName = sName
  End If
  
  Exit Function
    
GetFileName_ERR:
  Debug.Assert 0
  Debug.Print "GetFileName_ERR: " & ERR.Description

End Function

'************************************************************************************************
'   call the GXDialog to browse for a layer file
'************************************************************************************************
Public Function BrowseToSaveLayerFile() As String
  On Error GoTo BrowseForLayer_ERR
  
  Dim pSaveDialog As IGxDialog
  Dim pFilter As IGxObjectFilter
  Dim pSelection As IEnumGxObject
  Dim pGxObject As IGxObject
  Dim pGraphicsLayer As IGraphicsLayer
  Dim sTitle As String
  Dim pDS As IGxDataset
  
  Set pFilter = New GxLayer
  sTitle = "Save Layer"

  ' create the dialog, set proper filter:
  Set pSaveDialog = New GxDialog
  
  With pSaveDialog
    .AllowMultiSelect = False
    .Title = sTitle
    Set .ObjectFilter = pFilter
      
    ' Save the dialog:
    If .DoModalSave(0) Then
      BrowseToSaveLayerFile = EnsureBackslash(.FinalLocation.FullName) & .name
    End If
      
  End With

  Exit Function
    
BrowseForLayer_ERR:
  Debug.Print ERR.Description
  Debug.Assert 0
  Resume Next
  
End Function

'************************************************************************************************
'   call the GXDialog to browse for a RASTER
'************************************************************************************************
Public Function BrowseToSaveRaster() As String
  On Error GoTo BrowseForLayer_ERR
  
  Dim pSaveDialog As IGxDialog
  Dim pFilter As IGxObjectFilter
  Dim pSelection As IEnumGxObject
  Dim pGxObject As IGxObject
  Dim pFeatureLayer As IFeatureLayer
  Dim pRasterLayer As IRasterLayer
  Dim sTitle As String
  Dim pDS As IGxDataset
  
  ' define filter for proper layer types:

  Set pFilter = New GxFilterRasterDatasets
  sTitle = "Save Raster"
  
  ' create the dialog, set proper filter:
  Set pSaveDialog = New GxDialog
  
  With pSaveDialog
    .AllowMultiSelect = False
    .Title = sTitle
    Set .ObjectFilter = pFilter
      
    ' Save the dialog:
    If .DoModalSave(0) Then

      BrowseToSaveRaster = EnsureBackslash(.FinalLocation.FullName) & .name

    End If
      
  End With

  Exit Function
    
BrowseForLayer_ERR:
  Debug.Print ERR.Description
  Debug.Assert 0
  Resume Next
    
End Function

'************************************************************************************************
'   call the GXDialog to browse for a new GDB
'************************************************************************************************
Public Function BrowseToCreateGDB() As String
  On Error GoTo BrowseForLayer_ERR
  
  Dim pSaveDialog As IGxDialog
  Dim pFilter As IGxObjectFilter
  Dim pSelection As IEnumGxObject
  Dim pGxObject As IGxObject
  Dim pFeatureLayer As IFeatureLayer
  Dim pRasterLayer As IRasterLayer
  Dim sTitle As String
  Dim pDS As IGxDataset
  
  ' define filter for proper layer types:

  Set pFilter = New GxFilterPersonalGeodatabases
  sTitle = "Save Geodatabase"
  
  ' create the dialog, set proper filter:
  Set pSaveDialog = New GxDialog
  
  With pSaveDialog
    .AllowMultiSelect = False
    .Title = sTitle
    Set .ObjectFilter = pFilter
      
    ' Save the dialog:
    If .DoModalSave(0) Then

      BrowseToCreateGDB = EnsureBackslash(.FinalLocation.FullName) & .name

    End If
      
  End With

  Exit Function
    
BrowseForLayer_ERR:
  Debug.Print ERR.Description
  Debug.Assert 0
  Resume Next

End Function

'************************************************************************************************
'   call the GXDialog to save a layer file
'************************************************************************************************
Public Function SaveLayerDialog(Optional lParentWindow As Long = 0, Optional ByRef sLayerPath As String) As IGxLayer

  On Error GoTo SaveLayerDialog_ERR

  Dim pGxBrowser As IGxDialog
  Set pGxBrowser = New GxDialog

  Dim pFilter As IGxObjectFilter
  Set pFilter = New GxFilterLayers

  Set pGxBrowser.ObjectFilter = pFilter
  Dim sLayer As String
  Dim sDir As String
  Dim pGLayer As IGraphicsLayer
  Dim pLayer As ILayer
  Dim pGXFile As IGxFile
  Dim pGXLayer As IGxLayer

  If pGxBrowser.DoModalSave(lParentWindow) Then
    
    sLayer = pGxBrowser.name & ".lyr"
    sDir = pGxBrowser.FinalLocation.FullName
    If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
    
    Set pGXLayer = New GxLayer
    Set pGXFile = pGXLayer
    
    pGXFile.Path = sDir & sLayer
    pGXFile.Save
    sLayerPath = sDir & sLayer
    Set SaveLayerDialog = pGXLayer
    
  End If

  Exit Function

SaveLayerDialog_ERR:
    Debug.Print "SaveLayerDialog_ERR: " & ERR.Description
    Debug.Assert 0

End Function

'************************************************************************************************
'EnsureBackslash
'************************************************************************************************
Private Function EnsureBackslash(sPath As String) As String
  On Error Resume Next
  If Not (Right(sPath, 1) = "\") Then sPath = sPath & "\"
  EnsureBackslash = sPath
  
End Function


Public Function BrowseToOpenLayer2(sReturnPath As String) As ILayer
'Private Function BrowseForGN(pGeoNet As IGeometricNetwork) As Boolean
  On Error GoTo Fail

  On Error GoTo Fail
  Dim pOpenDialog As IGxDialog
  Dim pFilter As IGxObjectFilter
  Dim pSelection As IEnumGxObject
  Dim pGxObject As IGxObject
  Dim pFeatureLayer As IFeatureLayer
  Dim pRasterLayer As IRasterLayer
  Dim sTitle As String
  Dim pDS As IGxDataset
  Dim theLyr As ILayer
  ' define filter for proper layer types:
  
  ' create the dialog, set proper filter:
  Set pOpenDialog = New GxDialog
  Set pFilter = New GxFilterGeoDatasets
  
  With pOpenDialog
    .AllowMultiSelect = False
    .Title = "请选择图层" 'sTitle
    Set .ObjectFilter = pFilter
      
    ' open the dialog:
    If .DoModalOpen(0, pSelection) Then
    
      pSelection.Reset
      Set pGxObject = pSelection.Next
      
      ' build the return layer, depending on type:
      If TypeOf pGxObject Is GxDataset Then
        
        Set pDS = pGxObject
        
        Select Case pDS.Type  ' UCase(sPointLinePolyRasterTIN)
          Case esriDTFeatureDataset, esriDTFeatureClass
            Set pFeatureLayer = New FeatureLayer
            Set pFeatureLayer.FeatureClass = pDS.Dataset
            pFeatureLayer.name = pDS.Dataset.name
            sReturnPath = EnsureBackslash(pDS.Dataset.Workspace.pathName) & pDS.DatasetName.name
            Set theLyr = pFeatureLayer

          Case esriDTRasterDataset, esriDTRasterBand
            Set pRasterLayer = New RasterLayer
            pRasterLayer.CreateFromDataset pDS.Dataset
            
            pRasterLayer.name = pDS.Dataset.name
            sReturnPath = EnsureBackslash(pDS.Dataset.Workspace.pathName) & pDS.DatasetName.name
            Set theLyr = pRasterLayer
            
        End Select

      End If
         
    End If
      
  End With

  Set BrowseToOpenLayer2 = theLyr
 
  Exit Function

Fail:
  MsgBox "打开图层失败"
End Function