Option Explicit
Sub Export_PhotosVPat()
Dim oApp As Object, sourceZip$, folderZipimage$, DestFolderimage$, drawing1VML$, drawing1VMLREL$, i&
Dim UnZipeur As Object, bm As New cBenchmark
'les path
sourceZip = ThisWorkbook.Path & "\zzz.zip"
DestFolderimage = ThisWorkbook.Path & "\media"
'ThisWorkbook.SaveCopyAs sourceZip 'zippage du classeur dans son etat actuel(c'est un peu plus long mais a jour)
'FileCopy ThisWorkbook.FullName, sourceZip
CreateObject("Scripting.FileSystemObject").CopyFile ThisWorkbook.FullName, sourceZip, True 'OverWrite
'suppression des fichier existants si le dossier existe
If Dir(DestFolderimage, vbDirectory) <> "" Then Kill DestFolderimage & "\*.*": RmDir DestFolderimage
'-------------------------------------------------------
'dézippage by patricktoulon(france)
bm.Start
Set UnZipeur = CreateObject("Shell.Application")
'on va extraire le dossier "media" du zip qui contient toute les images a la racine du classeur
'chemin du dossier "media" dans le zip
folderZipimage = UnZipeur.Namespace(sourceZip & "\xl").Items.Item("media").Path
bm.TrackByName "Unzip Images"
'extraction du dossier media en entier
UnZipeur.Namespace(ThisWorkbook.Path & "\").CopyHere (folderZipimage)
Do While Dir(DestFolderimage, vbDirectory) = "" Or i < 1000: i = i + 1: DoEvents: Loop
If Dir(DestFolderimage, vbDirectory) = "" Then MsgBox "l 'extraction du dossier media c'est Mal passée" & vbCrLf & "sortie du programe!!": Set oApp = Nothing: Exit Sub
'chemin du vmlDrawing1.vml.rels
drawing1VMLREL = UnZipeur.Namespace(sourceZip & "\xl\drawings\_rels").Items.Item("vmlDrawing1.vml.rels").Path
'extraction du vmlDrawing1.vml.rels
UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VMLREL)
drawing1VMLREL = DestFolderimage & "\vmlDrawing1.vml.rels"
bm.TrackByName "Unzip VMLREL"
drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").Items.Item("vmlDrawing1.vml").Path
UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VML)
drawing1VML = DestFolderimage & "\vmlDrawing1.vml"
Set UnZipeur = Nothing
bm.TrackByName "Unzip VML"
Kill sourceZip
'fin de dézippage les VML compris
'----------------------------------------------------------
'copier les images
Dim DictShp As Object, DictFile As Object, Ccom As Object, Cel, Fname$
Set DictShp = CreateObject("Scripting.Dictionary")
Set DictFile = CreateObject("Scripting.Dictionary")
ChargerDicts drawing1VML, drawing1VMLREL, DictShp, DictFile
bm.TrackByName "ChargerDicts"
For Each Cel In [Tbl_Invendus[Désignation]]
Set Ccom = Cel.Comment
Select Case True
Case Ccom Is Nothing
Case Not Ccom.Shape.Fill.Type = msoFillPicture
Case Else
Fname = DictFile(DictShp(CStr(Ccom.Shape.id)))
FileCopy DestFolderimage & "\" & Fname, _
DestFolderimage & "\" & Cel & ".jpg"
End Select
Next
bm.TrackByName "Copier Images"
' Set docXML = CreateObject("MSXML2.DOMDocument")
' docXML.async = False
'x=freefile:open ddddd for input as #x:
' docXML.Load drawing1VMLREL
' Set relationships = docXML.getelementsbytagname("Relationship")
' For Each Elem In relationships
' Index = Val(Replace(Elem.getAttribute("Id"), "rId", ""))
' Image = ThisWorkbook.Path & Replace(Elem.getAttribute("Target"), "..", "")
' Name Image As DestFolderimage & "\" & [Tbl_Invendus[Désignation]].Cells(Index) & ".jpg"
' Next
Kill DestFolderimage & "\image*.*"
Kill drawing1VMLREL
Kill drawing1VML
Set DictShp = Nothing: Set DictFile = Nothing
MsgBox "Extraction des images de commentaires terminées"
End Sub
Sub ChargerDicts(vmlFile, vmlrelFile, DictShp, DictFile)
Dim fileName$, objName, relId$, shapeId$, XmlNamespaces$, res
Dim FSO As Object, xmlDoc As Object, nodes As Object, node As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
res = xmlDoc.Load(vmlFile)
If Not res Then MsgBox ("erreur Lecture fichier xml : " & vmlFile): End
XmlNamespaces = "xmlns:v='urn:schemas-microsoft-com:vml' xmlns:o='urn:schemas-microsoft-com:office:office'"
xmlDoc.SetProperty "SelectionNamespaces", XmlNamespaces
Set nodes = xmlDoc.SelectNodes("//v:shape")
For Each node In nodes
shapeId = Right(node.getAttribute("id"), 4)
relId = node.ChildNodes(0).getAttribute("o:relid")
'Debug.Print shapeId,relId
DictShp.Add shapeId, relId
Next
res = xmlDoc.Load(vmlrelFile)
If Not res Then MsgBox ("erreur Lecture fichier xml : " & vmlrelFile): End
Set nodes = xmlDoc.SelectNodes("//Relationship")
For Each node In nodes
fileName = FSO.GetFileName(node.getAttribute("Target"))
relId = node.getAttribute("Id")
'Debug.Print relId, fileName
DictFile.Add relId, fileName
Next
Set FSO = Nothing: Set nodes = Nothing: Set xmlDoc = Nothing
End Sub