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.
Voici la partie qui me pose problème avec plusieurs options mais aucune qui fonctionne.
A partir d'ici pas de test posible car message d'erreur sur la partie ci-dessus
Je suis preneur de toute solution.
Je vous remercie.
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.
Code:
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
Code:
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
Code:
DoEvents
End If
Next S
Application.ScreenUpdating = True
End Sub
Je suis preneur de toute solution.
Je vous remercie.
Pièces jointes
Dernière édition: