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 |
Partager