dbutil.bas

FloodEvaluation-程序是gis方面的程序

' Take an input string that represents a new file/dataset (not in Access or SDE). Make sure there isn't
' already a file with the same name. If so, ask to delete. Parse the path into directory and base name
' string variables.
Public Function CanCreateFile(sInString As String, sType As String, sOutDir As String, sOutName As String, bQueryOverwrite As Boolean) As Boolean
  Dim fs, f, s
  Set fs = CreateObject("Scripting.FileSystemObject")
  sOutDir = fs.GetParentFolderName(sInString)
  sOutName = fs.GetFileName(sInString)
  
  If (sOutDir = "") Then
    sOutDir = modDBUtil.GetDefaultOutWorkspaceName(sType)
  End If
 
  If ((fs.FolderExists(sOutDir & "\" & sOutName)) Or _
      (fs.FileExists(sOutDir & "\" & sOutName))) Then
    If (bQueryOverwrite) Then
      Dim res As VbMsgBoxResult
      res = MsgBox("Specified output exists. Overwrite?", vbYesNo, "Object Exists")
      If (res = vbYes) Then
        CanCreateFile = DeleteFile(sOutDir, sOutName)
        Exit Function
      Else
        SetError 2, "Specified output already exists."
        CanCreateFile = False
        Exit Function
      End If
    Else
      SetError 1, "Specified output already exists."
      CanCreateFile = False
      Exit Function
    End If
  End If
 
  If (fs.FolderExists(sOutDir)) Then
    CanCreateFile = True
  Else
    SetError 1, "Specified output directory not found."
    CanCreateFile = False
  End If
End Function
Public Function ResolveOutputFileName(sInString As String, sOutDir As String, sOutName As String) As Boolean
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  ResolveOutputFileName = CanCreateFile(sInString, "FILE", sOutDir, sOutName, True)
End Function


Public Function ResolveOutputRasterName(sInString As String, sOutDir As String, sOutName As String, bWriteTemp As Boolean) As Boolean
  If (modDBUtil.IsTempRasterName(sInString)) Then
    bWriteTemp = True
    ResolveOutputRasterName = True
    Exit Function
  Else
    bWriteTemp = False
  End If
  
  ' grids names can't exceed 13 characters (INFO limitation) and their paths can't contain spaces
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  Dim sName As String
  sName = fs.GetFileName(sInString)
  If (Len(sName) > 13) Then
    SetError 1, "The output grid name (excluding path) can't exceed 13 characters"
    ResolveOutputRasterName = False
    Exit Function
  End If
  If (InStr(sInString, " ") > 0) Then
    SetError 1, "The output grid name (including path) can't contain space characters"
    ResolveOutputRasterName = False
    Exit Function
  End If
  
  ResolveOutputRasterName = CanCreateFile(sInString, "Raster", sOutDir, sOutName, True)
End Function

' This function was created in case we change the way scratch rasters are specified in analysis
' dialogs. All dialogs that output rasters can call this (directly or via ResolveoutputRasterName)
' to determine if the output is temporary or permanent.
Private Function IsTempRasterName(sName As String) As Boolean
  IsTempRasterName = (InStr(UCase(sName), "<TEMPORARY") > 0) ' all variations to date have at least started
End Function
Public Function ResolveOutputShapefileName(sInString As String, sOutDir As String, sOutName As String) As Boolean
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  Dim sExt As String
  sExt = fs.GetExtensionName(sInString)
  If (sExt = "") Then
    sInString = sInString & ".shp" ' make sure extension is present so when looking for existing shapefile
  End If                           ' using file system tools it will be found
  ResolveOutputShapefileName = CanCreateFile(sInString, "Shapefile", sOutDir, sOutName, True)
End Function

Public Function ResolveOutputTinName(sInString As String, sOutDir As String, sOutName As String) As Boolean
  ResolveOutputTinName = CanCreateFile(sInString, "Tin", sOutDir, sOutName, True)
End Function


Public Function ResolveOutputFeatureClassName(sInString As String, sOutCat As String, sOutWSName As String, sOutDSName As String, sOutFCName As String, bQueryOverwrite As Boolean) As Boolean
  Dim bResOK As Boolean
  ResolveOutputFeatureClassName = False
  sOutCat = GetWorkspaceCategory(sInString)
  Select Case sOutCat
  Case "FOLDER"
    bResOK = ResolveOutputShapefileName(sInString, sOutWSName, sOutFCName)
  Case "PERSONAL GEODATABASE FEATURE DATASET"
'    Dim fs As FileSystemObject
'    Set fs = New FileSystemObject
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
    Dim sTemp As String
    sTemp = fs.GetParentFolderName(sInString)
    sOutWSName = fs.GetParentFolderName(sTemp)
    sOutDSName = fs.GetFileName(sTemp)
    sOutFCName = fs.GetFileName(sInString)
    Dim pWS As IFeatureWorkspace
    Set pWS = modDBUtil.OpenAccessDatabase(sOutWSName)
    bResOK = CanCreateGDBFeatureClass(pWS, sOutFCName, True)
  Case "PERSONAL GEODATABASE" ' stand alone feature class, no dataset
'    Set fs = New FileSystemObject
'  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
    sOutWSName = fs.GetParentFolderName(sInString)
    sOutFCName = fs.GetFileName(sInString)
    Set pWS = modDBUtil.OpenAccessDatabase(sOutWSName)
    bResOK = CanCreateGDBFeatureClass(pWS, sOutFCName, True)
  Case "SDE FEATURE DATASET"
'    Set fs = New FileSystemObject
  Set fs = CreateObject("Scripting.FileSystemObject")
    sTemp = fs.GetParentFolderName(sInString)
    sOutWSName = fs.GetParentFolderName(sTemp)
    sOutDSName = fs.GetFileName(sTemp)
    sOutFCName = fs.GetFileName(sInString)
    Set pWS = modDBUtil.OpenSDEWorkspaceWithConnection(sOutWSName)
    bResOK = CanCreateGDBFeatureClass(pWS, sOutFCName, True)
  Case "SDE CONNECTION" ' stand alone feature class, no dataset
'    Set fs = New FileSystemObject
  Set fs = CreateObject("Scripting.FileSystemObject")
    sOutWSName = fs.GetParentFolderName(sInString)
    sOutFCName = fs.GetFileName(sInString)
    Set pWS = modDBUtil.OpenSDEWorkspaceWithConnection(sOutWSName)
    bResOK = CanCreateGDBFeatureClass(pWS, sOutFCName, True)
  Case Else
    SetError 1, "Unsupported output feature category"
    ResolveOutputFeatureClassName = False
    Exit Function
  End Select
  
  If (bResOK) Then
    ResolveOutputFeatureClassName = True
  Else
    If (GetErrorCode = 1) Then
      MsgBox GetErrorMessage, vbExclamation, "Contour"
    End If
    ResolveOutputFeatureClassName = False
  End If
End Function

' sSuffix should include '.'
Public Function GetUniqueFileName(sDir As String, Optional sPrefix As String = "ai", Optional sSuffix As String = "") As String
'  Dim fs As FileSystemObject
'  Set fs = New FileSystemObject
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  Dim i As Long
  Dim done As Boolean
  Dim name As String
  done = False
  i = 1
  ' work whether or not input dir has "\" on end - like raster analysis workspace will
  Dim sDirNew As String
  sDirNew = sDir
  If (Right(sDir, 1) = "\") Then
    sDirNew = Left(sDir, Len(sDir) - 1)
  End If
  Do While Not done
    name = sPrefix & Format(i) & sSuffix
    If ((Not fs.FolderExists(sDirNew + "\" + name)) And _
        (Not fs.FileExists(sDirNew + "\" + name))) Then
      GetUniqueFileName = name
      Exit Function
    End If
    i = i + 1
  Loop
End Function

' Create minimal required fields for featureclass
Public Function CreateBasicFields(shapeType As esriGeometryType, hasM As Boolean, hasZ As Boolean, _
    pSpaRef As ISpatialReference) As IFields
  
  On Error GoTo CreateBasicFields_ERR
  
  Dim pFlds As IFields
  Dim pFldsEdt As IFieldsEdit
  Set pFlds = New esriCore.Fields
  Set pFldsEdt = pFlds
  
  Dim pFld As IField
  Dim pFldEdt As IFieldEdit
  Set pFld = New esriCore.Field
  Set pFldEdt = pFld
    
  Dim pGeoDef As IGeometryDefEdit
  Set pGeoDef = New GeometryDef

  With pGeoDef
    .GeometryType = shapeType
    .hasM = hasM
    .hasZ = hasZ
    Set .SpatialReference = pSpaRef
  End With

  ' add oid field (access and sde) - must come before geometry field
  Set pFldEdt = New esriCore.Field
  With pFldEdt
    .name = "OID"
    .Type = esriFieldTypeOID
  End With
  pFldsEdt.AddField pFldEdt
  
  'add Geometry field
  Set pFldEdt = New esriCore.Field
  With pFldEdt
    .name = "Shape"
    .IsNullable = True
    .Type = esriFieldTypeGeometry
    Set .GeometryDef = pGeoDef
  End With
  pFldsEdt.AddField pFldEdt
  
  Set CreateBasicFields = pFldsEdt
  Exit Function
CreateBasicFields_ERR:
  Debug.Print "CreateBasicFields_ERR: " & ERR.Description
  Debug.Assert 0
  
End Function
Public Function CreateRasterDS(ByVal sDir As String, ByVal sName As String, sType As String, pOrigin As IPoint, nCols As Long, nRows As Long, nCellX As Double, nCellY As Double, eRSTPixelType As rstPixelType, Optional pSR As ISpatialReference, Optional nNumBands = 1, Optional bIsPermanent As Boolean = True) As IRasterDataset
  
  On Error GoTo CreateRasterDS_ERR
  
  ' Create RasterWorkspace
  Dim pRWS As IRasterWorkspace2
  Dim pWSF As IWorkspaceFactory
  Set pWSF = New RasterWorkspaceFactory
  Dim sParentDir As String
  Dim sSubDir As String
  
  If Right(sDir, 1) = "\" Then sDir = Mid(sDir, 1, Len(sDir) - 1)
  
  sParentDir = priv_FileDir(sDir)
  sSubDir = priv_FileName(sDir)
  Dim pPropSet As IPropertySet
  Dim pWsName As IWorkspaceName
  Dim pName As IName
  If Right(sParentDir, 1) <> "\" Then sParentDir = sParentDir & "\"
  Set pName = pWSF.Create(sParentDir, sSubDir, pPropSet, 0)
  Set pRWS = pName.Open()
  Dim pRDS As IRasterDataset
  
  Dim pSRef As ISpatialReference
  If Not pSR Is Nothing Then
    Set pSRef = pSR
  Else
    Set pSRef = New UnknownCoordinateSystem
  End If
  
  Dim pDelRDS As IDataset
  Set pDelRDS = pRWS.OpenRasterDataset(sName)
  If Not pDelRDS Is Nothing Then pDelRDS.Delete
  
  Set pRDS = pRWS.CreateRasterDataset(sName, sType, pOrigin, nCols, nRows, nCellX, nCellY, nNumBands, eRSTPixelType, pSRef, bIsPermanent)
  Set CreateRasterDS = pRDS
  
  Exit Function
  
CreateRasterDS_ERR:
  'Debug.Print Err.Description
  Resume Next
  

End Function
Public Function CreateSDEFeatureClass(pFD As IFeatureDataset, _
  name As String, _
  shapeType As esriGeometryType, _
  pDomain As IEnvelope)
  
  On Error GoTo CreateSDEFeatureClass_ERR
  
  Dim m_pCLSID As UID
  Set m_pCLSID = New UID
  m_pCLSID.Value = "esricore.Feature"
  
  Dim pFields As IFields
  Set pFields = CreateBasicFields(shapeType, False, True, pDomain)
  
  Dim pFC As IFeatureClass
  Set pFC = pFD.CreateFeatureClass(name, pFields, m_pCLSID, Nothing, esriFTSimple, "Shape", "")
  
  Set CreateSDEFeatureClass = pFC

  Exit Function
CreateSDEFeatureClass_ERR:
  Debug.Print "CreateSDEFeatureClass_ERR: " & ERR.Description
  Debug.Assert 0
  
End Function

' Copy fields from one featureclass to another. The OutStartFieldIndex is set by this routine and represents
' the index position (base 0) of the first copied field in the output featureclass.
' CopiedFieldIndexes is set in this routine and stores the index position of each copied field from the
' input featureclass. This information should assist the caller if it is subsequently going to copy over the
' attribute values.
Public Sub CopyFeatureClassFields(pInFC As IFeatureClass, pOutFC As IFeatureClass, lOutStartFieldIndex As Long, pCopiedFieldIndexes As ILongArray)

  On Error GoTo CopyFeatureClassFields_ERR
  
  Dim pInFields As IFields
  Set pInFields = pInFC.Fields
  
  Dim pOutFields As IFields
  Set pOutFields = pOutFC.Fields
  lOutStartFieldIndex = pOutFields.FieldCount
  
  Set pCopiedFieldIndexes = New LongArray
  
  ' We can't copy over a field with the same name as one already existing and we can't copy over
  ' the OID and geometry fields. Everything else should go.
  Dim i As Long
  For i = 0 To (pInFields.FieldCount - 1)
    Dim s As String
    s = pInFields.Field(i).name
    If (Not pOutFields.FindField(s) >= 0) Then
      If ((pInFields.Field(i).Type <> esriFieldTypeGeometry) And _
          (pInFields.Field(i).Type <> esriFieldTypeOID)) Then
        Dim pClone As IClone
        Set pClone = pInFields.Field(i)
        Dim pOutField As IFieldEdit
        Set pOutField = pClone.Clone
        pOutFC.AddField pOutField
        pCopiedFieldIndexes.Add i
      End If
    End If
  Next i
  
  Exit Sub
CopyFeatureClassFields_ERR:
  Debug.Print "CopyFeatureClassFields_ERR: " & ERR.Description
  Debug.Assert 0
End Sub

Public Sub AddField(pFeatureCls As IFeatureClass, _
                        sFieldName As String, _
                        isN As Boolean, _
                        fieldType As esriFieldType, _
                        fieldLength As Integer, _
                        Optional fieldPrecision As Integer, _
                        Optional fieldScale As Integer)
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: " & ERR.Description
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