Le portail francophone de la géomatique

Public Sub test()

    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.fileexists("c:\temp\test.dbf") Then fso.deletefile "c:\temp\test.dbf", True
    
    Dim pmxdoc As IMxDocument
    Set pmxdoc = ThisDocument
    Dim pmap As IMap
    Set pmap = pmxdoc.FocusMap
    Dim player As ILayer
    Set player = pmap.Layer(0)
    Dim pfl As IFeatureLayer
    Set pfl = player
    Dim pgfl As IGeoFeatureLayer
    Set pgfl = pfl
    Dim pfr As IFeatureRenderer
    Set pfr = pgfl.Renderer
    Dim i As Integer
    Dim ptable As ITable
    Dim pwsf As IWorkspaceFactory
    Set pwsf = New ShapefileWorkspaceFactory
    Dim pws As IWorkspace
    Set pws = pwsf.OpenFromFile("c:\temp", 0)
    Dim pfldentete As IFieldEdit
    Dim pfldnom As IFieldEdit
    Dim pfieldsedit As IFieldsEdit
    Set pfieldsedit = New Fields
    
    Set pfldentete = New Field
    Set pfldnom = New Field
    
    With pfldentete
        .Name = "EN_TETE"
        .Type = esriFieldTypeString
        .Length = 30
    End With
    
    With pfldnom
        .Name = "NOM"
        .Type = esriFieldTypeString
        .Length = 30
    End With
    
    pfieldsedit.AddField pfldentete
    pfieldsedit.AddField pfldnom
    
    Dim pfields As IFields
    Set pfields = pfieldsedit
    
    Dim pfws As IFeatureWorkspace
    Set pfws = pws
    
    Set ptable = pfws.CreateTable("test", pfields, Nothing, Nothing, "")
    
    'Debug.Print ptable.Fields.FieldCount
    
    Dim pcursor As ICursor
    Set pcursor = ptable.Search(Nothing, True)
    Dim prow As IRow
        
    If TypeOf pfr Is UniqueValueRenderer Then
        Dim puvr As IUniqueValueRenderer
        Set puvr = pfr
        For i = 0 To puvr.ValueCount - 1
            Set prow = ptable.CreateRow
            'Debug.Print puvr.Heading(puvr.Value(i))
            prow.Value(1) = puvr.Heading(puvr.Value(i))
            'Debug.Print puvr.Value(i)
            prow.Value(2) = puvr.Value(i)
            prow.Store
        Next i
    Else
        Exit Sub
    End If
    
    Dim pli As ILegendInfo
    Set pli = pfr
    
    Debug.Print pli.LegendGroupCount
    Dim j As Integer
    
    For i = 0 To pli.LegendGroupCount - 1
        Debug.Print pli.LegendGroup(i).Heading
        Debug.Print pli.LegendGroup(i).ClassCount
        For j = 0 To pli.LegendGroup(i).ClassCount - 1
            Dim plegendclass As ILegendClass
            Set plegendclass = pli.LegendGroup(i).Class(j)
            Debug.Print plegendclass.Label
        Next j
    Next i
    
End Sub