dbutil.bas

来自「FloodEvaluation-程序是gis方面的程序」· BAS 代码 · 共 2,009 行 · 第 1/5 页

On Error GoTo EH
    Dim pFieldEdit As IFieldEdit
    Dim pField As IField
    Set pFieldEdit = New esriCore.Field
    With pFieldEdit
        .name = sFieldName
        .IsNullable = isN
        .Type = fieldType
        .Length = fieldLength
        If fieldPrecision > 0 Then .Precision = fieldPrecision
        If fieldScale > 0 Then .Scale = fieldScale
    End With
    Set pField = pFieldEdit
    pFeatureCls.AddField pField
    Exit Sub
EH:
    MsgBox "moddbutil.AddField: " & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub

'Public Function CreateAccessFCFromScratch( _
'    sDir As String, _
'    sDBName As String, _
'    sDSName As String, _
'    sFCName As String, _
'    shapeType As esriGeometryType, _
'    hasM As Boolean, _
'    hasZ As Boolean, _
'    pDomain As IEnvelope, _
'    bOverwrite As Boolean) As IFeatureClass
'
'  Dim pWS As IWorkspace
'  Set pWS = CreateAccessDatabase(sDir, sDBName, bOverwrite)
'
'  Dim pFD As IFeatureDataset
'  Set pFD = CreateAccessDataset(pWS, sDSName, hasM, hasZ, pDomain)
'
'  Dim pFC As IFeatureClass
'  Set pFC = CreateAccessFeatureClass(pFD, sFCName, shapeType, hasM, hasZ, pDomain)
'
'  Set CreateAccessFCFromScratch = pFC
'
'End Function
Public Function CreateAccessFeatureClass( _
  pFDS As IFeatureDataset, _
  sFCName As String, _
  shapeType As esriGeometryType, _
  hasM As Boolean, _
  hasZ As Boolean, _
  pDomain As IEnvelope) As IFeatureClass
    
  Dim pFields As IFields
  Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pDomain)
  
  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 CreateAccessFeatureClass = pFC
End Function






Public Sub DeleteFeatureClass(pFClass As IFeatureClass)
  Dim pDataset As IDataset
  Set pDataset = pFClass
  pDataset.Delete
End Sub

Public Function CreateShapefile(sDir As String, sName As String, shapeType As esriGeometryType, _
  hasM As Boolean, hasZ As Boolean, pSR As ISpatialReference) As IFeatureClass
  
On Error GoTo CreateShape_ERR

  Set CreateShapefile = Nothing
  
  Dim shapeWorkspaceFactory As IWorkspaceFactory
  Set shapeWorkspaceFactory = New ShapefileWorkspaceFactory
  
  Dim connectionProperties As IPropertySet
  Set connectionProperties = New PropertySet
  connectionProperties.SetProperty "DATABASE", sDir
  
  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", vbInformation + vbOKOnly, "提示信息"
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