dbutil.bas

FloodEvaluation-程序是gis方面的程序

      Else
          priv_FileName = sName
      End If
    Else
    ' no extension- filename is only 3 characters:
      priv_FileName = sName
    End If
  Else
    priv_FileName = sName
  End If
  
  
  Exit Function
    
    
priv_FileName_ERR:
  Debug.Assert 0
  Debug.Print "priv_FileName_ERR: " & ERR.Description

End Function

'
'   if there are quotes or double quotes around the passed in expression,
'   this function returns the expression without them.........
'
Private Function priv_RemoveQuotes(ByVal sTempExp) As String

  On Error GoTo RemoveQuotes_ERR
  sTempExp = Trim(sTempExp)
  priv_RemoveQuotes = sTempExp
  If sTempExp <> Chr(34) And sTempExp <> Chr(39) Then
    If (Left(Trim(sTempExp), 1) = Chr(34) Or Left(Trim(sTempExp), 1) = Chr(39)) _
    Or (Right(Trim(sTempExp), 1) = Chr(34) Or Right(Trim(sTempExp), 1) = Chr(39)) Then
        
      If Left(Trim(sTempExp), 1) = Chr(34) Or Left(Trim(sTempExp), 1) = Chr(39) Then
        sTempExp = Mid(sTempExp, 2)
      End If
      
      If Right(Trim(sTempExp), 1) = Chr(34) Or Right(Trim(sTempExp), 1) = Chr(39) Then
        sTempExp = Mid(sTempExp, 1, Len(sTempExp) - 1)
      End If
      
      priv_RemoveQuotes = sTempExp
    Else
      priv_RemoveQuotes = sTempExp
    End If
  Else
    priv_RemoveQuotes = ""
  End If

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


End Function
' Called when something needs to find a place to write data
Public Function GetWriteableLocation() As String
  Dim sVal As String
  sVal = Environ("TEMP")
  If (sVal = "") Then
    sVal = Environ("TMP")
    If (sVal = "") Then
      sVal = "c:"
    End If
  End If
  GetWriteableLocation = sVal
End Function


Public Function Is3DFeatureClass(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
  
  Is3DFeatureClass = pGeomDef.hasZ
End Function

' Given a valid geodatabase feature workspace, see if feature class of specified name can be created.
' This will ask the use if it's ok to overwrite and performs the deletion. The function should not
' be called for shapefiles as other types of data (textfiles, rasters) with the same name may be present
' and this won't detect them.
Public Function CanCreateGDBFeatureClass(pWS As IFeatureWorkspace, sName As String, bQueryOverwrite As Boolean) As Boolean
  On Error GoTo EH
  Dim sState As String
  Dim pFC As IFeatureClass
  sState = "OPEN"
  Set pFC = pWS.OpenFeatureClass(sName) ' this may throw error if fclass doesn't exist
  sState = "NULL"
  If (Not pFC Is Nothing) Then
    If (bQueryOverwrite) Then
      Dim res As VbMsgBoxResult
      res = MsgBox("Specified output exists. Overwrite?", vbYesNo, "Object Exists")
      If (res = vbYes) Then
        Dim pDS As IDataset
        Set pDS = pFC
        pDS.Delete
        CanCreateGDBFeatureClass = True
        Exit Function
      Else
        SetError 2, "Specified output already exists."
        CanCreateGDBFeatureClass = False
        Exit Function
      End If
    Else
      SetError 1, "Specified output already exists."
      CanCreateGDBFeatureClass = False
      Exit Function
    End If
  End If
  CanCreateGDBFeatureClass = True
  Exit Function
EH:
  If (sState = "OPEN") Then
    CanCreateGDBFeatureClass = True
    Exit Function
  Else
    SetError 1, ERR.Description
    CanCreateGDBFeatureClass = False
  End If
End Function

Public Function CreateOutFClass(sOutCat As String, _
                                sOutWSName As String, _
                                sOutDSName As String, _
                                sOutFCName As String, _
                                eGeomType As esriGeometryType, _
                                bHasM As Boolean, _
                                bHasZ As Boolean, _
                                pSR As ISpatialReference) As IFeatureClass
                                
  Select Case UCase(sOutCat)
  Case "FOLDER"
    Set CreateOutFClass = modDBUtil.CreateShapefile(sOutWSName, sOutFCName, eGeomType, bHasM, bHasZ, pSR)
  Case "PERSONAL GEODATABASE FEATURE DATASET"
    Dim pWS As IFeatureWorkspace
    Set pWS = modDBUtil.OpenAccessDatabase(sOutWSName)
    Dim pDS As IFeatureDataset
    Set pDS = pWS.OpenFeatureDataset(sOutDSName)
    Set CreateOutFClass = modDBUtil.CreateFeatureClassDS(pDS, sOutFCName, eGeomType, bHasM, bHasZ)
  Case "PERSONAL GEODATABASE"
    Set pWS = modDBUtil.OpenAccessDatabase(sOutWSName)
    Set CreateOutFClass = modDBUtil.CreateFeatureClassWS(pWS, sOutFCName, eGeomType, bHasM, bHasZ, pSR)
  Case "SDE FEATURE DATASET"
    Set pWS = modDBUtil.OpenSDEWorkspaceWithConnection(sOutWSName)
    Set pDS = pWS.OpenFeatureDataset(sOutDSName)
    Set CreateOutFClass = modDBUtil.CreateFeatureClassDS(pDS, sOutFCName, eGeomType, bHasM, bHasZ)
  Case "SDE CONNECTION"
    Set pWS = modDBUtil.OpenSDEWorkspaceWithConnection(sOutWSName)
    Set CreateOutFClass = modDBUtil.CreateFeatureClassWS(pWS, sOutFCName, eGeomType, bHasM, bHasZ, pSR)
  End Select
  
End Function

Public Function CreateRasterSurf(sDir As String, sName As String, sFormat As String, _
  pOrigin As IPoint, nCol As Long, nRow As Long, cellsizeX As Double, cellsizeY As Double, _
  ePixelType As rstPixelType, pSR As ISpatialReference2, bPerm As Boolean) As IRasterDataset
  
  Dim rWksFac As IWorkspaceFactory
  Set rWksFac = New RasterWorkspaceFactory
      
  Dim wks As IWorkspace
  Set wks = rWksFac.OpenFromFile(sDir, 0)
  
  Dim rWks As IRasterWorkspace2
  Set rWks = wks
      
  Dim numbands As Long
  numbands = 1
      
  Dim pRDS As IRasterDataset
  Set pRDS = rWks.CreateRasterDataset(sName, sFormat, pOrigin, nCol, nRow, cellsizeX, cellsizeY, numbands, ePixelType, pSR, bPerm)
    
  Set CreateRasterSurf = pRDS
End Function

Public Function GetRawPixels(pRDS As IRasterDataset, band As Long) As IRawPixels
  Dim pBandCollection As IRasterBandCollection
  Set pBandCollection = pRDS
  
  Dim pRasterBand As iRasterBand
  Set pRasterBand = pBandCollection.Item(band)
  
  Set GetRawPixels = pRasterBand
End Function

' Supported pixel types limited to float and long because output currently limited to native ESRI Grid
Public Function TinToRaster(pTin As ITinAdvanced, eRastConvType As esriRasterizationType, _
  sDir As String, sName As String, ePixelType As rstPixelType, cellsize As Double, pExtent As IEnvelope, _
  bPerm As Boolean) As IRasterDataset
      
  ' The origin used by CreateRasterDataset is the lower left cell corner.
  ' The extent passed is that of the TIN's.
  ' Define the raster origin and number of rows and columns so that the raster
  ' is of sufficient extent to capture all the TIN's data area.
  Dim pOrigin As IPoint
  Set pOrigin = pExtent.LowerLeft
  pOrigin.X = pOrigin.X - (cellsize * 0.5)
  pOrigin.Y = pOrigin.Y - (cellsize * 0.5)
  
  Dim nCol As Long, nRow As Long
  nCol = Round(pExtent.Width / cellsize) + 1
  nRow = Round(pExtent.Height / cellsize) + 1
  
  Dim pGDS As IGeoDataset
  Set pGDS = pTin
  Dim pSR As ISpatialReference2
  Set pSR = pGDS.SpatialReference
  
  Dim pRDS As IRasterDataset
  Set pRDS = CreateRasterSurf(sDir, sName, "GRID", pOrigin, nCol, nRow, cellsize, cellsize, ePixelType, pSR, bPerm)
    
  Dim pRawPixels As IRawPixels
  Set pRawPixels = GetRawPixels(pRDS, 0)
      
  ' TODO - this implementation is allocating one block for the entire extent. It may be resource
  ' intensive. A more resource friendly implementation would use a smaller block size and iterate.
  Dim pBlockSize As IPnt
  Set pBlockSize = New DblPnt
  pBlockSize.X = nCol
  pBlockSize.Y = nRow
  
  Dim pPixelBlock As IPixelBlock
  Set pPixelBlock = pRawPixels.CreatePixelBlock(pBlockSize)
    
  Dim val
  val = pPixelBlock.SafeArray(0)
      
  Dim pTinSurf As ITinSurface
  Set pTinSurf = pTin
    
  Dim pRasterProps As IRasterProps
  Set pRasterProps = pRawPixels
  
  Dim nodataFloat As Single
  Dim nodataInt As Long
  
  ' QueryPixelBlock takes an origin representing the upper left cell center.
  ' Calculate that cell center's position here.
  pOrigin.X = pOrigin.X + (cellsize * 0.5)
  pOrigin.Y = pOrigin.Y + (cellsize * nRow) - (cellsize * 0.5)
  
  If (ePixelType = PT_FLOAT) Then
    nodataFloat = pRasterProps.NoDataValue
    pTinSurf.QueryPixelBlock pOrigin.X, pOrigin.Y, cellsize, cellsize, eRastConvType, nodataFloat, val
  Else
    nodataInt = pRasterProps.NoDataValue
    pTinSurf.QueryPixelBlock pOrigin.X, pOrigin.Y, cellsize, cellsize, eRastConvType, nodataInt, val
  End If
  
  If pTin.ProcessCancelled Then GoTo Cancel
            
  Dim pOffset As IPnt
  Set pOffset = New DblPnt
  pOffset.X = 0
  pOffset.Y = 0
  pRawPixels.Write pOffset, pPixelBlock
        
  ' need this for some reason with temporary integer grids
  If (Not bPerm) And (ePixelType = PT_LONG) Then
    Dim pBand As iRasterBand
    Set pBand = pRawPixels
    Dim pStats As IRasterStatistics
    Set pStats = pBand.Statistics
    pStats.Recalculate
  End If
  
  If (bPerm) Then
    ' flush edits to disk by freeing all pointers
    Set pRDS = Nothing
    Set pRawPixels = Nothing
    Set pPixelBlock = Nothing
    Set pRasterProps = Nothing
    Set pRDS = OpenRasterDataset(sDir, sName)
  End If
  
  Set TinToRaster = pRDS
  Exit Function
  
Cancel:
  Set TinToRaster = Nothing
End Function

Public Function GetRasterWorkspace(sWKSName As String) As IRasterWorkspace
  Dim rWksFac As IWorkspaceFactory
  Set rWksFac = New RasterWorkspaceFactory
  Dim rWks As IRasterWorkspace
  Set rWks = rWksFac.OpenFromFile(sWKSName, 0)
  Set GetRasterWorkspace = rWks
End Function

Public Function GetRasterDataset(sDir As String, sName As String) As IRasterDataset
  Dim pRWK As IRasterWorkspace
  Set pRWK = GetRasterWorkspace(sDir)
  Set GetRasterDataset = pRWK.OpenRasterDataset(sName)
End Function

Public Function GetUniqueFeatureClassName(pWS As IFeatureWorkspace, Optional sPrefix) As String
  On Error GoTo EH
  Dim sPreName As String
  If (sPrefix <> "") Then
    sPreName = sPrefix
  Else
    sPreName = "ai"
  End If
  Dim i As Long
  i = 1
  
  ' if shapefile workspace add .shp extension
  Dim pDataset As IDataset
  Set pDataset = pWS
  If (InStr(UCase(pDataset.Category), "SHAPEFILE") > 0) Then
    Dim sExt As String
    sExt = ".shp"
  Else
    sExt = ""
  End If

  Dim done As Boolean
  Do While Not done
    Dim pFC As IFeatureClass
    Dim sName As String
    sName = sPreName & Format(i) & sExt
    Set pFC = pWS.OpenFeatureClass(sName) ' this can raise an error if dataset doesn't exist so error handler should use it
    If (pFC Is Nothing) Then
      done = True
    Else
      i = i + 1
    End If
  Loop
  GetUniqueFeatureClassName = sName
  Exit Function
EH:
  GetUniqueFeatureClassName = sName
End Function

Public Sub SetError(code As Long, sMsg As String)
  m_lErrorCode = code
  m_sErrorMsg = sMsg
End Sub

Public Function GetErrorMessage() As String
  GetErrorMessage = m_sErrorMsg
End Function

' 0 - no error
' 1 - the desired operation did not complete and a message has to be reported by the caller
' 2 - the desired operation did not complete but a message does not need to be reported
Public Function GetErrorCode() As Long
  GetErrorCode = m_lErrorCode
  m_lErrorCode = 0
End Function

Public Function ReadRasterPixelsSafeArray(pRaster As IRaster, Optional iRasterBand = 0, Optional ByRef ppNumCols As Long, Optional ByRef ppNumRows, Optional ppPixelType As rstPixelType, Optional ppCellSizeX As Double, Optional ppCellSizeY As Double)
  On Error GoTo ReadRasterPixels_ERR

  Dim pRBC As IRasterBandCollection
  Dim pRasterBand As iRasterBand
  
  Set pRBC = pRaster
  Set pRasterBand = pRBC.Item(iRasterBand)
  
  Dim pRawPixels As IRawPixels
  Set pRawPixels = pRasterBand
  
  Dim pRProps As IRasterProps
  Set pRProps = pRawPixels
  
  Dim nCol As Double
  Dim nRow As Double
  nCol = pRProps.Width
  nRow = pRProps.Height
  ppNumCols = nCol
  ppNumRows = nRow
  ppPixelType = pRProps.PixelType
  ppCellSizeX = pRProps.MeanCellSize.X
  ppCellSizeY = pRProps.MeanCellSize.Y
  
  Dim pBlockSize As IPnt
  Set pBlockSize = New DblPnt
  
  pBlockSize.X = nCol
  pBlockSize.Y = nRow
    
  Dim pPixelBlock As IPixelBlock
  Set pPixelBlock = pRawPixels.CreatePixelBlock(pBlockSize)
  
  Dim pBlockOrigin As IPnt
  Set pBlockOrigin = New DblPnt
  
  pBlockOrigin.X = 0
  pBlockOrigin.Y = 0
    
  pRawPixels.Read pBlockOrigin, pPixelBlock
  Dim a
  a = pPixelBlock.SafeArray(0)
  ReadRasterPixelsSafeArray = a
  
  Exit Function
ReadRasterPixels_ERR:
  Debug.Assert 0
  Debug.Print "ReadRasterPixels_ERR: " & ERR.Description
  
  
End Function

'
'   returns the path minus the file name:
'   ie. returns "C:\Program Files\BeijiangTemp" from "C:\Program Files\BeijiangTemp\table.dbf"
'
Private Function priv_FileDir(sPath As String) As String

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

End Function