modsdeop.bas

FloodEvaluation-程序是gis方面的程序

'''*******************************************************************************************************
'''CopyDS creates a new personal geodatabase, then uses IFeatureDataConverter::ConvertFeatureDataset
'''to convert an ArcSDE feature dataset into a feature dataset in the new Access database.
'''*******************************************************************************************************
Sub CopyDS()
     ' +++ Set connection properties. Change the properties to match your
     ' +++ server name, instance, user name and password for your SDE database
       
  On Error GoTo EH
  
     Dim pOutSDEPropset As IPropertySet
     Set pOutSDEPropset = New PropertySet
     With pOutSDEPropset
        .SetProperty "Server", "stout"
        .SetProperty "Instance", "sde4_ora"
        .SetProperty "user", "gdb"
        .SetProperty "password", "gdb"
        .SetProperty "version", "SDE.DEFAULT"
     End With

     Dim pInSDEWorkspaceName As IWorkspaceName
     Set pInSDEWorkspaceName = New WorkspaceName
     pInSDEWorkspaceName.connectionProperties = pOutSDEPropset
     pInSDEWorkspaceName.WorkspaceFactoryProgID = "esriCore.SdeWorkspaceFactory.1"

     ' +++ get the name object for the input SDE feature dataset
     Dim pFeatureDatasetName As IFeatureDatasetName
     Set pFeatureDatasetName = New FeatureDatasetName
     Dim pSDEDatasetName As IDatasetName
     Set pSDEDatasetName = pFeatureDatasetName
     pSDEDatasetName.name = "USA"
     Set pSDEDatasetName.WorkspaceName = pInSDEWorkspaceName

     ' +++ create a new Access database to copy the feature dataset into
     Dim pOutAcFact As IWorkspaceFactory
     Set pOutAcFact = New AccessWorkspaceFactory

     Dim pOutAcWorkspaceName As IWorkspaceName
     Set pOutAcWorkspaceName = pOutAcFact.Create("C:\", "Usa", Nothing, 0)

     ' +++ create a new feature datset name object for the output Access
     ' +++ feature dataset, call it "USA"
     Dim pOutAcFeatDSName As IFeatureDatasetName
     Set pOutAcFeatDSName = New FeatureDatasetName

     Dim pOutAcDSName As IDatasetName
     Set pOutAcDSName = pOutAcFeatDSName

     Set pOutAcDSName.WorkspaceName = pOutAcWorkspaceName
     pOutAcDSName.name = "USA"

     ' +++ now do the conversion
     Dim pFdtoFd As IFeatureDataConverter
     Set pFdtoFd = New FeatureDataConverter

     pFdtoFd.ConvertFeatureDataset pFeatureDatasetName, pOutAcFeatDSName, Nothing, "", 1000, 0

     MsgBox "Conversion complete!"
     Exit Sub
EH:
    MsgBox "打开SDE库失败" & Chr(13) & ERR.Description, vbInformation, "打开SDE"
End Sub

'''*******************************************************************************************************
'''LoadShps
'''      use the data conversion functions to convert data from a Shapefile to an ArcSDE Geodatabase.
'''*******************************************************************************************************
Sub LoadShps()
     ' +++ Set connection properties. Change the properties to match your
     ' +++ server name, instance, user name and password for your SDE database
       
     On Error GoTo EH
     
     Dim pOutSDEPropset As IPropertySet
     Set pOutSDEPropset = New PropertySet
     With pOutSDEPropset
        .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"
''        .SetProperty "Server", "stout"
''        .SetProperty "Instance", "sde4_ora"
''        .SetProperty "user", "gdb"
''        .SetProperty "password", "gdb"
''        .SetProperty "version", "SDE.DEFAULT"
     End With
     
     ' +++ Create a new feature datset name object for the output SDE feature dataset, call
     ' +++ it "USA"
     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 = "ushigh"

     ' +++ Get the name object for the input shapefile workspace
     Dim pInShpWorkspaceName As IWorkspaceName
     Set pInShpWorkspaceName = New WorkspaceName
     pInShpWorkspaceName.pathName = "C:\Program Files\arcgis\arcexe83\ArcObjects Developer Kit\Samples\Data\Usa"
     pInShpWorkspaceName.WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory.1"

     Dim pInShpFeatCLSNm As IFeatureClassName
     Set pInShpFeatCLSNm = New FeatureClassName
     Dim pShpDatasetName As IDatasetName
     Set pShpDatasetName = pInShpFeatCLSNm
     pShpDatasetName.name = "ushigh"
     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 = "ushigh"
     ' +++ 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
          
     MsgBox "完成向SDE库写矢量图!", vbInformation
     
    Exit Sub
EH:
    MsgBox "向SDE库写矢量图层失败" & Chr(13) & ERR.Description, vbInformation, "向SDE写矢量图层"
End Sub

'''*******************************************************************************************************
'''CreateShapefile
'''*******************************************************************************************************
Public Sub CreateShpfileToSDE()
On Error GoTo ER
  Const strFolder As String = "D:\Data"
  Const strName As String = "MyShapeFile" ' Dont include .shp extension
  Const strShapeFieldName As String = "Shape"
  
  ' Open the folder to contain the shapefile as a workspace
  Dim pFWS As IFeatureWorkspace
'  Dim pWorkspaceFactory As IWorkspaceFactory
'  Set pWorkspaceFactory = New ShapefileWorkspaceFactory
'  Set pFWS = pWorkspaceFactory.OpenFromFile(strFolder, 0)
  Set pFWS = pWorkspace
  
  ' Set up a simple fields collection
  Dim pFields As IFields
  Dim pFieldsEdit As IFieldsEdit
  Set pFields = New esriCore.Fields
  Set pFieldsEdit = pFields
  
  Dim pField As IField
  Dim pFieldEdit As IFieldEdit
  
  ' Make the shape field
  ' it will need a geometry definition, with a spatial reference
  Set pField = New esriCore.Field
  Set pFieldEdit = pField
  pFieldEdit.name = strShapeFieldName
  pFieldEdit.Type = esriFieldTypeGeometry
  
  Dim pGeomDef As IGeometryDef
  Dim pGeomDefEdit As IGeometryDefEdit
  Set pGeomDef = New GeometryDef
  Set pGeomDefEdit = pGeomDef
  With pGeomDefEdit
    .GeometryType = esriGeometryPolygon
    Set .SpatialReference = New UnknownCoordinateSystem
  End With
  Set pFieldEdit.GeometryDef = pGeomDef
  pFieldsEdit.AddField pField

  ' Add another miscellaneous text field
  Set pField = New esriCore.Field
  Set pFieldEdit = pField
  With pFieldEdit
      .Length = 30
      .name = "MiscText"
      .Type = esriFieldTypeString
  End With
  pFieldsEdit.AddField pField
  
  ' Create the shapefile
  ' (some parameters apply to geodatabase options and can be defaulted as Nothing)
  Dim pFeatClass As IFeatureClass
  Set pFeatClass = pFWS.CreateFeatureClass(strName, pFields, Nothing, _
                                           Nothing, esriFTSimple, strShapeFieldName, "")
  MsgBox "creating shapefile completed!"
  Exit Sub
ER:
  MsgBox "Failed to create shapefile in SDE" & Chr(13) & ERR.Description
End Sub

'************************************************************************************************'''
''''检测并上载FeatureClass
'************************************************************************************************'''
Public Sub LoadShpfileToSDE(strFile As String, strDir As String, strSdeName, _
                            sdeProperSet As IPropertySet, ByRef pSdeFWS As IWorkspace)
On Error GoTo ERH
   
    Dim strFCName As String, bExist As Boolean
    strFCName = Left(strFile, Len(strFile) - 4)
    
    Dim inProperSet As IPropertySet
    Set inProperSet = New PropertySet
    inProperSet.SetProperty "database", strDir
    
    Dim sdeName As String
    sdeName = strSdeName
    
    bExist = SDEFeatureExist(sdeName, pSdeFWS)
    If bExist Then
        MsgBox "指定的SDE图层已经存在，请换名"
        
        frmSdeName.Left = (Screen.Width - frmSdeName.Width) / 2
        frmSdeName.Top = (Screen.Height - frmSdeName.Height) / 2
        frmSdeName.Show vbModal
        If frmSdeName.bFlag Then
           sdeName = frmSdeName.strName
        Else
           MsgBox "命名失败"
           Exit Sub
        End If
    End If
    
    Call FCLoader(strFCName, sdeName, inProperSet, sdeProperSet)
    Exit Sub
    
ERH:
   MsgBox "上载矢量图层失败"
End Sub
'************************************************************************************************'''
''''检测FeatureClass是否存在
'************************************************************************************************'''
Public Function SDEFeatureExist(ByVal strFCName As String, _
                                ByRef pFWS As IWorkspace) As Boolean

On Error GoTo Error_h
    
    Dim pDsName As IDatasetName
    Dim pEnumDSName As IEnumDatasetName
    Set pEnumDSName = pFWS.DatasetNames(esriDTFeatureClass)
    Set pDsName = pEnumDSName.Next

    While Not pDsName Is Nothing
        If pDsName.name = "SDE." & strFCName Then
            SDEFeatureExist = True
            Exit Function
        End If
        Set pDsName = pEnumDSName.Next
    Wend
    SDEFeatureExist = False
    Exit Function
Error_h:
   MsgBox strFCName & "不存在"   'MsgLogOut MeName, "SDEFeatureExist", False
End Function

'"******************************************************************
'"Function:　创建到Oracle的连接, SDEConnect will create the connection to SDE Database
'"Input :　　Server , Instance,　User,　Password
'"Output :　 IFeatureWorkspace struction
'"******************************************************************
Public Function SDEConnect(ByVal Server As String, _
                           ByVal Instance As String, _
                           ByVal User As String, _
                           ByVal Password As String) As IFeatureWorkspace
              
On Error GoTo Error_h
'　　"Create ArcSDE Connection
    Dim pPropertyset As IPropertySet
    Set pPropertyset = New PropertySet
  
'　　"Set SDE DB Connect info here
    With pPropertyset
        .SetProperty "SERVER", Server
        .SetProperty "INSTANCE", Instance
        .SetProperty "USER", User
        .SetProperty "PASSWORD", Password
        .SetProperty "VERSION", "SDE.DEFAULT"
    End With
'　　"Open WorkSpace
    Dim pWorkspaceFactory As IWorkspaceFactory
    Set pWorkspaceFactory = New SdeWorkspaceFactory
    Dim pFWS As IFeatureWorkspace
    Set pFWS = pWorkspaceFactory.Open(pPropertyset, 0)
'　　"CleanUp
    Set pPropertyset = Nothing
    Set pWorkspaceFactory = Nothing
    Set SDEConnect = pFWS
    Exit Function
Error_h:
    Set pPropertyset = Nothing
    Set pWorkspaceFactory = Nothing
    MsgBox "SDEConnect()"
End Function

'************************************************************************************************'''
''''向SDE里面添加Shape File
'************************************************************************************************'''
'入口，源FeatureClass, 源InpropertySet, 目标/目标
Public Function FCLoader(sInName As String, _
                        sOutName As String, _
                        pInPropertySet As IPropertySet, _
                        pOutPropertySet As IPropertySet) As Boolean
  
On Error GoTo Error_h:
  
'　　" Set up for input workspace which is from a ShapeFile