shapefiletosde.frm

vb和arc objects开发的实用程序

        Else
           ' MsgBox "导入 " + pfeatureclass.AliasName + ":没有错误字段!", vbOKOnly, "字段错误检查"
        End If
        
        Dim pGeoField As IField
        Dim i As Integer
        For i = 0 To poutfields.FieldCount - 1
            If poutfields.Field(i).Type = esriFieldTypeGeometry Then
                Set pGeoField = poutfields.Field(i)
                Exit For
            End If
        Next i
    
        Dim pOutFCGeoDef As IGeometryDef
        Set pOutFCGeoDef = pGeoField.GeometryDef
        Dim pOutFCGeoDefEdit As IGeometryDefEdit
        Set pOutFCGeoDefEdit = pOutFCGeoDef
        pOutFCGeoDefEdit.GridCount = 1
        pOutFCGeoDefEdit.GridSize(0) = DefaultIndexGrid(pfeatureclass) '***************进行grid的设定
        '    pOutFCGeoDefEdit.GridSize(1) = 0
        '    pOutFCGeoDefEdit.GridSize(2) = 0
        Set pOutFCGeoDefEdit.SpatialReference = pGeoField.GeometryDef.SpatialReference '************进行参考系的设定
        
        Dim pFeatureDataConverter As IFeatureDataConverter
        Set pFeatureDataConverter = New FeatureDataConverter
        '  Set frmDatatoGDB.m_ActionObj = pFeatureDataConverter  '**************进度条的显示
        '  DoEvents
        Dim pQueryFilter As IQueryFilter
        Set pQueryFilter = New QueryFilter
        '  Dim strsub As String****************'控制生成的字段列表,和进行转换的图形满足条件的设定
        '  strsub = "Shape,Layer"
        '  pQueryFilter.SubFields = pFields.Field(0).AliasName + "," + pFields.Field(1).AliasName
        '  pQueryFilter.WhereClause = "Layer='ROADS'"
        '  pqueryfilter.AddField newfield
        Dim strcon As String
        strcon = "" '***************进行配置参数的设定

        Dim pEnumErrors As IEnumInvalidObject
        Set pEnumErrors = pFeatureDataConverter.ConvertFeatureClass(pinfcname, pQueryFilter, poutdatasetname, poutfcname, pOutFCGeoDef, poutfields, strcon, 100, 0)
      
        Dim pErrInfo As IInvalidObjectInfo
        Set pErrInfo = pEnumErrors.Next
        Dim errstr As String
        errstr = ""
        Do While Not pErrInfo Is Nothing
            errstr = errstr + CStr(pErrInfo.InvalidObjectID) + ":" + pErrInfo.ErrorDescription + vbCr
            Set pErrInfo = pEnumErrors.Next
        Loop
        If errstr <> "" Then
            MsgBox errstr, vbOKOnly, "导入中的feature错误"
        Else
            MsgBox "没有feature错误!", vbOKOnly, "导入中的feature错误"
        End If
        
    End If
    
    Next lnum
    
    'MsgBox "导入完成", vbOKOnly, "导入完成"

    Unload Me
 Exit Sub
errortip:
 MsgBox Err.Number + " " + Err.Description, vbInformation, "Shapefile入库"
 
 
 
End Sub

Private Sub Getlayers()

    If (Not m_pApp Is Nothing) Then
        Dim player As ILayer
        Dim layernumber As Long
        For layernumber = 0 To pmap.LayerCount - 1
            Set player = pmap.Layer(layernumber)
            lstlayers.AddItem player.Name
        Next layernumber
    End If

End Sub

Private Sub Form_Load()

    Me.lstlayers.Clear
'    txtserver.Text = ""
'    txtservice.Text = ""
'    txtuser.Text = ""
'    txtpassword.Text = ""
'    txtversion.Text = ""
    cmdoutput.Enabled = False
    
    If pmap.LayerCount = 0 Then
        Adddata
    Else
        Getlayers
    End If
    
End Sub

Private Sub Adddata()

    cdgbrouse.DialogTitle = "选择数据"
    cdgbrouse.InitDir = App.Path
    cdgbrouse.Filter = "shapefile|*.shp"
    cdgbrouse.FilterIndex = 0
    cdgbrouse.ShowOpen
    If cdgbrouse.FileName <> "" Then
        lstlayers.AddItem cdgbrouse.FileName
    End If
    
End Sub

Private Function GetName(sPath As String, iOption As Integer) As String
  
    Dim pos As Long
    pos = InStrRev(sPath, "\")
    Dim fname As String
    fname = Right(sPath, (Len(sPath) - pos))
    Dim pName As String
    pName = Left(sPath, pos - 1)
    
    If iOption = 0 Then
        GetName = pName
    Else
        GetName = fname
    End If
    
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

Private Function GetFieldError(eError As esriFieldNameErrorType) As String

    Dim strResult As String
    strResult = ""
    
    Select Case eError
        Case esriSQLReservedWord
        strResult = "是SQL保留关键字"
        Case esriDuplicatedFieldName
        strResult = "是重复字段名"
        Case esriInvalidCharacter
        strResult = "含有非法字符"
        Case esriInvalidFieldNameLength
        strResult = "字段名太长"
    End Select
    
    GetFieldError = strResult
    
End Function

Private Function islayer(str As String) As Boolean

  
    Dim i As Integer
    Dim bexisting As Boolean
    
    For i = 0 To pmap.LayerCount - 1
        If pmap.Layer(i).Name = str Then
        bexisting = True
        Exit For
        End If
    Next i
    islayer = bexisting
    
End Function

Private Function layerpos(str As String) As Integer

    Dim player As IFeatureLayer
    Dim i As Integer
    Dim pos As Integer
    
    For i = 0 To pmap.LayerCount - 1
        If pmap.Layer(i).Name = str Then
        pos = i
        Exit For
        End If
    Next i
    layerpos = pos
    
End Function

Public Function sdeConnect(ByRef pp As IPropertySet) As Boolean

    Dim pFact As IWorkspaceFactory
    Set pFact = New SdeWorkspaceFactory
    Dim ws As IWorkspace
    Set ws = pFact.Open(pp, 0)
    
    If ws Is Nothing Then
        MsgBox "SDE连接失败!"
        sdeConnect = False
    Else
        MsgBox "SDE连接成功!"
        sdeConnect = True
    End If
  
End Function