VBA extraire objet incorporé (repertoire)

[darkjedi]

Bonjour à tous.
Grâce à ce forum j'ai pu développer quelques macros afin de me faciliter la vie au travail.
Merci à vous.

Aujourd'hui je me retrouve ici car malgré mes recherches sur internet je n'ai pas réussi à solutionner mon problème.

J'ai créé un classeur excel avec un fichier incorporé (fichier zip). J'ai réussi par le biais d'une macro à créér le repertoire de destination et à copier mon objet en question.
Mais je bloque sur la fonction coller dans le repertoire ce fichier.
Voici mon code qui me pose problème. En pièce jointe vous trouverez mon fichier en question. Dans celui-ci c'est le module 3 qui est problèmatique.

Option Explicit
'variable dezippage
Dim RepDestination As String
Dim RepDest As String
'variable pour shape
Dim S As Shape
Dim Obj As Object
Dim genre$
'variable objet
Dim oFSO As Object  'Scripting.FileSystemObject
Dim oFld As Variant
Dim oApp As Object

Sub RepertoireExiste(RepDestination As String)
     
     On Error Resume Next
     
     If Dir(RepDestination, vbDirectory) = "" Then
          MkDir (RepDestination)
     Else
          'Kill CheminDestination & "*.*"
          RmDir RepDestination
          MkDir RepDestination
          On Error GoTo 0
     End If

End Sub

Sub TestRun()
'Il ne faut pas oublier de rajouter la réference
'Miscrosoft Scripting runtime

     Application.ScreenUpdating = False
     
     Sheets("EMT").Unprotect
     'definition des chemins
     RepDestination = "C:" 'repertoire racine
     RepDest = "NETCOMM" 'sous repertoire à créer
     
     If VBA.Right(RepDestination, 1) <> Application.PathSeparator Then
     RepDestination = RepDestination & Application.PathSeparator & RepDest
     End If

     'If RepDestination <> "" Then
     'RepertoireExiste (RepDestination)
     'End If
     
          For Each S In Sheets("EMT").Shapes
               If S.Type = msoEmbeddedOLEObject Then
                    S.Select
                    Set Obj = Selection
                    'Obj.Verb Verb:=xlPrimary
                    Obj.Copy
                    genre$ = "INCORPORE"
                    
                    'Instanciation du FSO
                    Set oFSO = New Scripting.FileSystemObject   'CreateObject("Scripting.FileSystemObject")
                    'Accède au dossier
                    If oFSO.FolderExists(RepDestination) Then
                         Set oFld = oFSO.GetFolder(RepDestination)
                    Else
                         RepertoireExiste (RepDestination)
                    End If

Voici la partie qui me pose problème avec plusieurs options mais aucune qui fonctionne.

                    Set oApp = CreateObject("Shell.Application")
'oApp.Namespace(CVar(oFld)).CopyHere oApp(CVar(Obj)).Items
                    
                    'If Not oFSO.FolderExists(RepDestination) Then
                         'oFSO.CreateFolder (RepDestination)
                    'End If
                    
                    With oApp
                         .Content.Paste
                         .ActiveWindow.View.Type = 3
                         .SaveAs RepDestination & genre$ & "_" & CDbl(Now) & ".zip"
                         .Close
                    End With
                    'oFSO.CopyFolder Obj, RepDestination

A partir d'ici pas de test posible car message d'erreur sur la partie ci-dessus

                    DoEvents
                    
               End If
          Next S
     Application.ScreenUpdating = True

End Sub

Je suis preneur de toute solution.

Je vous remercie.

 

[darkjedi]

Re : VBA extraire objet incorporé (repertoire)

Bonjour,
Pas de solution en vue pour cette problématique ?
Quelles peuvent être les autres solutions alternatives pour extraire et installer une référence pour que mon fichier fonctionne ?