dbutil.bas

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

  MsgBox "Failed in Opening RasterDataset. " & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
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
      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