Le portail francophone de la géomatique

Public Sub ExportToExcel()
    
    ' Export selected or all features to Excel.
    Dim pApp As IApplication
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Dim pLayers As IEnumLayer
    Dim pUID As New UID
    Dim pEnumLayer As IEnumLayer
    Dim pLayer As ILayer
    Dim pFLayer As IFeatureLayer
    Dim pFeatSel As IFeatureSelection
    Dim pEF As IEnumFeature
    Dim pFeat As IFeature
    Dim pExcelApp As Excel.Application
    Dim pExcelWbk As Excel.Workbook
    
    Set pApp = Application
    Set pMxDoc = pApp.Document
    Set pMap = pMxDoc.FocusMap
    Set pEF = pMap.FeatureSelection
    Set pFeat = pEF.Next
    
    If pFeat Is Nothing Then
      Exit Sub
    End If
    
   Set pExcelApp = CreateObject("excel.application")
   Set pExcelWbk = pExcelApp.Workbooks.Add
        
    pUID = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}"
    Set pEnumLayer = pMap.Layers(pUID, True)
    pEnumLayer.Reset
    Set pFLayer = pEnumLayer.Next
    
    Do While Not pFLayer Is Nothing
      If pFLayer.Valid Then
        If TypeOf pFLayer Is IFeatureSelection Then
          Set pFeatSel = pFLayer
          If pFeatSel.SelectionSet.count > 0 Then
            ExportLayer pExcelWbk, pMxDoc, pFLayer
          End If
        End If
      End If
      Set pFLayer = pEnumLayer.Next
    Loop
    
    'Delete default worksheets
    pExcelApp.DisplayAlerts = False
    pExcelApp.Worksheets("Sheet1").Delete
    pExcelApp.Worksheets("Sheet2").Delete
    pExcelApp.Worksheets("Sheet3").Delete
    pExcelApp.DisplayAlerts = True
    
    'Make the first sheet active
    pExcelApp.Worksheets(1).Activate
    
    ' Make Excel visible
    pExcelApp.Application.Visible = True
End Sub
Public Sub ExportLayer(pExcelWbk As Excel.Workbook, pMxDoc As IMxDocument, pFLayer As IFeatureLayer)
    Dim pExcelApp As Excel.Application
    Dim pExcelSheet As Object
    Dim pFC As IFeatureClass
    Dim pFeatSel As IFeatureSelection
    Dim pDisplayTable As IDisplayTable
    Dim pTable As ITable
    Dim pCursor As ICursor
    Dim pFCursor As IFeatureCursor
    Dim pLayerFields As ILayerFields
    Dim pFieldInfo As IFieldInfo2
    Dim pCurField As iField
    Dim pFeat As IFeature
    Dim lrow As Long
    Dim lcol As Long
    Dim j As Long
    Dim pSubtypes As ISubtypes
    Dim lSubCode As Long
    Dim pTableProperties As ITableProperties
    Dim pEnumTableProperties As IEnumTableProperties
    Dim pTableProperty As ITableProperty
    Dim pTableChar As ITableCharacteristics
    Dim bUseDescriptions As Boolean
    Dim pDomain As IDomain
    Dim pCodedValueDomain As ICodedValueDomain
    Dim i As Integer
    Dim pTableFields As ITableFields
    
    'Add new excel worksheet for this layer
    Set pExcelApp = pExcelWbk.Application
    Set pExcelSheet = pExcelWbk.Sheets.Add(After:=pExcelWbk.Sheets(pExcelWbk.Sheets.count))
    pExcelSheet.Name = pFLayer.Name

    'Get Subtype info
    Set pFC = pFLayer.FeatureClass
    If TypeOf pFC Is ISubtypes Then
      Set pSubtypes = pFC
    Else
      Set pSubtypes = Nothing
    End If
    
    
    'Determine whether to use descriptions or codes for domains and subtypes
    bUseDescriptions = True
    Set pTableProperties = pMxDoc.TableProperties
    Set pEnumTableProperties = pTableProperties.IEnumTableProperties
    pEnumTableProperties.Reset
    Set pTableProperty = pEnumTableProperties.Next
    Do While Not pTableProperty Is Nothing
      If pTableProperty.FeatureLayer Is pFLayer Then
        Set pTableChar = pTableProperty
        bUseDescriptions = pTableChar.ShowCodedValueDomainDescriptions
      End If
      Set pTableProperty = pEnumTableProperties.Next
    Loop
    
    Set pFeatSel = pFLayer
 
    Set pDisplayTable = pFLayer
    Set pTable = pDisplayTable.DisplayTable
 
     'Get pTableFields so later we can determine whether that field is visible
    Set pLayerFields = pFLayer
    Set pTableFields = pFLayer
    
    'Set Excel pointer to first column
    lcol = 1
    
    'Loop through each field
    For j = 0 To pTableFields.FieldCount - 1
    'For j = 0 To pTable.Fields.FieldCount - 1
     Set pCurField = pTableFields.Field(j)
     'Debug.Print pCurField.Name
     
     'Skip blob and geometry fields
     If pCurField.Type <> esriFieldTypeBlob And pCurField.Type <> esriFieldTypeGeometry Then
            
          Set pDomain = pCurField.Domain
          If Not pDomain Is Nothing Then
           If TypeOf pCurField.Domain Is ICodedValueDomain Then
            Set pCodedValueDomain = pCurField.Domain
            'Debug.Print pCodedValueDomain.Name(0) & "  " & pCodedValueDomain.CodeCount
           End If
          End If
  
          'Write field alias name as Excel column header
          pExcelApp.Cells(1, lcol).Value = pTableFields.FieldInfo(j).Alias
          
          
          'Get all selected features for this layer (use iDisplayTable to get any joined data)
          pDisplayTable.DisplaySelectionSet.Search Nothing, True, pCursor
          Set pFCursor = pCursor
          
          Set pFeat = pFCursor.NextFeature
          
          'Write data values to Excel
          lrow = 2
          Do While Not pFeat Is Nothing
            If bUseDescriptions Then
              If Not pSubtypes Is Nothing Then 'Shapefiles and coverages will have pSubtypes = Nothing
                If pSubtypes.HasSubtype And pSubtypes.SubtypeFieldIndex = j Then
                  If Not IsNull(pFeat.Value(j)) Then 'Correction
                    lSubCode = pFeat.Value(j)
                  Else
                    lSubCode = pSubtypes.DefaultSubtypeCode
                  End If
                  pExcelApp.Cells(lrow, lcol).Value = pSubtypes.SubtypeName(lSubCode)
                Else
                  pExcelApp.Cells(lrow, lcol).Value = pFeat.Value(j)
                  If Not pCodedValueDomain Is Nothing Then
                    For i = 0 To pCodedValueDomain.CodeCount - 1
                      If pCodedValueDomain.Value(i) = pFeat.Value(j) Then
                        pExcelApp.Cells(lrow, lcol).Value = pCodedValueDomain.Name(i)
                        i = pCodedValueDomain.CodeCount
                      End If
                    Next i
                  End If
                End If
              Else
                pExcelApp.Cells(lrow, lcol).Value = pFeat.Value(j) 'Display raw value (shapefiles and coverages)
              End If
            Else
              pExcelApp.Cells(lrow, lcol).Value = pFeat.Value(j) 'Display raw value if desc not requested for table
            End If
            
            lrow = lrow + 1
            Set pFeat = pFCursor.NextFeature
          Loop
          
          'Resize column width to fit data
          pExcelSheet.Columns(lcol).AutoFit
          
          'Hide column if invisible in ArcMap
          If Not pTableFields.FieldInfo(j).Visible = True Then
              pExcelSheet.Columns(lcol).Hidden = True
          End If
          
          lcol = lcol + 1

     End If
    Next j


End Sub