NOMENCLATURES AUTOCAD VERS EXCEL

'**************************************
'*                                    *
'* EXPORT DE NOMENCLATURE AUTOCAD     *
'* VERS MICROSOFT EXCEL               *
'*                                    *
'* Ecrit par LEVEUGLE Damien (c) 2005 *
'*                                    *
'**************************************

Option Explicit

Public Enum EXCELCOL
    IGNORE = 0
    REFERE = 1
    REPER = 2
    DESIGN = 4
    MATIERE = 5
    NUM_DE_PLAN = 7
    CODE_ARTICLE = 9
    MASSE = 10
    DESCR = 11
End Enum

Public Sub subExtracToXL()
    
    '****************
    '* DECLARATIONS *
    '****************
    Const REEL69SS = "REEL_PARTREFERENCE"
    
    Dim objExelApp      As Excel.Application
    Dim objExelSheet    As Excel.Worksheet
    Dim gpCode(0)       As Integer
    Dim dataValue(0)    As Variant
    Dim groupCode       As Variant
    Dim dataCode        As Variant
    Dim MySelectionSet  As AcadSelectionSet
    Dim MyMPR           As McadPartReference
    Dim I               As Integer
    Dim LigneExcel      As Integer
    Dim ColonneExcel    As EXCELCOL

    '******************
    '* INITIALISATION *
    '******************
       
    On Error Resume Next    ' Gestion erreurs
    
    ThisDrawing.SelectionSets(REEL69SS).Delete
    Set MySelectionSet = ThisDrawing.SelectionSets.Add(REEL69SS)
    
    gpCode(0) = 0
    dataValue(0) = "ACMPARTREF"
    groupCode = gpCode
    dataCode = dataValue
    LigneExcel = 9
    ColonneExcel = IGNORE

    '*************
    '* SELECTION *
    '*************
    
    ThisDrawing.SelectionSets(REEL69SS).Select acSelectionSetAll, , , groupCode, dataCode
    If ThisDrawing.SelectionSets(REEL69SS).Count = 0 Then
        MsgBox "Aucune pièce dans la nomenclature présente.", vbInformation, "Pas de pièces"
        Exit Sub
    End If

    Err.Clear

    '*********************
    '* APPLICATION EXCEL *
    '*********************

    Set objExelApp = GetObject(, "excel.application") ' ouvre le classeur courant

    If Err Then    ' si excel non ouvert on en crée un !
        Err.Clear
        Set objExelApp = Nothing
        Set objExelApp = CreateObject("excel.application")
        If Err Then
            Err.Clear
            MsgBox "L'application Excel n'est pas présente sur votre poste", vbCritical, "EXCEL"
            Exit Sub
        End If
    End If

    objExelApp.Visible = True

    Set objExelSheet = objExelApp.ActiveSheet

    On Error GoTo 0
    
    '**********************************
    '* PLACE PIECE TROUVER DANS EXCEL *
    '**********************************
    
    For Each MyMPR In ThisDrawing.SelectionSets(REEL69SS)       ' Parcoure chaque ligne de la NT
        
        If IsEmpty(MyMPR.Data) Then
            MsgBox "Nomenclature vide", vbInformation, "Vide"
            GoTo final
        Else

            LigneExcel = LigneExcel + 1                         ' position dans excel

            objExelSheet.Cells(LigneExcel, 3).Value = MyMPR.Quantity

            For I = LBound(MyMPR.Data) To UBound(MyMPR.Data)    ' Lit chaque champs de la ligne

                Select Case MyMPR.Data(I, 0)
                    Case "REF": ColonneExcel = REFERE           ' Associe les champs de nomenclature AutoCAD
                    Case "REPERE": ColonneExcel = REPER         ' aux colonnes d'Excel
                    Case "NAME": ColonneExcel = DESIGN
                    Case "MATERIAL": ColonneExcel = MATIERE
                    Case "N°_DE_PLAN": ColonneExcel = NUM_DE_PLAN
                    Case "CODE_ARTICLE": ColonneExcel = CODE_ARTICLE
                    Case "MASS": ColonneExcel = MASSE
                    Case "DESCR": ColonneExcel = DESCR
                Case Else
                    ColonneExcel = IGNORE
                End Select

                If ColonneExcel <> IGNORE Then objExelSheet.Cells(LigneExcel, ColonneExcel).Value = MyMPR.Data(I, 1)

            Next I

        End If

    Next

'*******************
'* TRIE DANS EXCEL *
'*******************

    objExelSheet.Range("B10:J600").Sort Key1:=objExelSheet.Columns("B"), Order1:=xlAscending, MatchCase:=False, Orientation:=xlTopToBottom
    objExelSheet.Range("A10").Select
    
final:

    '*********************
    '* LIBERE LA MEMOIRE *
    '*********************

    Set objExelApp = Nothing
    Set objExelSheet = Nothing
    Set MySelectionSet = Nothing

End Sub