arcgis 检出数据VBA代码

' Create a Replica Dataset descrpiton for a single feature class checkout
'IsCheckOut=ture 则捡出数据,false 则导出数据
'pGeometry为定义的数据范围
Private Function CreateRepDescription(pFeatureClassName() As IFeatureClassName, pChildWorkspaceName As IWorkspaceName, _
  bolReuseSchema As Boolean, pGeometry As IGeometry, icount As Integer, isCheckout As Boolean, IsContains As esriSpatialRelEnum) As IReplicaDescription
  
  Dim pEnumNameEdit As IEnumNameEdit
  Dim intIndex As Integer
  Dim i  As Integer
  
  Dim pRepDescription As IReplicaDescription
  Dim pRepFilterDescEdit As IReplicaFilterDescriptionEdit
  
  Set pEnumNameEdit = New NamesEnumerator
  For i = 0 To icount
      pEnumNameEdit.Add pFeatureClassName(i)
  Next
    
  ' Initialize the ReplicaDatasetDescription for the layer
  Set pRepDescription = New ReplicaDescription
  
  'IsCheckOut=ture 则捡出数据,false 则提取数据
  If isCheckout = True Then
     pRepDescription.Init pEnumNameEdit, pChildWorkspaceName, bolReuseSchema, esriDataCheckOut
  Else
     pRepDescription.Init pEnumNameEdit, pChildWorkspaceName, bolReuseSchema, esriDataExtraction
  End If
  pRepDescription.ReplicaModelType = esriModelTypeFullGeodatabase
  
  Set pRepFilterDescEdit = pRepDescription
  
  For i = 0 To icount
      intIndex = pRepDescription.FindTable(pFeatureClassName(i))

      With pRepFilterDescEdit
        .RowsType(intIndex) = esriRowsTypeFilter
        .TableUsesQueryGeometry(intIndex) = True '= Not (pGeometry Is Nothing)
        Set .Geometry = pGeometry
        .SpatialRelation = IsContains 
      End With
      pRepDescription.TableExcluded(intIndex) = False
  Next
 
  Set CreateRepDescription = pRepDescription
  
End Function

'按任意面检出
Private Sub CheckOutTest(DataExtent As IGeometry)
    
    Dim pApp As Application
    Set pApp = ThisDocument.Parent
    Dim pMxDoc As IMxDocument
    Set pMxDoc = Application.Document
    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap
    
   '获取要提取的要素类
   Dim DSNames() As String
   Dim dsInfo As String
   Dim fcCount As Integer
   Dim i As Integer

   dsInfo = getExtractFCInfo()
   If Trim(dsInfo) = "" Then
     MsgBox "没有选择图层！"
     Exit Sub
   End If
   
   dsInfo = Left(Trim(dsInfo), Len(Trim(dsInfo)) - 1)
   DSNames = Split(dsInfo, "\")
   fcCount = UBound(DSNames)
  
'   '获得提取的范围,以画图为先，选择面域为后
    Dim pExtractGeo As IGeometry
    Set pExtractGeo = DataExtent
    
    '确定导出范围
    Dim IsContains As esriSpatialRelEnum
    IsContains = esriSpatialRelIntersects
    
   '保存个人空间数据库的文件
   Dim pACCFact As IWorkspaceFactory2
   Dim pCheckOutWorkspace As IWorkspace
   Dim pCheckOutWorkspaceName As IWorkspaceName
     
   '以日期和时间作为捡出数据的文件名和捡出名称  默认放在C盘
   Dim MyDate
   Dim MyTime
   Dim MyTimeStr As String
   MyDate = Date
   MyTime = Time
   MyTimeStr = Format(MyTime, "hhmmss")
   Dim OutFileName As String
   Dim CheckoutName As String
   CheckoutName = Left(Environ("Computername"), 3) & "_" & Trim(Format(Str(MyDate), "yyyymmdd") & "_" & Trim(MyTimeStr)) '检出版本名称
     
   Dim customFileName As String
   customFileName = Format(Str(MyDate), "yyyymmdd") & "_" & Trim(MyTimeStr)
   OutFileName = "地形检出_" & Format(Str(MyDate), "yyyymmdd") & "_" & Trim(MyTimeStr)
   OutFileName = OutFileName + ".mdb"
   
   Dim fullName As String
   fullName = "c:\" & OutFileName

   Set pACCFact = New AccessWorkspaceFactory
   Set pCheckOutWorkspaceName = pACCFact.Create("c:\", OutFileName, Nothing, 0)

   Dim pGDBName As IName
   Set pGDBName = pCheckOutWorkspaceName
   Set pCheckOutWorkspace = pGDBName.Open
        
   If pCheckOutWorkspace Is Nothing Then
        MsgBox "本地文件创建失败,可能空间不足或者文件重命名！"
        Exit Sub
   End If
   Application.StatusBar.Message(0) = "正在连接数据库--->"

   Dim pPropSet As IPropertySet
   Dim pSdeFact As IWorkspaceFactory
   Set pPropSet = New PropertySet
   
   '获得连接参数
   Dim pServerName, pInstance, pUser, pPassword As String
   
   Dim adoconnectionstring As String
   Dim datacn  As New ADODB.Connection

   Dim rs As New ADODB.Recordset
   Dim sql As String

   adoconnectionstring = "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & pMDBfile & ";Uid=Admin;Pwd="
   datacn.ConnectionString = adoconnectionstring
   datacn.Open

   sql = "select server,instance,user,password from DatabaseConnStr"
   rs.Open sql, datacn, adOpenForwardOnly, adLockReadOnly
   
   Do While rs.EOF = False
       pServerName = rs!server
       pInstance = rs!Instance
       pUser = rs!user
       pPassword = rs!password
       rs.MoveNext
   Loop
   rs.Close
   datacn.Close
   
   If pInstance = "" Or pUser = "" Or pPassword = "" Then
     MsgBox "数据库参数有误，请重新设置并保存！"
     Exit Sub
   End If
   
   With pPropSet  'SDE数据库

     .SetProperty "SERVER", "Oracle"
     .SetProperty "INSTANCE", pInstance & ":" & pServerName
     .SetProperty "DATABASE", ""
     .SetProperty "USER", pUser
     .SetProperty "PASSWORD", pPassword
     .SetProperty "VERSION", "SDE.DEFAULT"

   End With

   Set pSdeFact = New SdeWorkspaceFactory
   Dim pWS As IWorkspace
   Set pWS = pSdeFact.Open(pPropSet, 0)
   
   '枚举所有要导出的FeatureClass
   Dim pFeatureWorkspace As IFeatureWorkspace
   Set pFeatureWorkspace = pWS

   ReDim pFCNames(fcCount + 1) As IFeatureClassName
   Dim pFeatureclass As IFeatureClass
   Dim pDataset As IDataset
   Dim pFeatureClassName As IFeatureClassName
   
   Dim pStepProgressor As IStepProgressor
   Set pStepProgressor = Application.StatusBar.ProgressBar
    
   pStepProgressor.MinRange = 0
   pStepProgressor.MaxRange = fcCount
   pStepProgressor.Show
   
   For i = 0 To fcCount
       Set pFeatureclass = pFeatureWorkspace.OpenFeatureClass(DSNames(i))
       Set pDataset = pFeatureclass
       Set pFeatureClassName = pDataset.fullName
       Set pFCNames(i) = pFeatureClassName
       
       pStepProgressor.position = i
       pStepProgressor.Message = "正在检查图层"
   Next
   pStepProgressor.Hide
   
   Application.StatusBar.Message(0) = "正在检出地形数据，请稍候--->"

   Dim pRepDescription As IReplicaDescription
   Set pRepDescription = CreateRepDescription(pFCNames, pCheckOutWorkspaceName, False, pExtractGeo, fcCount, True, IsContains)
   
    Dim pCheckOUtUI As ICheckOutUI
    Set pCheckOUtUI = New CheckOutUI
    
    Dim pCheckOutUIPropsEdit As ICheckOutUIPropertiesEdit
    Set pCheckOutUIPropsEdit = pCheckOUtUI
    Set pCheckOutUIPropsEdit.CODescription = pRepDescription
    pCheckOutUIPropsEdit.COName = CheckoutName
    pCheckOutUIPropsEdit.CORelatedObjects = False
    
    Dim pDisConEditUI As IDisconnectedEditingUI
    Set pDisConEditUI = pCheckOUtUI
    Set pDisConEditUI.Application = pApp
    pDisConEditUI.Show False, pApp.hWnd
     
    Application.StatusBar.Message(0) = "数据检出完成!"
    Set pWS = Nothing
    
    Dim pViewManager As IViewManager
    Set pViewManager = pMap
    pViewManager.ElementSelection.Clear
    pMap.ClearSelection
   

End Sub