modsdeop.bas

FloodEvaluation-程序是gis方面的程序

    Dim pInWorkspaceName As IWorkspaceName
    Set pInWorkspaceName = New WorkspaceName
    pInWorkspaceName.connectionProperties = pInPropertySet
    pInWorkspaceName.WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory.1"    'WorkspaceName

'　　" Set in dataset and table names.
    Dim pInFCName As IFeatureClassName
    Set pInFCName = New FeatureClassName
    Dim pInDatasetName As IDatasetName
    Set pInDatasetName = pInFCName
    pInDatasetName.name = sInName
    Set pInDatasetName.WorkspaceName = pInWorkspaceName                                 'inDatasetName
  
'　　" Setup output workspace which is to SDE database.
    Dim pOutWorkspaceName As IWorkspaceName
    Set pOutWorkspaceName = New WorkspaceName
    pOutWorkspaceName.connectionProperties = pOutPropertySet
    pOutWorkspaceName.WorkspaceFactoryProgID = "esriCore.SDEWorkspaceFactory.1"
  
'　　" Set out dataset and table names.
    Dim pOutDatasetName As IDatasetName
    Dim pOutFCName As IFeatureClassName
    Set pOutFCName = New FeatureClassName
    Set pOutDatasetName = pOutFCName
    pOutDatasetName.name = sOutName
    Set pOutDatasetName.WorkspaceName = pOutWorkspaceName

'　 " Open input Featureclass to get field definitions.
    Dim pName As IName
    Dim pInFC As IFeatureClass
    Set pName = pInFCName
    Set pInFC = pName.Open                                                              'Open Featureclass
  
'　　" Validate the field names.
    Dim pOutFCFields As IFields
    Dim pInFCFields As IFields
    Dim pFieldCheck As IFieldChecker
    Dim i As Long
  
    Set pInFCFields = pInFC.Fields
    Set pFieldCheck = New FieldChecker
    pFieldCheck.Validate pInFCFields, Nothing, pOutFCFields
    Set pFieldCheck = Nothing
  
'　　" +++ Loop through the output fields to find the geometry field
    Dim pGeoField As IField
    For i = 0 To pOutFCFields.FieldCount
        If pOutFCFields.Field(i).Type = esriFieldTypeGeometry Then
          Set pGeoField = pOutFCFields.Field(i)
          Exit For
        End If
    Next i
  
'　　" +++ Get the geometry field"s geometry defenition
    Dim pOutFCGeoDef As IGeometryDef
    Set pOutFCGeoDef = pGeoField.GeometryDef
  
'　　" +++ Give the geometry definition a spatial index grid count and grid size
    Dim pOutFCGeoDefEdit As IGeometryDefEdit
    Set pOutFCGeoDefEdit = pOutFCGeoDef
    pOutFCGeoDefEdit.GridCount = 1
    pOutFCGeoDefEdit.GridSize(0) = DefaultIndexGrid(pInFC)
    Set pOutFCGeoDefEdit.SpatialReference = pGeoField.GeometryDef.SpatialReference
  
'　　" Load the table.
    Dim pFCToFC As IFeatureDataConverter
    Set pFCToFC = New FeatureDataConverter
  
    Dim pEnumErrors As IEnumInvalidObject
    Set pEnumErrors = pFCToFC.ConvertFeatureClass( _
                                pInFCName, Nothing, Nothing, pOutFCName, _
                                pOutFCGeoDef, pOutFCFields, "", 1000, 0)
  
'　　"Catch the Error
    Dim pErrInfo As IInvalidObjectInfo
    Set pErrInfo = pEnumErrors.Next

    Dim strErrMsg As String
    Do Until pErrInfo Is Nothing
        strErrMsg = strErrMsg & pErrInfo.ErrorDescription & ":" & pErrInfo.InvalidObjectID
        Debug.Print pErrInfo.ErrorDescription & ":" & pErrInfo.InvalidObjectID
        Set pErrInfo = pEnumErrors.Next
    Loop
    pEnumErrors.Reset
  
'　　"Clean Up
    Set pInWorkspaceName = Nothing
    Set pInFCName = Nothing
    Set pOutWorkspaceName = Nothing
    Set pOutFCName = Nothing
    Set pFCToFC = Nothing
  
    FCLoader = True
    Exit Function
Error_h:
    Set pInWorkspaceName = Nothing
    Set pInFCName = Nothing
    Set pOutWorkspaceName = Nothing
    Set pOutFCName = Nothing
    Set pFCToFC = Nothing
    MsgBox "fail to load featurelayer"   'MsgLogOut MeName, "FCLoader()", True, strErrMsg
End Function

Private Function DefaultIndexGrid(InFC As IFeatureClass) As Double
  ' Calculate approximate first grid
  ' based on the average of a random sample of feature extents times five
  Dim lngNumFeat As Long
  Dim lngSampleSize As Long
  Dim pFields As IFields
  Dim pField As IField
  Dim strFIDName As String
  Dim strWhereClause As String
  Dim lngCurrFID As Long
  Dim pFeat As IFeature
  Dim pFeatCursor As IFeatureCursor
  Dim pFeatEnv As IEnvelope
  Dim pQueryFilter As IQueryFilter
  Dim pNewCol As New Collection
  Dim lngKMax As Long
 
  Dim dblMaxDelta As Double
  dblMaxDelta = 0
  Dim dblMinDelta As Double
  dblMinDelta = 1000000000000#
  Dim dblSquareness As Double
  dblSquareness = 1
  
  Dim i As Long
  Dim j As Long
  Dim k As Long
  
  Const SampleSize = 1
  Const Factor = 1
  
  ' Create a recordset
  
  Dim ColInfo(0), c0(3)
  
  c0(0) = "minext"
  c0(1) = CInt(5)
  c0(2) = CInt(-1)
  c0(3) = False
  
  ColInfo(0) = c0
  
  lngNumFeat = InFC.FeatureCount(Nothing) - 1
  If lngNumFeat <= 0 Then
    DefaultIndexGrid = 1000
    Exit Function
  End If
  'if the feature type is points use the density function
  If InFC.shapeType = esriGeometryMultipoint Or InFC.shapeType = esriGeometryPoint Then
    DefaultIndexGrid = DefaultIndexGridPoint(InFC)
    Exit Function
  End If
  ' Get the sample size
  lngSampleSize = lngNumFeat * SampleSize
  ' Don't allow too large a sample size to speed
  If lngSampleSize > 1000 Then lngSampleSize = 1000
  ' Get the ObjectID Fieldname of the feature class
  Set pFields = InFC.Fields
  ' FID is always the first field
  Set pField = pFields.Field(0)
  strFIDName = pField.name
  ' Add every nth feature to the collection of FIDs
  For i = 1 To lngNumFeat Step CLng(lngNumFeat / lngSampleSize)
    pNewCol.Add i
  Next i
  For j = 0 To pNewCol.Count - 1 Step 250
    ' Will we top out the features before the next 250 chunk?
    lngKMax = Min(pNewCol.Count - j, 250)
    strWhereClause = strFIDName + " IN("
    For k = 1 To lngKMax
      strWhereClause = strWhereClause + CStr(pNewCol.Item(j + k)) + ","
    Next k
    ' Remove last comma and add close parenthesis
    strWhereClause = Mid(strWhereClause, 1, Len(strWhereClause) - 1) + ")"
    Set pQueryFilter = New QueryFilter
    pQueryFilter.WhereClause = strWhereClause
    Set pFeatCursor = InFC.Search(pQueryFilter, True)
    Set pFeat = pFeatCursor.NextFeature
    While Not pFeat Is Nothing
      ' Get the extent of the current feature
      Set pFeatEnv = pFeat.Extent
      ' Find the min, max side of all extents. The "Squareness", a measure
      ' of how close the extent is to a square, is accumulated for later
      ' average calculation.
      dblMaxDelta = Max(dblMaxDelta, Max(pFeatEnv.Width, pFeatEnv.Height))
      dblMinDelta = Min(dblMinDelta, Min(pFeatEnv.Width, pFeatEnv.Height))
    '  lstSort.AddItem Max(pFeatEnv.Width, pFeatEnv.Height)
      If dblMinDelta <> 0 Then
        dblSquareness = dblSquareness + ((Min(pFeatEnv.Width, pFeatEnv.Height) / (Max(pFeatEnv.Width, pFeatEnv.Height))))
      Else
        dblSquareness = dblSquareness + 0.0001
      End If
      Set pFeat = pFeatCursor.NextFeature
    Wend
  Next j
  
  ' If the average envelope approximates a square set the grid size half
  ' way between the min and max sides. If the envelope is more rectangular,
  ' then set the grid size to half of the max.
  If ((dblSquareness / lngSampleSize) > 0.5) Then
    DefaultIndexGrid = (dblMinDelta + ((dblMaxDelta - dblMinDelta) / 2)) * Factor
  Else
    DefaultIndexGrid = (dblMaxDelta / 2) * Factor
  End If
End Function

Private Function Min(v1 As Variant, v2 As Variant) As Variant
  Min = IIf(v1 < v2, v1, v2)
End Function

Private Function Max(v1 As Variant, v2 As Variant) As Variant
  Max = IIf(v1 > v2, v1, v2)
End Function

Function DefaultIndexGridPoint(InFC As IFeatureClass) As Double
  ' Calculates the Index grid based on input feature class
  ' Get the dataset
  Dim pGeoDataSet As IGeoDataset
  Set pGeoDataSet = InFC
  ' Get the envelope of the input dataset
  Dim pEnvelope As IEnvelope
  Set pEnvelope = pGeoDataSet.Extent
  'Calculate approximate first grid
  Dim lngNumFeat As Long
  Dim dblArea As Double
  lngNumFeat = InFC.FeatureCount(Nothing)
  If lngNumFeat = 0 Or pEnvelope.IsEmpty Then
    ' when there are no features or an empty bnd - return 1000
    DefaultIndexGridPoint = 1000
  Else
    dblArea = pEnvelope.Height * pEnvelope.Width
    ' approximate grid size is the square root of area over the number of features
    DefaultIndexGridPoint = Sqr(dblArea / lngNumFeat)
  End If
  Set pGeoDataSet = Nothing
  Set pEnvelope = Nothing
 End Function


'************************************************************************************************'''
''拷贝一个FeatureClass，不使用Dataset
''纯粹的一边读取，一边写入，速度一般，不算很慢。
'************************************************************************************************'''

'''Public Function SDECopyFeature(ByVal strFeatureName As String, _
'''                                        ByRef pFWS As IFeatureWorkspace, _
'''                                        ByVal strMDBName As String, _
'''                                        ByVal FeatureType As Integer) As Long
'''On Error GoTo Error_h
''''　　" Connect to MDB
'''    Dim pWorkspaceFactory As IWorkspaceFactory
'''    Set pWorkspaceFactory = New AccessWorkspaceFactory
'''
'''    Dim pAccessWorkSpace As IFeatureWorkspace
'''    Set pAccessWorkSpace = pWorkspaceFactory.OpenFromFile(strMDBName, 0)
'''
'''    Dim pSDEFeatureClass As IFeatureClass
'''    Set pSDEFeatureClass = pFWS.OpenFeatureClass(strFeatureName)
'''
'''    If FeatureType = 0 Then   '" Point
'''        SDECreatePointFeatureClass strFeatureName, pAccessWorkSpace
'''    Else                '" Polygon
'''        SDECreatePolygonFeatureClass strFeatureName, pAccessWorkSpace, strFeatureName, pFWS
'''    End If
'''
'''    Dim pFeatureCursor As IFeatureCursor
'''    Set pFeatureCursor = pSDEFeatureClass.Search(Nothing, False)
'''
'''    Dim pAccessFeatureClass As IFeatureClass
'''    Set pAccessFeatureClass = pAccessWorkSpace.OpenFeatureClass(strFeatureName)
'''
'''    Dim pSDEFeat As IFeature
'''    Set pSDEFeat = pFeatureCursor.NextFeature
'''
'''    Dim pAccessFeat As IFeature
'''    Dim pos As Long
'''    Dim count As Long
'''    Dim i As Long
'''    While Not pSDEFeat Is Nothing
'''        Set pAccessFeat = pAccessFeatureClass.CreateFeature
'''        For i = 0 To pSDEFeat.Fields.FieldCount - 1
'''            If pSDEFeat.Fields.Field(i).Type <> esriFieldTypeGeometry And _
'''                pSDEFeat.Fields.Field(i).Type <> esriFieldTypeOID Then
'''                pos = pAccessFeat.Fields.FindFieldByAliasName(pSDEFeat.Fields.Field(i).name)
'''                If pos <> -1 Then pAccessFeat.Value(pos) = pSDEFeat.Value(i)
'''            End If
'''        Next i
'''        Set pAccessFeat.Shape = pSDEFeat.Shape
'''        count = count + 1
''''"　　　　Debug.Print Count
'''        pAccessFeat.Store
'''        Set pSDEFeat = pFeatureCursor.NextFeature
'''    Wend
'''
'''    Set pSDEFeat = Nothing
'''    SDECopyFeature = count
'''    Exit Function
'''Error_h:
'''    MsgLogOut MeName, "SDECopyFeature()", True
'''End

'************************************************************************************************'''
''加载DBF文件
''就是纯粹的数据表文件
'************************************************************************************************'''
Private Function CopyTable(pSrcWorkSpace As IFeatureWorkspace, _
                           pDstWorkSpace As IFeatureWorkspace, _
                           strTableName As String) As Boolean
On Error GoTo Error_h
'　　" Open Source Table
    Dim pDBFTable As ITable
    Set pDBFTable = pSrcWorkSpace.OpenTable(strTableName)
  
    Dim pDBFFields As IFields
    Set pDBFFields = pDBFTable.Fields
'　　" Open Destination Table
    Dim pSDETable As ITable
    If SDEFeatureExist(strTableName, pDstWorkSpace) Then
        Set pSDETable = pDstWorkSpace.OpenTable(strTableName)
    Else
'　　　　" If doesn"t exist , Create a New One
        Set pSDETable = pDstWorkSpace.CreateTable(strTableName, pDBFFields, Nothing, Nothing, "")
    End If
'　　" Select All rows from Source
    Dim pDBFCursor As ICursor
    Set pDBFCursor = pDBFTable.Search(Nothing, True)
  
    Dim pDBFRow As IRow
    Set pDBFRow = pDBFCursor.NextRow
'　　" Prepare Insert Cursor for Destination Table
    Dim pSDERow As IRow
    Dim pSDECursor As ICursor
    Set pSDECursor = pSDETable.Insert(False)
'　　" Copy Rows
    Dim i As Long
    Do Until pDBFRow Is Nothing
        Set pSDERow = pSDETable.CreateRow
        For i = 0 To pDBFFields.FieldCount - 1
            If Not pDBFFields.Field(i).Type = esriFieldTypeOID Then _
                pSDERow.Value(i) = pDBFRow.Value(i)
        Next i
        pSDECursor.InsertRow pSDERow
        Set pDBFRow = pDBFCursor.NextRow
    Loop
    CopyTable = True
    Exit Function
Error_h:
   MsgBox "fail to copy table"   'MsgLogOut "", "CopyTable", False, strTableName
End Function