Discussion :

[SilkyRoad]

bonsoir à toutes et à tous

je suis à la recherche de personnes disponibles pour tester la procédure ci joint.
Excel et Open Office doivent être installés sur le poste


Le sujet:

Lorsqu'un classeur est corrompu, Il est parfois possible d'en récupérer les données en l'ouvrant depuis la suite bureautique Open Office. Les macros sont aussi récupérables. Open office stocke tous les modules (standards et objets) mais chaque ligne est précédée de l'instruction REM.


La macro Excel ci dessous automatise le processus de récupération et de remise en forme.

Description:

1. Lancez la macro.
2. Sélectionnez le classeur qui vous pose problème (ou un classeur de test) dans la boite de dialogue.
3. Le classeur sélectionné va être ouvert dans Open Office
4. La procedure va créer un nouveau classeur.
5. Ensuite la macro boucle sur tous les modules du document scanné.
6. Des modules sont créés dans le nouveau classeur Excel afin d'importer les macros: (Les procédures evenementielles sont également importées dans des modules).
7. La procédure supprime toutes les instructions REM et remet en forme les modules
8. Open Office est refermé


Les procédures des UserForm sont aussi récupérées mais pas l'objet en lui même. (Ce n'est qu'un moindre mal s'il ne vous reste que les contrôles à repositionner dans la forme.)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
99
100
101
102
103
104
105
106
107
Option Explicit
Option Compare Text
 
 
Sub MacrosRecovery_Excel_OOo()
    '
    'SilkyRoad le 27.08.2006
    'macro testée avec Excel2002 et OOo 2.0.1
    '
    Dim serviceManager As Object, Desktop As Object
    Dim Document As Object
    Dim Fichier As String, Cible As String
    Dim Args()
    Dim Tableau()
    Dim I As Integer, x As Integer, J As Integer
    Dim Wb As Workbook
    Dim VBComp As Object
    Dim v As Integer, y As Integer
 
    'Boîte de dialogue pour sélectionner un classeur
    Fichier = _
    Application.GetOpenFilename("Classeurs Excel (*.xls), *.xls")
    If Fichier = "Faux" Then Exit Sub
 
    'Transforme le chemin du classeur au format URL
    Fichier = ConvertToURL(Fichier)
 
    'Création d'une instance Open Office
    Set serviceManager = CreateObject("com.sun.star.serviceManager")
    Set Desktop = _
    serviceManager.createInstance("com.sun.star.frame.Desktop")
 
   'Ouverture du fichier
    Set Document = _
    Desktop.loadComponentFromURL(Fichier, "_blank", 0, Args)
 
    'Récupère la liste des noms de modules dans un tableau.
    Tableau() = _
    Document.BasicLibraries.getByName("Standard").ElementNames
 
    'Création d'un nouveau classeur
    'qui va récupérer les macros importées.
    Set Wb = Workbooks.Add
 
    '------------------------
    'Boucle sur les noms de module pour en extraire le contenu
    For I = 0 To UBound(Tableau())
 
        'Crée des modules standard dans le nouveau classeur
        'afin de stocker les macros importées.
        '1= Module standard
        Set VBComp = Wb.VBProject.VBComponents.Add(1)
        'Renomme le module
        VBComp.Name = "Recup" & Tableau(I)
 
        'Insertion des procédures dans les modules
        With Wb.VBProject.VBComponents("Recup" & Tableau(I)).CodeModule
 
            'Fait le ménage: Suppression d'"Option Explicit"
            .DeleteLines 1, .CountOfLines
 
 
        'Import de la procédure et remise en forme dans le module
        .AddFromString _
        Document.BasicLibraries.getByName("Standard"). _
                getByName(Tableau(I))
 
            For J = .CountOfLines To 1 Step -1
                Cible = .Lines(J, 1)
 
                If Left(Cible, 17) = "Rem Attribute VBA" Then
                .DeleteLines J, 1
                Else
 
                    If Left(Cible, 3) = "Rem" Then
                        Cible = Mid(Cible, 4)
                        .ReplaceLine J, Cible
                        Else
                        .DeleteLines J, 1
                    End If
 
                End If
            Next J
        End With
 
        'Suppression des modules vides
        If VBComp.Type = 1 Then
            v = VBComp.CodeModule.CountOfDeclarationLines + 1
            y = VBComp.CodeModule.CountOfLines
            If y < v Then Wb.VBProject.VBComponents.Remove VBComp
        End If
    Next I
 
    DoEvents
    'Fermeture du document OOo
    Document.Close (False)
End Sub
 
 
Function ConvertToURL(Fichier As String)
    'fonction de conversion  au format URL
    Dim Cible As String
 
        Cible = Fichier
        Cible = Replace(Cible, "\", "/")
        ConvertToURL = "file:///" & Cible
End Function

actuellement testé avec Excel2002, WinXP & OOo2.0.1


Les amélorations à venir:
Pouvoir placer chaque procédure dans le type de module identique au classeur scanné: module standard, module de classe, modules objets (Feuilles, ThisWorkbook et UserForm)

Remarque:
Une autre solution pourrait consister à ouvrir le classeur dans OpenOffice et le réenregistrer au format .xls, vous permettant de récupérer aussi le contenu des feuilles.



toutes vos remarques sont les bienvenues.
d'avance merci.


en espérant que vous n'ayez jamais besoin de vous en servir réellement..;o)
bonne soiree
michel

[SilkyRoad]

bonsoir

Voici une nouvelle version qui permet de placer chaque procédure importée dans le bon type de module:
(module standard , module de classe , modules objets Feuille & ThisWorkbook )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
Option Explicit
Option Compare Text
 
 
Sub MacrosRecovery_Excel_OOo_V102()
    '
    'SilkyRoad le 28.08.2006
    'macro testée avec Excel2002 et OOo 2.0.1
    '
    Dim serviceManager As Object, Desktop As Object
    Dim Document As Object
    Dim Fichier As String, Cible As String, TypeMod() As String
    Dim Args()
    Dim Tableau()
    Dim I As Integer, x As Integer, J As Integer
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim VBComp As Object
    Dim v As Integer, y As Integer
 
 
    'Boîte de dialogue pour sélectionner un classeur sur le disque
    Fichier = _
    Application.GetOpenFilename("Classeurs Excel (*.xls), *.xls")
    If Fichier = "Faux" Then Exit Sub
 
    'Transforme le chemin du classeur au format URL
    Fichier = ConvertToURL(Fichier)
 
    'Création d'une instance Open Office
    Set serviceManager = CreateObject("com.sun.star.serviceManager")
    Set Desktop = _
    serviceManager.createInstance("com.sun.star.frame.Desktop")
 
   'Ouverture du fichier
    Set Document = _
        Desktop.loadComponentFromURL(Fichier, "_blank", 0, Args)
 
    'Récupère la liste des noms de modules dans un tableau.
    Tableau() = _
        Document.BasicLibraries.getByName("Standard").ElementNames
 
    'Création d'un nouveau classeur pour stocker les macros importées.
    Set Wb = Workbooks.Add(1)
 
 
    '------------------------
    'Boucle sur les noms de module pour en extraire le contenu
    For I = 0 To UBound(Tableau())
 
    TypeMod() = Split(Document.BasicLibraries.getByName("Standard"). _
                        getByName(Tableau(I)), vbCrLf)
    TypeMod() = Split(TypeMod(0), Chr(10))
 
    Select Case Mid(TypeMod(0), 30)
 
    Case "VBAClassModule" 'Module de classe
        Set VBComp = Wb.VBProject.VBComponents.Add(2)
        'Renomme le module de classe
        VBComp.Name = Mid(TypeMod(1), 5)
 
    Case "VBADocumentModule" 'ThisWorkbook & les feuilles
 
        If Mid(TypeMod(1), 5) = "ThisWorkbook" Then
            Set VBComp = Wb.VBProject.VBComponents("ThisWorkbook")
            Else
 
            Set Ws = Nothing
            On Error Resume Next
            Set Ws = Wb.Worksheets(Mid(TypeMod(1), 5))
            On Error GoTo 0
 
                If Ws Is Nothing Then
                    'Creation nouvelle feuille
                    Set Ws = Wb.Worksheets.Add
                    'Renomme la feuille et le CodeName
                    Ws.Name = Mid(TypeMod(1), 5)
                    Wb.VBProject.VBComponents(Ws.CodeName).Name = _
                        Mid(TypeMod(1), 5)
 
                    Set VBComp = _
                        Wb.VBProject.VBComponents(Mid(TypeMod(1), 5))
                Else
                    Set VBComp = _
                        Wb.VBProject.VBComponents(Mid(TypeMod(1), 5))
                End If
        End If
 
    Case "VBAModule" 'Module standard
        Set VBComp = Wb.VBProject.VBComponents.Add(1)
        'Renomme le module standard
        VBComp.Name = Mid(TypeMod(1), 5)
 
    Case "VBAFormModule" 'UserForm
        Set VBComp = Wb.VBProject.VBComponents.Add(3)
        'Renomme l'UserForm
        VBComp.Name = Mid(TypeMod(1), 5)
    End Select
 
 
    'Insertion des procédures dans les modules
    With Wb.VBProject.VBComponents(VBComp.Name).CodeModule
 
        'Fait le ménage: Suppression d'"Option Explicit"
        .DeleteLines 1, .CountOfLines
 
        'Import de la procédure et remise en forme dans le module
        .AddFromString _
        Document.BasicLibraries.getByName("Standard"). _
                        getByName(Tableau(I))
 
            For J = .CountOfLines To 1 Step -1
                Cible = .Lines(J, 1)
 
                If Left(Cible, 17) = "Rem Attribute VBA" Then
                .DeleteLines J, 1
                Else
 
                    If Left(Cible, 3) = "Rem" Then
                        Cible = Mid(Cible, 4)
                        .ReplaceLine J, Cible
                        Else
                        .DeleteLines J, 1
                    End If
 
                End If
            Next J
    End With
 
        'Suppression des modules vides
        If VBComp.Type = 1 Then
            v = VBComp.CodeModule.CountOfDeclarationLines + 1
            y = VBComp.CodeModule.CountOfLines
            If y < v Then Wb.VBProject.VBComponents.Remove VBComp
        End If
    Next I
 
    DoEvents
    'Fermeture du document OOo
    Document.Close (False)
 
End Sub
 
 
Function ConvertToURL(Fichier As String)
    'fonction de conversion  au format URL
    Dim Cible As String
 
        Cible = Fichier
        Cible = Replace(Cible, "\", "/")
        ConvertToURL = "file:///" & Cible
End Function

bonne soirée
michel