dbutil.bas

FloodEvaluation-程序是gis方面的程序

Attribute VB_Name = "modDBUtil"
'
' ESRI
' 3D Analyst Developer Sample Utility
' moddbutil.bas
' Methods for general ArcGIS database tasks
'
Option Explicit

Private m_sErrorMsg As String
Private m_lErrorCode As Long

' Returns the spatial reference of the layer's data source. Only features, tins, and
' rasters supported at this time.
' TODO - support all layer types.
Public Function GetLayerSourceSpatialRef(pLayer As ILayer) As ISpatialReference
  If (TypeOf pLayer Is IFeatureLayer) Then
    Dim pFLayer As IFeatureLayer
    Set pFLayer = pLayer
    Dim pGDS As IGeoDataset
    Set pGDS = pFLayer.FeatureClass
  ElseIf (TypeOf pLayer Is ITinLayer) Then
    Dim pTLayer As ITinLayer
    Set pTLayer = pLayer
    Set pGDS = pTLayer.Dataset
  ElseIf (TypeOf pLayer Is IRasterLayer) Then
    Dim pRLayer As IRasterLayer
    Set pRLayer = pLayer
    Dim pRasterBands As IRasterBandCollection
    Set pRasterBands = pRLayer.Raster
    Dim pRasterBand As iRasterBand
    Set pRasterBand = pRasterBands.Item(0)
    Set pGDS = pRasterBand.RasterDataset
  End If
  Set GetLayerSourceSpatialRef = pGDS.SpatialReference
End Function


' Brings up GxDialog to get output name for specified type. Returns true if user defines output name or
' false if operation cancelled.
Public Function BrowseForOutputName(ByRef sName As String, ByRef sLocation As String, eType As esriDatasetType, hParentHwnd As OLE_HANDLE) As Boolean
  On Error GoTo EH
  Dim pGxDialog As IGxDialog
  Set pGxDialog = New GxDialog
  Dim pFilter As IGxObjectFilter
  Dim pFilterCol As IGxObjectFilterCollection
  Set pFilterCol = pGxDialog
  
  Select Case eType
    Case esriDTFeatureClass
      pGxDialog.Title = "Save Features As"
      Set pFilter = New GxFilterShapefiles
      Dim bDefault As Boolean ' determine which filter is default by looking at current browse location
      bDefault = ((Not LocationSupportsAccess(sLocation)) And (LocationSupportsSDE(sLocation)))
      pFilterCol.AddFilter pFilter, bDefault
      Set pFilter = New GxFilterPGDBFeatureClasses
      bDefault = (LocationSupportsAccess(sLocation))
      pFilterCol.AddFilter pFilter, bDefault
      Set pFilter = New GxFilterSDEFeatureClasses
      bDefault = (LocationSupportsSDE(sLocation))
      pFilterCol.AddFilter pFilter, bDefault
    Case esriDTTin
      pGxDialog.Title = "Save TIN As"
      Set pFilter = New GxFilterTINDatasets
      pFilterCol.AddFilter pFilter, True
    Case esriDTRasterBand
      pGxDialog.Title = "Save Raster As"
      Set pFilter = New GxFilterRasterDatasets
      pFilterCol.AddFilter pFilter, True
    Case esriDTText
      pGxDialog.Title = "Save File As"
      Set pFilter = New GxFilterTextFiles
      pFilterCol.AddFilter pFilter, True
    Case Else
  End Select
  
  pGxDialog.StartingLocation = sLocation
  
  If (pGxDialog.DoModalSave(hParentHwnd)) Then ' using this form as parent keeps dialog forward
    Dim pGxObject As IGxObject             ' of parent application when pressing save key on browser
    Set pGxObject = pGxDialog.FinalLocation
    sLocation = pGxObject.FullName
    sName = sLocation & "\" & pGxDialog.name
    'MsgBox pGxObject.Category
    BrowseForOutputName = True
  Else
    BrowseForOutputName = False
  End If
  
  Exit Function
EH:
  BrowseForOutputName = False
End Function


' Returns true if container specifies either Access workspace or dataset
Public Function LocationSupportsAccess(sContainer As String) As Boolean
  On Error GoTo EH
  Dim pWSFact As IWorkspaceFactory
  Dim pFeatws As IFeatureWorkspace

  If (sContainer <> "") Then
    ' see if access dataset
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Dim sWSName As String
    sWSName = fs.GetParentFolderName(sContainer)
    Dim sDSName As String
    sDSName = fs.GetFileName(sContainer)
    If (IsAccessDataset(sWSName, sDSName)) Then
      LocationSupportsAccess = True
    Else ' see if access workspace
      Set pWSFact = New AccessWorkspaceFactory
      Set pFeatws = pWSFact.OpenFromFile(sContainer, 0)
      LocationSupportsAccess = (Not pFeatws Is Nothing)
    End If
  Else
    LocationSupportsAccess = False
  End If

  ' this is faster:
  LocationSupportsAccess = (InStr(sContainer, ".mdb") > 0) ' as long as it has an access extension in it somewhere
  
  Exit Function
EH:
  LocationSupportsAccess = False
End Function

Public Function LocationSupportsRasters(sContainer As String) As Boolean
  On Error GoTo EH
'  Dim pWSFact As IWorkspaceFactory
'  Dim pRasWS As IRasterWorkspace
'
'  If (sContainer <> "") Then
'    Set pWSFact = New RasterWorkspaceFactory
'    Set pRasWS = pWSFact.OpenFromFile(sContainer, 0)
'    LocationSupportsRasters = (Not pRasWS Is Nothing)
'  Else
'    LocationSupportsRasters = False
'  End If

  ' this is faster:
  LocationSupportsRasters = ((Not IsCoverage(sContainer)) And (Not LocationSupportsAccess(sContainer)) And (Not LocationSupportsSDE(sContainer)))
  
  Exit Function
EH:
  LocationSupportsRasters = False
End Function

Public Function LocationSupportsTins(sContainer As String) As Boolean
  On Error GoTo EH
'  Dim pWSFact As IWorkspaceFactory
'  Dim pTinWS As ITinWorkspace
'
'  If (sContainer <> "") Then
'    Set pWSFact = New TinWorkspaceFactory
'    Set pTinWS = pWSFact.OpenFromFile(sContainer, 0)
'    LocationSupportsTins = (Not pTinWS Is Nothing)
'  Else
'    LocationSupportsTins = False
'  End If

'  LocationSupportsTins = LocationSupportsShapefiles(sContainer) ' TODO - use this instead because of CQ00118798

  ' this is faster
    LocationSupportsTins = ((Not IsCoverage(sContainer)) And (Not LocationSupportsAccess(sContainer)) And (Not LocationSupportsSDE(sContainer)))
    
    Exit Function
EH:
  LocationSupportsTins = False
End Function

' Returns true if container specifies either SDE workspace or dataset
Public Function LocationSupportsSDE(sContainer As String) As Boolean
  On Error GoTo EH

  LocationSupportsSDE = (InStr(sContainer, "Database") = 1) ' as long as it has reference to database connection
  
  Exit Function
EH:
  LocationSupportsSDE = False
End Function

Public Function LocationSupportsShapefiles(sContainer As String) As Boolean
  On Error GoTo EH
'  Dim pWSFact As IWorkspaceFactory
'  Dim pFeatws As IFeatureWorkspace
'
'  If (sContainer <> "") Then
'    Set pWSFact = New ShapefileWorkspaceFactory
'    Set pFeatws = pWSFact.OpenFromFile(sContainer, 0)
'    LocationSupportsShapefiles = (Not pFeatws Is Nothing)
'  Else
'    LocationSupportsShapefiles = False
'  End If

  ' this is faster
  LocationSupportsShapefiles = (Not IsCoverage(sContainer)) And (Not (LocationSupportsAccess(sContainer)) And (Not LocationSupportsSDE(sContainer)))
  
  Exit Function
EH:
  LocationSupportsShapefiles = False
End Function
  

Public Function IsCoverage(sContainer) As Boolean
  On Error GoTo EH
'  Dim fs As FileSystemObject
'  Set fs = New FileSystemObject
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  Dim sDir As String
  sDir = fs.GetParentFolderName(sContainer)
  Dim sName As String
  sName = fs.GetFileName(sContainer)
  Dim pWSF As IWorkspaceFactory
  Set pWSF = New ArcInfoWorkspaceFactory
  Dim pWS As IFeatureWorkspace
  Set pWS = pWSF.OpenFromFile(sDir, 0)
  Dim pDS As IFeatureDataset
  Set pDS = pWS.OpenFeatureDataset(sName)
  IsCoverage = (Not pDS Is Nothing)
  Exit Function
EH:
  Resume Next
End Function
Public Function OpenFeatureWorkspace(sConnect As String) As IFeatureWorkspace
  On Error GoTo EH
  Dim pWSF As IWorkspaceFactory
  Set pWSF = New ShapefileWorkspaceFactory ' attempt as shapefile
  Dim pWS As IFeatureWorkspace
  Set pWS = pWSF.OpenFromFile(sConnect, 0)
  If (pWS Is Nothing) Then
    Set pWSF = New AccessWorkspaceFactory ' attempt as access
    Set pWS = pWSF.OpenFromFile(sConnect, 0)
    If (pWS Is Nothing) Then
'      Dim fs As FileSystemObject
'      Set fs = New FileSystemObject
        Dim fs
        Set fs = CreateObject("Scripting.FileSystemObject")
      Set pWS = pWSF.OpenFromFile(fs.GetParentFolderName(sConnect), 0) ' attempt as access dataset
      If (pWS Is Nothing) Then
        Dim pGxCat As IGxCatalog
        Set pGxCat = New GxCatalog
        Dim pDB As IGxDatabase
        Dim i As Long
        Set pDB = pGxCat.GetObjectFromFullName(sConnect, i) ' attempt as sde
        Set pWS = pDB.Workspace
        If (pWS Is Nothing) Then
          Set pDB = pGxCat.GetObjectFromFullName(fs.GetParentFolderName(sConnect), i) ' attempt as sde dataset
          Set pWS = pDB.Workspace
        End If
      End If
    End If
  End If
  Set OpenFeatureWorkspace = pWS
  Exit Function
EH:
  Resume Next
End Function

' Designed to take a proposed output name and determine what type of output it is, being folder
' based (shapefiles, tins, rasters), Access based, or SDE based. The sName argument should be the full
' name of a feature class, raster, or tin (existing or not). When specifying a database the path naming
' convention should follow ArcCatalog (e.g. 'Database Connections\Connection to luke.sde\myfc' or
' 'c:\myaccess.mdb\mydataset\myfc')
Public Function GetWorkspaceCategory(sName As String) As String
'  Dim fs As FileSystemObject
'  Set fs = New FileSystemObject
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  
  Dim sWorkspaceName As String
  sWorkspaceName = fs.GetParentFolderName(sName)
  If (modDBUtil.LocationSupportsShapefiles(sWorkspaceName)) Then ' tins and rasters are supported in shapefile
    GetWorkspaceCategory = "FOLDER"                           ' folders too
  ElseIf (modDBUtil.LocationSupportsAccess(sWorkspaceName)) Then
    Dim sDBName As String
    sDBName = fs.GetParentFolderName(sWorkspaceName)
    Dim sDSName As String
    sDSName = fs.GetFileName(sWorkspaceName)
    If (modDBUtil.IsAccessDataset(sDBName, sDSName)) Then
      GetWorkspaceCategory = "PERSONAL GEODATABASE FEATURE DATASET"
    Else
      GetWorkspaceCategory = "PERSONAL GEODATABASE"
    End If
  ElseIf (modDBUtil.LocationSupportsSDE(sWorkspaceName)) Then
    sDBName = fs.GetParentFolderName(sWorkspaceName)
    sDSName = fs.GetFileName(sWorkspaceName)
    If (modDBUtil.IsSDEDataset(sDBName, sDSName)) Then
      GetWorkspaceCategory = "SDE FEATURE DATASET"
    Else
      GetWorkspaceCategory = "SDE CONNECTION"
    End If
  Else
    GetWorkspaceCategory = ""
  End If

End Function

' This returns a default location where output should be written. It attempts to use the GxDialog's
' last browse location but that may be invalid for the data type being written (specified by sType
' argument). For example, a TIN can't go into an Access. When a conflict is discovered this routine
' will move up through parent containers/folders to find a valid spot. If all else fails it will end
' up at 'Catalog', the top most position possible.
Public Function GetDefaultOutWorkspaceName(Optional sType As String) As String
  GetDefaultOutWorkspaceName = modDBUtil.GetLastBrowseLocation
  
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  
  Select Case UCase(sType) ' note if no sType is passed, or it's not in this Select Case statment, the
    Case "TIN"             ' result will be the last browse location
      Dim bDone As Boolean
      bDone = False
      Do While (Not bDone)
        If (modDBUtil.LocationSupportsTins(GetDefaultOutWorkspaceName)) Then
          bDone = True
        Else
          GetDefaultOutWorkspaceName = fs.GetParentFolderName(GetDefaultOutWorkspaceName)
          If (GetDefaultOutWorkspaceName = "") Then
            GetDefaultOutWorkspaceName = GetWriteableLocation
            bDone = True
          End If
        End If
      Loop
    Case "GRID"
      bDone = False
      Do While (Not bDone)
        If (modDBUtil.LocationSupportsRasters(GetDefaultOutWorkspaceName)) Then
          bDone = True
        Else
          GetDefaultOutWorkspaceName = fs.GetParentFolderName(GetDefaultOutWorkspaceName)
          If (GetDefaultOutWorkspaceName = "") Then
            GetDefaultOutWorkspaceName = GetWriteableLocation
            bDone = True
          End If
        End If
      Loop
    Case "RASTER"
      bDone = False
      Do While (Not bDone)
        If (modDBUtil.LocationSupportsRasters(GetDefaultOutWorkspaceName)) Then
          bDone = True
        Else
          GetDefaultOutWorkspaceName = fs.GetParentFolderName(GetDefaultOutWorkspaceName)
          If (GetDefaultOutWorkspaceName = "") Then
            GetDefaultOutWorkspaceName = GetWriteableLocation
            bDone = True
          End If
        End If
      Loop
    Case "SHAPEFILE", "FILE"
      bDone = False
      Do While (Not bDone)
        If (modDBUtil.LocationSupportsShapefiles(GetDefaultOutWorkspaceName)) Then
          bDone = True
        Else
          GetDefaultOutWorkspaceName = fs.GetParentFolderName(GetDefaultOutWorkspaceName)
          If (GetDefaultOutWorkspaceName = "") Then
            GetDefaultOutWorkspaceName = GetWriteableLocation
            bDone = True
          End If
        End If
      Loop
    Case Else ' assuming features
      bDone = False
      Do While (Not bDone)
        If (Not modDBUtil.IsCoverage(GetDefaultOutWorkspaceName)) Then ' we don't write coverages
          bDone = True
        Else
          GetDefaultOutWorkspaceName = fs.GetParentFolderName(GetDefaultOutWorkspaceName)
          If (GetDefaultOutWorkspaceName = "") Then
            GetDefaultOutWorkspaceName = GetWriteableLocation
            bDone = True
          End If
        End If
      Loop
  End Select
End Function

' Returns the last location of the GxBrowser
Private Function GetLastBrowseLocation() As String
On Error GoTo EH
  Dim wscr
  Set wscr = CreateObject("WScript.Shell")
  Dim sLoc As String
  sLoc = wscr.RegRead("HKEY_CURRENT_USER\Software\ESRI\ArcCatalog\Settings\LastBrowseLocation")
  GetLastBrowseLocation = sLoc
  Exit Function
EH:
  GetLastBrowseLocation = "Catalog"
End Function

Public Function DeleteFile(sDir As String, sName As String) As Boolean
  On Error GoTo EH
  
  Dim pDS As IDataset
  
  ' try shapefile
  Dim pFClass As IFeatureClass
  Set pFClass = modDBUtil.OpenShapeFile(sDir, sName)
  If (Not pFClass Is Nothing) Then
    Set pDS = pFClass
    pDS.Delete
    DeleteFile = True
    Exit Function
  End If
  
  ' try raster
  Dim pRD As IRasterDataset
  Set pRD = modDBUtil.OpenRasterDataset(sDir, sName)
  If (Not pRD Is Nothing) Then
    Set pDS = pRD
    pDS.Delete
    DeleteFile = True
    Exit Function
  End If
  
  ' try tin
  Dim pTin As ITin
  Set pTin = modDBUtil.OpenTin(sDir, sName)
  If (Not pTin Is Nothing) Then
    Set pDS = pTin
    pDS.Delete
    DeleteFile = True
    Exit Function
  End If
  
  ' try ordinary file
'  Dim fs As FileSystemObject
'  Set fs = New FileSystemObject
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  If (fs.FileExists(sDir & "\" & sName)) Then
    fs.DeleteFile (sDir & "\" & sName)
    DeleteFile = True
    Exit Function
  End If
  
  DeleteFile = False
  Exit Function
EH:
  SetError 1, ERR.Description
  DeleteFile = False
End Function