dbutil.bas

FloodEvaluation-程序是gis方面的程序

  Dim shapeWorkspace As IFeatureWorkspace
  Set shapeWorkspace = shapeWorkspaceFactory.Open(connectionProperties, 0)
  If (Not shapeWorkspace Is Nothing) Then
    Dim pFC As IFeatureClass
    Set pFC = OpenShapeFile(sDir, sName)
    
    If Not pFC Is Nothing Then
        Dim pDS As IDataset
        Set pDS = pFC
        pDS.Delete
    End If
    
    Dim pFields As IFields
    Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pSR)
  
    Dim pFClass As IFeatureClass
    Set pFClass = shapeWorkspace.CreateFeatureClass(sName, pFields, Nothing, Nothing, esriFTSimple, "Shape", "")
  
    Set CreateShapefile = pFClass
  End If
  
    Exit Function
CreateShape_ERR:
Debug.Print "CreateShape_ERR: " & ERR.Description
    Resume Next
    
End Function


Public Function FeatureClassHasM(pFC As IFeatureClass) As Boolean
  Dim pFields As IFields
  Set pFields = pFC.Fields
  
  Dim shapeIndex As Long
  shapeIndex = pFields.FindField(pFC.ShapeFieldName)

  Dim pShapeField As IField
  Set pShapeField = pFields.Field(shapeIndex)

  Dim pGeomDef As IGeometryDef
  Set pGeomDef = pShapeField.GeometryDef

  FeatureClassHasM = pGeomDef.hasM
End Function


Public Function FeatureClassHasZ(pFC As IFeatureClass) As Boolean
  Dim pFields As IFields
  Set pFields = pFC.Fields
  
  Dim shapeIndex As Long
  shapeIndex = pFields.FindField(pFC.ShapeFieldName)

  Dim pShapeField As IField
  Set pShapeField = pFields.Field(shapeIndex)

  Dim pGeomDef As IGeometryDef
  Set pGeomDef = pShapeField.GeometryDef

  FeatureClassHasZ = pGeomDef.hasZ
End Function


Public Function OpenShapefileWorkspace(sDir As String) As IWorkspace
  On Error GoTo EH
  Dim pWSFact As IWorkspaceFactory
  Set pWSFact = New ShapefileWorkspaceFactory
  Dim connectionProperties As IPropertySet
  Set connectionProperties = New PropertySet
  connectionProperties.SetProperty "DATABASE", sDir
  Set OpenShapefileWorkspace = pWSFact.Open(connectionProperties, 0)
EH:
End Function

Public Function OpenShapeFile(dir As String, name As String) As IFeatureClass
On Error GoTo errHandler
  Dim pWSFact As IWorkspaceFactory
  Dim connectionProperties As IPropertySet
  Dim pShapeWS As IFeatureWorkspace
  Dim isShapeWS As Boolean

  Set OpenShapeFile = Nothing
  
  Set pWSFact = New ShapefileWorkspaceFactory
  isShapeWS = pWSFact.IsWorkspace(dir)
  If (isShapeWS) Then
    On Error GoTo errHandler
    Set connectionProperties = New PropertySet
    connectionProperties.SetProperty "DATABASE", dir
    Set pShapeWS = pWSFact.Open(connectionProperties, 0)
    Dim pFClass As IFeatureClass
    Set pFClass = pShapeWS.OpenFeatureClass(name)
    Set OpenShapeFile = pFClass
  End If
  Exit Function
errHandler:
  MsgBox "failed to open shapefile"
End Function

' sFCType can be POINT, ARC, POLYGON, ..and/or others depending on coverage
Public Function OpenCoverage(sDir As String, sName As String, sFCType As String) As IFeatureClass
  Dim pWSFact As IWorkspaceFactory
  Dim connectionProperties As IPropertySet
  Dim pArcWS As IFeatureWorkspace
  Dim isArcWS As Boolean
  
  Set pWSFact = New ArcInfoWorkspaceFactory
  isArcWS = pWSFact.IsWorkspace(sDir)
  If (isArcWS) Then
    On Error GoTo errHandler
    Set connectionProperties = New PropertySet
    connectionProperties.SetProperty "DATABASE", sDir
    Set pArcWS = pWSFact.Open(connectionProperties, 0)

    Dim pFD As IFeatureDataset
    Set pFD = pArcWS.OpenFeatureDataset(sName)
    
    Dim pFCContainer As IFeatureClassContainer
    Set pFCContainer = pFD
        
    Dim pFClass As IFeatureClass
    Set pFClass = pFCContainer.ClassByName(sFCType)
    Set OpenCoverage = pFClass
  End If
errHandler:
End Function

Public Function CreateAccessDatabase( _
  sDir As String, _
  sDBName As String, _
  bOverwrite As Boolean) As IWorkspace
  
  If (bOverwrite) Then
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists(sDir + "\" + sDBName + ".mdb")) Then
      Kill sDir + "\" + sDBName + ".mdb"
    End If
  End If
  
  Dim pWSF As IWorkspaceFactory
  Set pWSF = New AccessWorkspaceFactory
  
  Dim pPropSet As IPropertySet
  Set pPropSet = New PropertySet
  
  Dim pWsName As IWorkspaceName
  Set pWsName = pWSF.Create(sDir, sDBName, pPropSet, 0)

  Dim pName As IName
  Set pName = pWsName
  Dim pWS As IWorkspace
  Set pWS = pName.Open
  
  Set CreateAccessDatabase = pWS
End Function

' Create a feature class that resides in a feature dataset (shapefile not supported)
Public Function CreateFeatureClassDS( _
  pFDS As IFeatureDataset, _
  sFCName As String, _
  shapeType As esriGeometryType, _
  hasM As Boolean, _
  hasZ As Boolean) As IFeatureClass
    
  Dim pGDS As IGeoDataset
  Set pGDS = pFDS
  
  Dim pSR As ISpatialReference
  Set pSR = pGDS.SpatialReference
  
  Dim pFields As IFields
  Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pSR)
  
  Dim m_pCLSID As UID
  Set m_pCLSID = New UID
  m_pCLSID.Value = "esricore.Feature"
    
  Dim pFC As IFeatureClass
  Set pFC = pFDS.CreateFeatureClass(sFCName, pFields, m_pCLSID, Nothing, esriFTSimple, "Shape", "")
  
  Set CreateFeatureClassDS = pFC
End Function

' Create a stand alone feature class (not inside dataset)
Public Function CreateFeatureClassWS( _
  pFWS As IFeatureWorkspace, _
  sFCName As String, _
  shapeType As esriGeometryType, _
  hasM As Boolean, _
  hasZ As Boolean, _
  pSR As ISpatialReference) As IFeatureClass
    
  Dim pFields As IFields
  Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pSR)
  
  Dim m_pCLSID As UID
  Set m_pCLSID = New UID
  m_pCLSID.Value = "esricore.Feature"
    
  Dim pFC As IFeatureClass
  Set pFC = pFWS.CreateFeatureClass(sFCName, pFields, m_pCLSID, Nothing, esriFTSimple, "Shape", "")
  
  Set CreateFeatureClassWS = pFC
End Function

Public Function IsAccessDataset(sDBName As String, sDSName As String) As Boolean
  On Error GoTo EH
  Dim pWSFact As IWorkspaceFactory
  Set pWSFact = New AccessWorkspaceFactory
  
  Dim connectionProperties As IPropertySet
  Set connectionProperties = New PropertySet
  connectionProperties.SetProperty "DATABASE", sDBName
  
  Dim pAccessWS As IFeatureWorkspace
  Set pAccessWS = pWSFact.Open(connectionProperties, 0)
  
  Dim pDS As IFeatureDataset
  Set pDS = pAccessWS.OpenFeatureDataset(sDSName)
  IsAccessDataset = (Not pDS Is Nothing)
  Exit Function
EH:
  IsAccessDataset = False
End Function

Public Function IsSDEDataset(sDBName As String, sDSName As String) As Boolean
  On Error GoTo EH
  Dim pWS As IFeatureWorkspace
  Set pWS = OpenSDEWorkspaceWithConnection(sDBName)
  Dim pDS As IFeatureDataset
  Set pDS = pWS.OpenFeatureDataset(sDSName)
  IsSDEDataset = (Not pDS Is Nothing)
  Exit Function
EH:
  IsSDEDataset = False
End Function


Public Function OpenAccessDatabase(sDBName As String) As IFeatureWorkspace
  Dim pWSFact As IWorkspaceFactory
  Set pWSFact = New AccessWorkspaceFactory
  
  Dim connectionProperties As IPropertySet
  Set connectionProperties = New PropertySet
  connectionProperties.SetProperty "DATABASE", sDBName
  
  Dim pAccessWS As IFeatureWorkspace
  Set pAccessWS = pWSFact.Open(connectionProperties, 0)
  
  Set OpenAccessDatabase = pAccessWS
End Function

Public Function OpenAccessFeatureClass(sDBName As String, _
                                        sFCName As String) As IFeatureClass
  
  Dim pFWS As IFeatureWorkspace
  Set pFWS = OpenAccessDatabase(sDBName)
    
  Set OpenAccessFeatureClass = pFWS.OpenFeatureClass(sFCName)
End Function

' location of folder containing sde connection files
Public Function GetConnectionsFolder() As String
  On Error GoTo EH
  Dim pGxCat As IGxCatalog
  Set pGxCat = New GxCatalog
  Dim pFolder As IGxRemoteDatabaseFolder
  Dim i As Long
  Set pFolder = pGxCat.GetObjectFromFullName("Database Connections", i)
  GetConnectionsFolder = pFolder.Path
  Exit Function
EH:
End Function

Public Function HasZUnitsDefined(pInGDS As IGeoDataset, pOutLU As ILinearUnit) As Boolean
  Dim pSR As ISpatialReference
  Set pSR = pInGDS.SpatialReference
  Set pOutLU = pSR.ZCoordinateUnit
  HasZUnitsDefined = (Not pOutLU Is Nothing)
End Function

'Public Function OpenRasterDataset(sDir As String, sName As String) As IRasterDataset
'  On Error GoTo EH
'  Dim pRW As IRasterWorkspace
'  Set pRW = OpenRasterWorkspace(sDir)
'  Set OpenRasterDataset = pRW.OpenRasterDataset(sName)
'EH:
'End Function

Public Function OpenRasterDataset(sPath As String, sFileName As String) As IRasterDataset
   ' Returns RasterDataset object given a file name and its directory
    ' sPath: directory where dataset resides
    ' sFileName: name of the raster dataset
    On Error GoTo ErrorHandler
    
    ' Create RasterWorkSpaceFactory
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New RasterWorkspaceFactory
    
    ' Get RasterWorkspace
    Dim pRasWS As IRasterWorkspace
    If pWSF.IsWorkspace(sPath) Then
        Set pRasWS = pWSF.OpenFromFile(sPath, 0)
        Set OpenRasterDataset = pRasWS.OpenRasterDataset(sFileName)
    End If
    
    ' Release memeory
    Set pRasWS = Nothing
    Set pWSF = Nothing
    Exit Function
    
ErrorHandler:
    Set OpenRasterDataset = Nothing
  MsgBox "Failed in Opening RasterDataset. " & ERR.Description
End Function

Public Function OpenRasterWorkspace(sDir As String) As IRasterWorkspace
  On Error GoTo EH
  Dim pWF As IWorkspaceFactory
  Set pWF = New RasterWorkspaceFactory
  Set OpenRasterWorkspace = pWF.OpenFromFile(sDir, 0)
EH:
End Function

' sConnect points to connection file. Syntax as ArcCatalog (e.g. 'Database Connections\Connection to Luke.sde')
Public Function OpenSDEWorkspaceWithConnection(sConnect As String) As IWorkspace
  On Error GoTo EH
  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 OpenSDEWorkspaceWithConnection = pDB.Workspace
EH:
End Function

Public Function OpenSDEWorkspace(Server As String, _
                    Instance As String, _
                    username As String, _
                    Password As String) As IFeatureWorkspace
                    
  Dim pWSF As IWorkspaceFactory
  Set pWSF = New SdeWorkspaceFactory
  
  Dim pPropSet As IPropertySet
  Set pPropSet = New PropertySet
  With pPropSet
    .SetProperty "Server", Server
    .SetProperty "Instance", Instance
    .SetProperty "User", username
    .SetProperty "Password", Password
  End With

  'pWSF.PrepareConnectionProperties = pPropSet

  Dim pWS As IWorkspace
  Set pWS = pWSF.Open(pPropSet, 0)

  Set OpenSDEWorkspace = pWS
End Function


' Use this routine when adding only a few features. See commented
' code inside for more efficient method when adding a large number of
' features.
Public Sub AddShapeToFeatureClass(pGeom As IGeometry, pFC As IFeatureClass)
  Dim pFeature As IFeature
  Set pFeature = pFC.CreateFeature
  Set pFeature.Shape = pGeom
  pFeature.Store

' Here's better method to use if you're adding a bunch of features.
' Create a buffered cursor and add features using it in a loop.
'
' Create cursor and buffer...
'  Dim pCursor As IFeatureCursor
'  Set pCursor = pFC.Insert(True)
'
'  Dim pBuffer As IFeatureBuffer
'  Set pBuffer = pFC.CreateFeatureBuffer
'
' Then use them in a loop...
'  pBuffer.Shape = pGeom
'  pCursor.InsertFeature pBuffer
'
End Sub

Public Function OpenTin(sDir As String, sName As String) As ITin
  Dim pWSFact As IWorkspaceFactory
  Dim pTinWS As ITinWorkspace
  Dim pTin As ITin

  Set pWSFact = New TinWorkspaceFactory
  If (pWSFact.IsWorkspace(sDir)) Then
    Set pTinWS = pWSFact.OpenFromFile(sDir, 0)
    If (pTinWS.IsTin(sName)) Then
      Set pTin = pTinWS.OpenTin(sName)
    End If
  End If
  Set OpenTin = pTin

  ' this is easier - but requires 3D Analyst license (previous method supported in core)
'  Dim pTinAdv As ITinAdvanced
'  Set pTinAdv = New Tin
'  pTinAdv.Init sDir & "\" & sName
'  Set OpenTin = pTinAdv
End Function

'
' returns the directory that the file in the path resides in
' ie . returns "Temp.dbf" from "C:\Program Files\BeijiangTemp\table.dbf"
Private Function priv_FileName(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 priv_FileName_ERR

  sFilePath = priv_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
          priv_FileName = Mid(sName, 1, Len(sName) - 4)
        Else
          priv_FileName = ""
        End If