[XL-2007] Extraction données complexe dans fichier txt [Résolu]

[familledacp]

Bonjour à tous et à toutes

Je cherche à extraire des données dans un fichier texte de type dxf (il s'agit d'un format d'export d'autocad)

Les fichiers sont composés d'une succession de lignes et parfois très longs

J'en ai par exemple généré un qui fait 1 350 000 lignes.....

Je cherche à récupérer les lignes concernant un certain type de données et les insérer dans un fichier excel pour ensuite les retraiter

Il s'agit des lignes avec le texte "AcDbPolyline"

C'est ce que j'arrive à obtenir dans le code ci dessous

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub CommandButton4_Click()
 Dim ValeurLigne As String
  Dim Cellule As Range
 
  Set Cellule = Range("a2")
 
  Open "e:\dessin1.dxf" For Input As #1
  Do While Not EOF(1)
  Line Input #1, ValeurLigne
  If InStr(1, ValeurLigne, "AcDbPolyline") <> 0 Then
    Cellule = ValeurLigne
    Set Cellule = Cellule(2)
  End If
  Loop
  Close #1
 
End Sub

Je souhaite aller plus loin

A chaque fois qu'on trouve "AcDbPolyline", il faut récupérer
- la valeur située deux lignes au dessus (par exemple "essai calque" dans le fichier joint)
- les valeurs numériques situées sur la 8e ligne en dessous et toutes les 2 lignes juqu'à la 1ere ligne avec un mot (et non des valeurs numériques). Le nombre de lignes concernées varie d'un "paragraphe à l'autre)

Je mets à titre d'exemple un fichier dxf en pièce jointe.

Si vous avez des pistes, je suis preneur, et vous en remercie par avance.

Bonne journée

Daniel S

[AlainTech]

Bonjour,

Une idée:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
  Dim Cellule As Range
  Dim strLigneMoins1 As String
  Dim strLigneMoins2 As String
  Dim ValeurLigne As String
 
  Set Cellule = Range("a2")
 
  Open ThisWorkbook.Path & "\dessin1.dxf" For Input As #1
  Do While Not EOF(1)
    Line Input #1, ValeurLigne
    If InStr(1, ValeurLigne, "AcDbPolyline") <> 0 Then
      Cellule = ValeurLigne
      Cellule.Offset(0, 1) = strLigneMoins2
      Cellule.Offset(0, 2) = strLigneMoins1
      Set Cellule = Cellule(2)
    End If
    strLigneMoins2 = strLigneMoins1
    strLigneMoins1 = ValeurLigne
  Loop
  Close #1

[Qwazerty]

Salut

J'ai poursuivi le code d'AlainTech

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Sub teste()
  Dim Cellule As Range
  Dim strLigneMoins1 As String
  Dim strLigneMoins2 As String
  Dim ValeurLigne As String
  Dim ValeurAfterHeight As Variant
  Dim iEight As Integer
  Dim SheetResult As Worksheet
 
  Set SheetResult = ThisWorkbook.Sheets("Feuil1")
 
  Set Cellule = SheetResult.Range("a2")
  iEight = -1
 
  Open ThisWorkbook.Path & "\dessin1.dxf" For Input As #1
  Do While Not EOF(1)
    Line Input #1, ValeurLigne
 
    'Si on est en cours de recherche de la 8ème ligne
    If iEight > -1 Then iEight = iEight + 1
 
    If InStr(1, ValeurLigne, "AcDbPolyline") <> 0 Then
      Cellule = ValeurLigne
      Cellule.Offset(0, 1) = strLigneMoins2
      'Cellule.Offset(0, 2) = strLigneMoins1
      'Set Cellule = Cellule(2)
      iEight = 0
    End If
    strLigneMoins2 = strLigneMoins1
    strLigneMoins1 = ValeurLigne
 
    'On regarde si on a atteint la 8ème ligne ou une ligne paire suivant 8
    If (iEight >= 8) And (iEight Mod 2 = 0) Then
        'On verifie qu'une valeur numérique soit contenu (attention avec le séparateur numérique)
        'Par contre ici je suppose que les valeur ne prennent jamais 0 comme valeur (fait signe si ça ne va pas)
        If CStr(Val(ValeurLigne)) <> "0" Then
            'On a une valeur numérique
            SheetResult.Cells(Cellule.Row, Columns.Count).End(xlToLeft).Offset(0, 1) = ValeurLigne
        Else
            'La valeur n'est pas numérique, on stoppe la recherche
            iEight = -1
            'On passe à la ligne suivante
            Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
        End If
    End If
 
  Loop
  Close #1
 
  End Sub

++
Qwaz

[familledacp]

Bonjour à tous et toutes

Un énorme merci à AlainTech et Qwazerty

Je suis bluffé

Une précision complémentaire : il se peut qu'il y ait des valeurs "0" sur les coordonnées des polylignes à récupérer .... Il se peut aussi qu'il y ait des valeurs négatives aussi, mais ca, mon traitement ensuite sait les gérer (tableau croisé dynamique)

Sans abuser, s'il était possible de faire une petite modification, j'en serais très heureux ... si cela vous ennuie, je m'y plongerai .

Dans le cas de polylignes composées de plusieurs segments, le code que qwazerty a posté met les résultats sur une même ligne

S'il était possible de les décomposer sur plusieurs lignes (comme sur le tableau ci joint), cela serait super

Encore merci pour votre implication


Bonne journée

Daniel S

[did85]

Bonjour,
je ne sais pas si tu as plus de 6 segments. J'ai modifié le code que Qwazerty t'a passé pour ajouter uniquement 6 segments.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Sub test()
  Dim Cellule As Range
  Dim strLigneMoins1 As String
  Dim strLigneMoins2 As String
  Dim ValeurLigne As String
  Dim ValeurAfterHeight As Variant
  Dim iEight, iNbColonne As Integer
  Dim SheetResult As Worksheet
 
  Set SheetResult = ThisWorkbook.Sheets("Feuil1")
 
  Set Cellule = SheetResult.Range("a2")
  iEight = -1
 
  Open ThisWorkbook.Path & "\Dessin1.dxf" For Input As #1
  Do While Not EOF(1)
    Line Input #1, ValeurLigne
 
    'Si on est en cours de recherche de la 8ème ligne
    If iEight > -1 Then iEight = iEight + 1
 
    If InStr(1, ValeurLigne, "AcDbPolyline") <> 0 Then
      Cellule = ValeurLigne
      Cellule.Offset(0, 1) = strLigneMoins2
      'Cellule.Offset(0, 2) = strLigneMoins1
      'Set Cellule = Cellule(2)
      iEight = 0
    End If
    strLigneMoins2 = strLigneMoins1
    strLigneMoins1 = ValeurLigne
 
    'On regarde si on a atteint la 8ème ligne ou une ligne paire suivant 8
    If (iEight >= 8) And (iEight Mod 2 = 0) Then
        'On verifie qu'une valeur numérique soit contenu (attention avec le séparateur numérique)
        'Par contre ici je suppose que les valeur ne prennent jamais 0 comme valeur (fait signe si ça ne va pas)
        If CStr(Val(ValeurLigne)) <> "0" Then
            'On a une valeur numérique
            'Récupère le numéro de la dernière colonne remplie pour faire un tableau sur 4 colonnes
            iNbColonne = SheetResult.Cells(Cellule.Row, Columns.Count).End(xlToLeft).Column
            'On a atteint le quota de segment, on change de ligne
            If iNbColonne >= 6 Then
                Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
                'On recopie la ligne du dessus
                SheetResult.Cells(Cellule.Row, 1) = SheetResult.Cells(Cellule.Row - 1, 1)
                SheetResult.Cells(Cellule.Row, 2) = SheetResult.Cells(Cellule.Row - 1, 2)
                SheetResult.Cells(Cellule.Row, 4) = SheetResult.Cells(Cellule.Row - 1, iNbColonne)
                SheetResult.Cells(Cellule.Row, 3) = SheetResult.Cells(Cellule.Row - 1, iNbColonne - 1)
                iNbColonne = 4
            End If
            'On n'a pas atteint le quota de segments
            SheetResult.Cells(Cellule.Row, iNbColonne + 1) = ValeurLigne
        Else
            'La valeur n'est pas numérique, on stoppe la recherche
            iEight = -1
            'On passe à la ligne suivante
            Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
        End If
    End If
 
  Loop
  Close #1
 
  End Sub

Si tu as besoin de modifier la présentation, c'est ici que ça se passe :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 'Récupère le numéro de la dernière colonne remplie pour faire un tableau sur 4 colonnes
            iNbColonne = SheetResult.Cells(Cellule.Row, Columns.Count).End(xlToLeft).Column
            'On a atteint le quota de segment, on change de ligne
            If iNbColonne >= 6 Then
                Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
                'On recopie la ligne du dessus
                SheetResult.Cells(Cellule.Row, 1) = SheetResult.Cells(Cellule.Row - 1, 1)
                SheetResult.Cells(Cellule.Row, 2) = SheetResult.Cells(Cellule.Row - 1, 2)
                SheetResult.Cells(Cellule.Row, 4) = SheetResult.Cells(Cellule.Row - 1, iNbColonne)
                SheetResult.Cells(Cellule.Row, 3) = SheetResult.Cells(Cellule.Row - 1, iNbColonne - 1)
                iNbColonne = 4
            End If
            'On n'a pas atteint le quota de segments
            SheetResult.Cells(Cellule.Row, iNbColonne + 1) = ValeurLigne

Il faudrait que tu redonnes un .dxf plus complexe pour voir si ça colle.
Bon appétit.
Did85

[familledacp]

Re bonjour

Voici en pièce jointe un fichier dxf avec 2 polylignes, une de 12 segments, une de 6

Bon appétit

A bientot

Daniel S

[did85]

Dit-moi, je lis plus de 12 segments :
- la 1ere :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
calque essai
100
AcDbPolyline
 90
       13
 70
     0
 43
0.0
 10
463.446564814345
 20
456.2036655394668
 10
631.2222491820721
 20
990.420491791604
 10
884.8366530966924
 20
760.3563106107758
 10
978.4788936530622
 20
994.3198865462955
 10
736.5697654739778
 20
1189.289529514362
 10
600.0081651441615
 20
1154.194991301601
 10
518.0712003233256
 20
1384.25917248243
 10
966.773617917528
 20
1395.957349456772
 10
1329.637304407471
 20
1033.313812224016
 10
1193.075704077657
 20
772.0544875851182
 10
923.8542581440816
 20
608.2799880751208
 10
681.9451299649972
 20
690.1672414749864
 10
732.6680107479205
 20
444.5054885651233

La seconde :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
0
100
AcDbPolyline
 90
        7
 70
     0
 43
0.0
 10
1037.005295445464
 20
475.700632023193
 10
1314.030262388516
 20
701.8654184493288
 10
1434.984832256741
 20
592.6824163460869
 10
1314.030262388516
 20
471.8012372685007
 10
1645.679876397915
 20
436.7066990557396
 10
1782.241476727731
 20
752.5575283911248
 10
1618.367558643425
 20
830.5453797465652

Si c'est bien les valeurs 1 sur 2 à récupérer, c'est bien par groupe de 4 ? Et dans le cas où à la fin on n'en a pas 4, on reprend les valeurs de la ligne du dessus ? comme dans ton PDF ?

Merci

[familledacp]

Re bonjour

Non non, il y en a bien 12 ... pour le 1er code en tous cas (et 6 pour le second)

Je m'explique

Chaque segment est composé de 2 extrémités en x et y donc de 4 valeurs x départ, y départ, x arrivée et y arrivée

Et comme le segment repart du point d'arrivée du segment précédent on a , pour le 1er exemple

segment 1 (463.44 ; 456.20) vers (631.22 ; 990.42) soit lignes 11 13 15 et 17,
segment 2 (631.22 ; 990.42) vers (884.63 ; 760.35) soit lignes 15 17 19 et 21
et ainsi de suite

A votre disposition pour de plus amples renseignements

Daniel S

[Qwazerty]

Salut

Pour faire l'essai, j'ai rajouter

Code :

1
2
0
Fin

à la fin des polygones proposés.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Option Explicit
 
Sub teste()
  Dim Cellule As Range
  Dim strLigneMoins1 As String
  Dim strLigneMoins2 As String
  Dim ValeurLigne As String
  Dim ValeurAfterHeight As Variant
  Dim iEight As Integer
  Dim SheetResult As Worksheet
  Dim MemoType As String, MemoNom As String
 
  Set SheetResult = ThisWorkbook.Sheets("Feuil1")
 
  Set Cellule = SheetResult.Range("a2")
  iEight = -1
 
  Open ThisWorkbook.Path & "\dessin1.dxf" For Input As #1
  Do While Not EOF(1)
    Line Input #1, ValeurLigne
 
    'Si on est en cours de recherche de la 8ème ligne
    If iEight > -1 Then iEight = iEight + 1
 
    If InStr(1, ValeurLigne, "AcDbPolyline") <> 0 Then
      Cellule = ValeurLigne
      Cellule.Offset(0, 1) = strLigneMoins2
      MemoType = ValeurLigne
      MemoNom = strLigneMoins2
      'Cellule.Offset(0, 2) = strLigneMoins1
      'Set Cellule = Cellule(2)
      iEight = 0
    End If
    strLigneMoins2 = strLigneMoins1
    strLigneMoins1 = ValeurLigne
 
    'On regarde si on a atteint la 8ème ligne ou une ligne paire suivant 8
    If (iEight >= 8) And (iEight Mod 2 = 0) Then
        'On verifie qu'une valeur numérique soit contenu (attention avec le séparateur numérique)
        If (CStr(Val(ValeurLigne)) <> "0") Or (ValeurLigne = "0") Then
            'On a une valeur numérique
            SheetResult.Cells(Cellule.Row, Columns.Count).End(xlToLeft).Offset(0, 1) = ValeurLigne
            'Si on a un segment renseigné on passe à la ligne
            If SheetResult.Cells(Cellule.Row, Columns.Count).End(xlToLeft).Column = 6 Then
                'On passe à la ligne et on note de nouveau la valeur + les infos
                Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
                Cellule = MemoType
                Cellule.Offset(0, 1) = MemoNom
                'On reprend les coordonnées du dernier point
                Cellule.Offset(0, 2) = Cellule.Offset(-1, 4)
                Cellule.Offset(0, 3) = Cellule.Offset(-1, 5)
            End If
        Else
            'La valeur n'est pas numérique, on stoppe la recherche
            iEight = -1
            'On supprime les valeurs notées en trop
            Cellule.EntireRow.ClearContents
            'On passe à la ligne suivante
            Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
        End If
    End If
 
  Loop
  Close #1
 
  End Sub

++
Qwaz

[did85]

Voici une solution par tableau :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub test2()
 
  Dim Cellule As Range
  Dim strLigneMoins1 As String
  Dim strLigneMoins2 As String
  Dim ValeurLigne As String
  Dim ValeurAfterHeight As Variant
  Dim iEight, iNbColonne, i As Integer
  Dim SheetResult As Worksheet
  Dim TabValeur() As Variant
 
  Set SheetResult = ThisWorkbook.Sheets("Feuil1")
 
  Set Cellule = SheetResult.Range("a2")
  iEight = -1
 
  Open ThisWorkbook.Path & "\Dessin1.dxf" For Input As #1
  Do While Not EOF(1)
    Line Input #1, ValeurLigne
 
    'Si on est en cours de recherche de la 8ème ligne
    If iEight > -1 Then iEight = iEight + 1
 
    If InStr(1, ValeurLigne, "AcDbPolyline") <> 0 Then
      Cellule = ValeurLigne
      Cellule.Offset(0, 1) = strLigneMoins2
      'Cellule.Offset(0, 2) = strLigneMoins1
      'Set Cellule = Cellule(2)
      iEight = 0
    End If
    strLigneMoins2 = strLigneMoins1
    strLigneMoins1 = ValeurLigne
 
    'On regarde si on a atteint la 8ème ligne ou une ligne paire suivant 8
    If (iEight >= 8) And (iEight Mod 2 = 0) Then
        'On verifie qu'une valeur numérique soit contenu (attention avec le séparateur numérique)
        'Par contre ici je suppose que les valeur ne prennent jamais 0 comme valeur (fait signe si ça ne va pas)
        If CStr(Val(ValeurLigne)) <> "0" Then
            i = i + 1
            'Stocke les valeurs dans un tableau pour disposition en tableau dans le Else
            ReDim Preserve TabValeur(1 To i)
            TabValeur(i) = ValeurLigne
        Else
            'La valeur n'est pas numérique, on stoppe la recherche
            iEight = -1
            'on écrit les données
            For i = 1 To UBound(TabValeur)
                'Récupère le numéro de la dernière colonne remplie pour faire un tableau sur 4 colonnes
                iNbColonne = SheetResult.Cells(Cellule.Row, Columns.Count).End(xlToLeft).Column
                'Segment suivant
                If iNbColonne = 6 Then
                    'Change de ligne
                    Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
                    'Recopie ligne au dessus
                    SheetResult.Cells(Cellule.Row, 1) = SheetResult.Cells(Cellule.Row - 1, 1)
                    SheetResult.Cells(Cellule.Row, 2) = SheetResult.Cells(Cellule.Row - 1, 2)
                    i = i - 2
                    iNbColonne = 2
                End If
                SheetResult.Cells(Cellule.Row, iNbColonne + 1) = TabValeur(i)
            Next i
            'On passe à la ligne suivante
            Set Cellule = SheetResult.Cells(Cellule.Row + 1, "A")
            'on libère le tableau
            i = 0
            Erase TabValeur
        End If
    End If
 
  Loop
  Close #1
 
  End Sub

Qui te donne le tableau en pièce jointe
Cordialement
Did85

[familledacp]

Re bonjour

C'est fabuleux

Cela fonctionne parfaitement

Merci encore

Daniel S