dbutil.bas

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

    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

'
'Public Function ConnectOracle() As adodb.Connection
'       On Error GoTo Er
'       '连接Oracle数据库
'       Dim strCnn As String
'       strCnn = "Provider=MSDAORA.1;User ID=sde;Data Source=sde;Persist Security Info=False"
'       'strCnn = "Provider=MSDAORA.1;User ID=sde;Data Source=mydb;Persist Security Info=False"
'       Set AdoCnn = New adodb.Connection
'       With AdoCnn
'            If .State = adStateConnecting Then
'               .Close
'            End If
'
'            If .ConnectionString <> "" Then
'               Exit Function
'            End If
'
'            .ConnectionString = strCnn
'            .CursorLocation = adUseClient
'            .Open strCnn, "sde", "lan811"
'       End With
'       Set ConnectOracle = AdoCnn
'       Exit Function
'Er:
'    MsgBox "系统错误提示：" & Chr(13) & ERR.Description, vbCritical + vbOKOnly, "警告"
'    ERR.Clear
'End Function


'********************************************************************************************************
''''Database functions
'********************************************************************************************************
Public Function ConnectOracle() As ADODB.Connection
On Error GoTo ER
    '连接Oracle数据库
    Dim strCnn As String
    strCnn = "Provider=MSDAORA.1;User ID=sde;Data Source=sde;Persist Security Info=False"
    'strCnn = "Provider=MSDAORA.1;User ID=sde;Data Source=mydb;Persist Security Info=False"
    Dim adoCnn As ADODB.Connection
    Set adoCnn = New ADODB.Connection
    With adoCnn
         If .State = adStateConnecting Then
            .Close
         End If
         
         If .ConnectionString <> "" Then
            Exit Function
         End If
         
         .ConnectionString = strCnn
         .CursorLocation = adUseClient
         .Open strCnn, "sde", "lan811"
    End With
    Set ConnectOracle = adoCnn
    
    Exit Function

ER:
    MsgBox "数据库连接错误提示：" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "警告"
    ERR.Clear
End Function

Public Function ConnectAccess() As ADODB.Connection
On Error GoTo ER
    
    Dim adoCnn As ADODB.Connection
    Set adoCnn = New ADODB.Connection
    
    Dim strCnn As String
    strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Program Files\BeijiangTemp\myAccess.mdb;Persist Security Info=False" ' & _
      '"Data Source=srv;Initial Catalog=pubs;User Id=sa;Password=; "
    adoCnn.Open strCnn
       
'    Call AppendEvalInfoRecord(AdoCnn)
    Set ConnectAccess = adoCnn
'    Dim tmpRS As ADODB.Recordset
'    Set tmpRS = New ADODB.Recordset
     Exit Function
ER:
    MsgBox "系统错误提示：" & Chr(13) & ERR.Description, vbCritical + vbOKOnly, "警告"
    ERR.Clear

End Function

Public Function GetWritableRS(ByVal strTable As String, _
                              ByVal adoCnn As ADODB.Connection) As ADODB.Recordset
On Error GoTo ERH
        
    Dim strFilter As String
    strFilter = " select * from " & strTable

    Dim tmpRS As New ADODB.Recordset
    
    With tmpRS
         If .State = adStateOpen Then
         .Close
         End If
         .CursorLocation = adUseClient
         .CursorType = adOpenStatic
         .LockType = adLockOptimistic
         .Source = strFilter
         .ActiveConnection = adoCnn
         .Open
         
    End With
    Set GetWritableRS = tmpRS
    
    Exit Function
ERH:
    MsgBox "打开数据表失败！" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "信息"
    Set GetWritableRS = Nothing
    ERR.Clear
End Function

Public Function selectRecordset(ByVal strFilter As String, _
                                ByVal adoCnn As ADODB.Connection) As ADODB.Recordset
On Error GoTo ERH
         
    Dim tmpRS As ADODB.Recordset
    Set tmpRS = New ADODB.Recordset
    
    With tmpRS
        If .State = adStateOpen Then
            .Close
        End If
        
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
        .Source = strFilter
        .ActiveConnection = adoCnn
        .Open 'strFilter, adoCnn, adOpenStatic, adLockOptimistic
    End With
    
    Set selectRecordset = tmpRS
    
    Exit Function
ERH:
    MsgBox "系统发生错误！" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "信息"
    Set selectRecordset = Nothing
    ERR.Clear
End Function


'************************************************************************************************'''
''''数据库有关操作
'************************************************************************************************'''
Public Function recordExist(ByVal strTable As String, _
                            ByVal strField As String, _
                            ByVal strValue As String, _
                            ByVal adoCnn As ADODB.Connection) As Boolean
On Error GoTo ERH
         
    Dim strFilter As String
    strFilter = " select * from " + strTable + " where " + strField + " = '" + strValue + "'"
    
    Dim tmpRS As New ADODB.Recordset
    
    With tmpRS
         If .State = adStateOpen Then
         .Close
         End If
         .CursorLocation = adUseClient
         .CursorType = adOpenStatic
         .LockType = adLockOptimistic
         .Source = strFilter
         .ActiveConnection = adoCnn
         .Open
         
    End With
    
    If tmpRS.RecordCount > 0 Then
        recordExist = True
    Else
        recordExist = False
    End If
    
    Set tmpRS = Nothing
    Exit Function
ERH:
    MsgBox "系统发生错误！" & Chr(13) & ERR.Description, vbCritical + vbOKOnly, "警告"
    
    recordExist = False
    ERR.Clear
End Function

'************************************************************************************************'''
''''数据库有关操作
'************************************************************************************************'''
Public Function delRecords(ByVal strTable As String, _
                           ByVal strField As String, _
                           ByVal strValue As String, _
                           ByVal adoCnn As ADODB.Connection) As Boolean
On Error GoTo ERH
         
    Dim strFilter As String
    strFilter = " delete from " + strTable + " where " + strField + " = '" + strValue + "'"
    
    Dim tmpRS As New ADODB.Recordset
    
    With tmpRS
         If .State = adStateOpen Then
         .Close
         End If
         .CursorLocation = adUseClient
         .CursorType = adOpenStatic
         .LockType = adLockOptimistic
         .Source = strFilter
         .ActiveConnection = adoCnn
         .Open
         
    End With
    
    delRecords = False
    
    Exit Function
ERH:
    MsgBox "系统发生错误！" & Chr(13) & ERR.Description, vbCritical + vbOKOnly, "警告"
    
    delRecords = False
    ERR.Clear
End Function

'************************************************************************************************'''
''''数据库有关操作
'************************************************************************************************'''
Public Sub AppendEvalInfoRecord(rs As ADODB.Recordset, _
                                floodNam