modsdeop.bas

FloodEvaluation-程序是gis方面的程序

Attribute VB_Name = "modSdeOp"
Dim sServer As String, sInstance As String, sDB As String, sUser As String, sPasswd As String, sVersion As String
Dim sSDERaster As String, sDir As String, sInput As String, sSDEFeature As String

Dim m_pWorkspace As IWorkspace
Dim m_pSDEPropset As IPropertySet

Public Sub setConnectInfo()

''''''  With pSDEPropertySet
''''''        .SetProperty "Server", "foundway"
''''''        .SetProperty "Instance", "port:5150"
''''''        .SetProperty "Database", "mydb"              ' Ignored with ArcSDE for Oracle
''''''        .SetProperty "user", "sde"
''''''        .SetProperty "password", "lan811"
''''''        .SetProperty "version", "sde.DEFAULT"
''''''  End With
    'set the SDE connection information
    sServer = "foundway"
    sInstance = "port:5150"
    sDB = "mydb"            ' Ignored with ArcSDE for Oracle
    sUser = "sde"
    sPasswd = "lan811"
    sVersion = "sde.DEFAULT"
    
    sDir = "C:\Program Files\BeijiangTemp"
    sSDERaster = "dem1"
    sSDEFeature = "flood"
    sInput = "dem1"
    Set m_pSDEPropset = setPropertySet(sServer, sInstance, sUser, sPasswd, sDB, sVersion)
    Set m_pWorkspace = openSdeFWS(m_pSDEPropset)
         
End Sub

'''
'''Private Sub cmdAddFeat_Click()
'''    Dim sSDEDSname As String, sShpPath As String, sShpName As String
'''    sSDEDSname = "flood"
'''    sShpPath = "C:\Program Files\BeijiangTemp" '"C:\Program Files\arcgis\arcexe83\ArcObjects Developer Kit\Samples\Data\Usa" '
'''    sShpName = "flood"
'''
'''    Call AddFeatureToSDE(m_pSDEPropset, sSDEDSname, sShpPath, sShpName)
'''
'''End Sub

'''*******************************************************************************************************
'''从SDE读取矢量数据
'''*******************************************************************************************************
Public Function GetFeatureFromSDE(sSDEFeature As String) As IFeatureClass
    
  On Error GoTo EH
  
'    Me.MousePointer = vbHourglass
    
    Dim pFWS As IFeatureWorkspace
    Set pFWS = m_pWorkspace

    Dim featCls  As IFeatureClass
    Set featCls = pFWS.OpenFeatureClass(sSDEFeature)
    Set GetFeatureFromSDE = featCls
    
'    Me.MousePointer = vbDefault

    Exit Function
EH:
    MsgBox "打开SDE矢量图层失败" & Chr(13) & ERR.Description, vbInformation, "打开SDE矢量图层"
End Function

'''*******************************************************************************************************
'''从SDE加载矢量数据
'''*******************************************************************************************************
Public Sub AddFeatureToSDE(pOutSDEPropset As IPropertySet, sSDEDSname As String, _
                           sShpPath As String, sShpName As String)
    
     On Error GoTo EH
     
     ' +++ Create a new feature datset name object for the output SDE feature dataset
     Dim pOutSDEWorkspaceName As IWorkspaceName
     Set pOutSDEWorkspaceName = New WorkspaceName
     pOutSDEWorkspaceName.connectionProperties = pOutSDEPropset
     pOutSDEWorkspaceName.WorkspaceFactoryProgID = "esriCore.SdeWorkspaceFactory.1"
   
     Dim pOutSDEFeatDSName As IFeatureDatasetName
     Set pOutSDEFeatDSName = New FeatureDatasetName
     
     Dim pSDEDSname As IDatasetName
     Set pSDEDSname = pOutSDEFeatDSName
     Set pSDEDSname.WorkspaceName = pOutSDEWorkspaceName
     pSDEDSname.name = sSDEDSname

     ' +++ Get the name object for the input shapefile workspace
     Dim pInShpWorkspaceName As IWorkspaceName
     Set pInShpWorkspaceName = New WorkspaceName
     pInShpWorkspaceName.pathName = sShpPath
     pInShpWorkspaceName.WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory.1"

     Dim pInShpFeatCLSNm As IFeatureClassName
     Set pInShpFeatCLSNm = New FeatureClassName
     Dim pShpDatasetName As IDatasetName
     Set pShpDatasetName = pInShpFeatCLSNm
     pShpDatasetName.name = sShpName
     Set pShpDatasetName.WorkspaceName = pInShpWorkspaceName

     ' +++ create the new output FeatureClass name object that will be passed into the conversion function
     Dim pOutputDSName As IDatasetName
     Dim pOutputFCName As IFeatureClassName
     Set pOutputFCName = New FeatureClassName
     Set pOutputDSName = pOutputFCName
     Dim pInDSNAme As IDatasetName
      
     ' +++ Set the new FeatureClass name to be the same as the input FeatureClass name
     Set pInDSNAme = pInShpFeatCLSNm
     pOutputDSName.name = sShpName
     ' +++ Open the input Shapefile FeatureClass object, so that we can get its fields
     Dim pName As IName
     Dim pInShpFeatCls As IFeatureClass
     Set pName = pInShpFeatCLSNm
     Set pInShpFeatCls = pName.Open
      
     ' +++ Get the fields for the input feature class and run them through field checker to make sure there are no illegal or duplicate field names
     Dim pOutSDEFlds As IFields
     Dim pInShpFlds As IFields
     Dim pFldChk As IFieldChecker
     Dim i As Long
     Dim pGeoField As IField
     Dim pOutSDEGeoDef As IGeometryDef
     Dim pOutSDEGeoDefEdit As IGeometryDefEdit
     Set pInShpFlds = pInShpFeatCls.Fields
     Set pFldChk = New FieldChecker
     pFldChk.Validate pInShpFlds, Nothing, pOutSDEFlds

     ' +++ Loop through the output fields to find the geometry field
     For i = 0 To pOutSDEFlds.FieldCount
       If pOutSDEFlds.Field(i).Type = esriFieldTypeGeometry Then
         Set pGeoField = pOutSDEFlds.Field(i)
         Exit For
       End If
     Next i

     ' +++ Get the geometry field's geometry definition
     Set pOutSDEGeoDef = pGeoField.GeometryDef

     ' +++ Give the geometry definition a spatial index grid count and grid size
     Set pOutSDEGeoDefEdit = pOutSDEGeoDef
     pOutSDEGeoDefEdit.GridCount = 1
     pOutSDEGeoDefEdit.GridSize(0) = 1500000
      
     ' +++ Now use IFeatureDataConverter::Convert to create the output FeatureDataset and FeatureClass.
     Dim pShpToFc As IFeatureDataConverter
     Set pShpToFc = New FeatureDataConverter
     pShpToFc.ConvertFeatureClass pInShpFeatCLSNm, Nothing, pOutSDEFeatDSName, _
                        pOutputFCName, Nothing, pOutSDEFlds, "", 1000, 0
     
    Set pOutSDEWorkspaceName = Nothing
    Set pOutSDEFeatDSName = Nothing
    Set pInShpWorkspaceName = Nothing
    Set pInShpFeatCLSNm = Nothing
    Set pOutputFCName = Nothing
    Set pFldChk = Nothing

    MsgBox "完成SDE矢量图层写入!", vbInformation
    
    Exit Sub
EH:

    MsgBox "SDE矢量图层写入失败" & Chr(13) & ERR.Description, vbInformation, "向SDE写入矢量图层"

End Sub

'''*******************************************************************************************************
'''从SDE读取栅格数据
'''*******************************************************************************************************
Public Function GetRasterFromSDE(pSDEPropertySet As IPropertySet, sUser As String, sSDERaster As String) As IRasterDataset
  On Error GoTo EH
  
'    Me.MousePointer = vbHourglass
    
    Dim pSDEWs As IWorkspaceName
    Dim pSDERasterDataset As IRasterDataset
    Dim pDsName As IDatasetName
    Dim pName As IName
    Dim sQualifiedName As String
            
    ' Get workspacename
    Set pSDEWs = New WorkspaceName
    pSDEWs.connectionProperties = pSDEPropertySet
    pSDEWs.WorkspaceFactoryProgID = "esricore.sdeworkspacefactory"
    
'    Get qualified ArcSDE raster name
'    If Len(sDB) > 0 Then
'        sQualifiedName = sDB + "." + sUser + "." + sSDERaster
'    Else
    sQualifiedName = sUser + "." + sSDERaster
'    End If
    
    ' Get raster dataset name
    Set pDsName = New RasterDatasetName
    pDsName.name = sQualifiedName
    Set pDsName.WorkspaceName = pSDEWs
    Set pName = pDsName
    
    ' Open ArcSDE raster dataset
    Set pSDERasterDataset = pName.Open
    
    ' Cleanup
    Set GetRasterFromSDE = pSDERasterDataset
    Set pSDEWs = Nothing
    Set pSDERasterDataset = Nothing
    Set pName = Nothing
    Set pDsName = Nothing

'    Me.MousePointer = vbDefault
    Exit Function
EH:
    MsgBox "从SDE读取栅格失败" & Chr(13) & ERR.Description, vbInformation, "从SDE读取栅格"
End Function

'''*******************************************************************************************************
'''向SDE加载栅格数据
'''*******************************************************************************************************
Public Sub AddRasterToSDE(sDir As String, sInput As String, sServer As String, sInstance As String, _
                      sDB As String, sUser As String, sPasswd As String, sSDERaster As String)
  
    ' sDir:       the directory where the input raster resides
    ' sInput:     the name of input raster
    ' sSDERaster: the output ArcSDE raster dataset name
    ' sServer,sInstance,sDB,sUser,sPasswd: ArcSDE connection info
    On Error GoTo EH
    
    Dim pSDEConn As IRasterSdeConnection
    Dim pSDEStorage As IRasterSdeStorage
    Dim pSDEOp As IRasterSdeServerOperation
    Dim pRasterWsFact As IWorkspaceFactory
    Dim pRasterWs As IRasterWorkspace
    Dim pGeoDs As IGeoDataset
    
    ' Initialize RasterSDELoader
    Set pSDEConn = New RasterSdeLoader
    ' Make connection
        pSDEConn.ServerName = sServer
        pSDEConn.Instance = sInstance
        pSDEConn.Database = sDB
        pSDEConn.username = sUser
        pSDEConn.Password = sPasswd
        pSDEConn.InputRasterName = sDir & "\" & sInput
        pSDEConn.SdeRasterName = sSDERaster
    
    Set pSDEStorage = pSDEConn                                             ' Set storage parameters
    Set pRasterWsFact = New RasterWorkspaceFactory                         ' Get spatialreference
    Set pRasterWs = pRasterWsFact.OpenFromFile(sDir, 0)
    Set pGeoDs = pRasterWs.OpenRasterDataset(sInput)
    Set pSDEStorage.SpatialReference = pGeoDs.SpatialReference             ' Set spatialreference
    pSDEStorage.CompressionType = esriRasterSdeCompressionTypeRunLength    ' Set compression
    pSDEStorage.TileHeight = 128                                           ' Set tilesize
    pSDEStorage.TileWidth = 128
    pSDEStorage.PyramidOption = esriRasterSdePyramidBuildWithFirstLevel    ' Pyramids option
    pSDEStorage.PyramidResampleType = RSP_BilinearInterpolation
    Set pSDEOp = pSDEConn                                                  ' Start loading
    pSDEOp.Create
    pSDEOp.ComputeStatistics                                               ' Calculate stats

    
    ' Cleanup
    Set pSDEConn = Nothing
    Set pSDEStorage = Nothing
    Set pSDEOp = Nothing
    Set pRasterWsFact = Nothing
    Set pRasterWs = Nothing
    Set pGeoDs = Nothing
    MsgBox "完成SDE栅格图层写入"
    Exit Sub
EH:
    MsgBox "SDE栅格图层写入失败" & Chr(13) & ERR.Description, vbInformation, "向SDE写入栅格"
End Sub

'''*******************************************************************************************************
'''向SDE加载栅格数据
'''*******************************************************************************************************
Public Sub DeleteRasterToSDE(sDir As String, sInput As String, sServer As String, sInstance As String, _
                             sDB As String, sUser As String, sPasswd As String, sSDERaster As String)
    ' sDir:       the directory where the input raster resides
    ' sInput:     the name of input raster
    ' sSDERaster: the output ArcSDE raster dataset name
    ' sServer,sInstance,sDB,sUser,sPasswd: ArcSDE connection info
    On Error GoTo EH
    
    Dim pSDEConn As IRasterSdeConnection
    Dim pSDEOp As IRasterSdeServerOperation
    
    ' Initialize RasterSDELoader
    Set pSDEConn = New RasterSdeLoader
    ' Make connection
        pSDEConn.ServerName = sServer
        pSDEConn.Instance = sInstance
        pSDEConn.Database = sDB
        pSDEConn.username = sUser
        pSDEConn.Password = sPasswd
        pSDEConn.InputRasterName = sDir & "\" & sInput
        pSDEConn.SdeRasterName = sSDERaster
    
    ' Start loading
    Set pSDEOp = pSDEConn
    pSDEOp.Delete
    
    ' Cleanup
    Set pSDEConn = Nothing
    Set pSDEOp = Nothing
    Exit Sub
EH:
    MsgBox "从SDE删除栅格失败" & Chr(13) & ERR.Description, vbInformation, "从SDE删除栅格"
End Sub


'''*******************************************************************************************************
'''openSdeFWS，打开SDE用于读取矢量图层
'''*******************************************************************************************************
Public Function setPropertySet(Server As String, Instance As String, User As String, _
                             Password As String, Optional Database As String = "", _
                             Optional version As String = "SDE.DEFAULT") As IPropertySet
  
  On Error GoTo EH
  Dim pSDEPropset As IPropertySet
  Set pSDEPropset = New PropertySet
  
  With pSDEPropset
    .SetProperty "Server", Server
    .SetProperty "Instance", Instance
    .SetProperty "Database", Database
    .SetProperty "User", User
    .SetProperty "Password", Password
    .SetProperty "version", version
  End With
 
  Set setPropertySet = pSDEPropset
  Exit Function
EH:
    MsgBox "设置PropertySet失败" & Chr(13) & ERR.Description
End Function

'''*******************************************************************************************************
'''openSdeFWS，打开SDE用于读取矢量图层
'''*******************************************************************************************************
Public Function openSdeFWS(pPropSet As IPropertySet) As IWorkspace
  
  On Error GoTo EH
  Set openSdeFWS = Nothing
  
  Dim pSdeFact As IWorkspaceFactory
  Set pSdeFact = New SdeWorkspaceFactory
  
  Set openSdeFWS = pSdeFact.Open(pPropSet, 0)
  
  Exit Function
EH:
    MsgBox "打开SDE库失败" & Chr(13) & ERR.Description, vbInformation, "打开SDE"
End Function