sélections automatiques d'objets dans Word [Résolu]

[antoine.b]

Bonjour,

Après avoir parcouru les ressources et testé quelques solutions, je fais appel à vos lumières.
Pour un projet de recherche en linguistique, je cherche à supprimer automatiquement par une macro tous les tableaux d'un document Word, pour les rempalcer par une châine de type <TABLE>.
Idem pour les images (<PICTURE>) et les zones de textes créées grâce à la barre d'outils Dessin (<TEXTZONE>).
Le but est de pouvoir faire ça grâce à un petit bout de code en VBA, qui sera ensuite inséré dans une macro que j'ai déjà permettant d'appliquer le même traitement sur tous les documents d'un répertoire (code dispo sur simple demande).
J'ai trouvé sur ce forum le code suivant, que j'ai adapté :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
===début===
Sub select_table()
On Error Resume Next
For i = 1 To ActiveDocument.Tables.Count
ActiveDocument.Tables(i).Select
Selection.Tables(1).Delete
    Selection.TypeText Text:="<TABLE>"
If Err <> 0 Then
MsgBox "No table found"
Exit For
End If
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="MyTable" & CStr(i)
End With
Next
End Sub
===fin===

Mais il ne traite qu'un tableau sur deux -tous les tableaux impairs.
Quelqu'un a-t-il(elle) une idée?

Merci à tous de vos lumières.
ant.

[Heureux-oli]

Code :

1
2
3
4
5
6
7
8
9
10
11
Sub delTable()
Dim tbl As Table
 
For Each tbl In ActiveDocument.Tables
    tbl.Select
    tbl.Delete
    Selection.TypeText "<table>"
    Selection.TypeParagraph
Next tbl
 
End Sub

Voilà un code un peu plus court.
Je pense que dans ton code, le problème vient de

Code :

Selection.Tables(1).Delete

[antoine.b]

>> Voilà un code un peu plus court.

Super! Merci beaucoup, ça marche en effet beaucoup mieux.
Et pour les graphiques, illustrations etc, y aurait-il une commande adéquate ? J'ai essayé (naïvement?) de remplacer Table par Graphic, mais visiblement c'est pas ça.

[Heureux-oli]

Essaie dans l'aide de voir du coté de "Shapes"

[antoine.b]

Je viens de trouver, c'est ^g qui permet de repérer les graphiques, et dans le même ordre d'idée ^f pour les notes de bas de page.
Je publierai le code ici dès que j'aurais quelque chose de propre.

Merci encore!
ant.

[Heureux-oli]

ça marche aussi !!

[antoine.b]

Bon, voici où j'en suis. Un puriste dira certainement qu'on peut optimiser, mais je ne suis pas puriste ;-) et j'obtiens le résultat attendu.
Les différents process sont indiquées en remarque dans le code.

Merci de votre aide!

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Sub save_UTF8()
  a$ = Dir$("C:\test_macro\*.doc")
While a$ <> ""
     ChangeFileOpenDirectory "C:\test_macro\"
  Documents.Open filename:=a$, ConfirmConversions:=False, _
      ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
      PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
      WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
   'accept all changes
   Selection.WholeStory
   WordBasic.AcceptAllChangesInDoc
   'delete headers and footers
   ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
   Selection.WholeStory
   Selection.Delete Unit:=wdCharacter, Count:=1
   ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
   Selection.WholeStory
   Selection.Delete Unit:=wdCharacter, Count:=1
   ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  'replace tables by string <TABLE>
   Dim tbl As Table
   For Each tbl In ActiveDocument.Tables
   tbl.Select
   tbl.Delete
   Selection.TypeText "<!Table!>"
   Selection.TypeParagraph
   Next tbl
   ActiveDocument.Repaginate
  'detele footnotes
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^f"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'detele endnotes
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^e"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    'detele graphics
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^g"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
  'delete table of contents
    On Error Resume Next
    WordBasic.GotoTableOfContents
    Selection.Delete Unit:=wdCharacter, Count:=1
  'convert text box to frame
  For Each s In ActiveDocument.Shapes
    With s.TextFrame
         If .HasText Then s.ConvertToFrame
    End With
  Next
  'write down the output
   ChangeFileOpenDirectory "C:\test_macro\export\"
   ActiveDocument.SaveAs filename:=a$, FileFormat:=wdFormatText _
      , LockComments:=False, Password:="", AddToRecentFiles:=False, _
      WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
       SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
      False, Encoding:=65001, InsertLineBreaks:=False, AllowSubstitutions:=True _
      , LineEnding:=wdCRLF
   ActiveWindow.Close
        a$ = Dir$
Wend
End Sub