Option Explicit
Sub Export_CommentairesPicturesVPat()
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)
'suppression des fichier existants si le dossier existe
If Dir(DestFolderimage, vbDirectory) <> "" Then
If Dir(DestFolderimage & "\*.*") <> "" Then Kill DestFolderimage & "\*.*"
RmDir DestFolderimage
End If
'-------------------------------------------------------
'dézippage by patricktoulon(france)
Set UnZipeur = CreateObject("Shell.Application")
folderZipimage = UnZipeur.Namespace(sourceZip & "\xl").Items.Item("media").Path
'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
UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VMLREL)
drawing1VMLREL = DestFolderimage & "\vmlDrawing1.vml.rels"
drawing1VML = UnZipeur.Namespace(sourceZip & "\xl\drawings").Items.Item("vmlDrawing1.vml").Path
UnZipeur.Namespace(DestFolderimage & "\").CopyHere (drawing1VML)
drawing1VML = DestFolderimage & "\vmlDrawing1.vml"
corecteurVML drawing1VML
Set UnZipeur = Nothing
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
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
Set nodes = xmldoc.getelementsbytagname("shape")
For Each node In nodes
shapeId = Right(node.getattribute("id"), 4)
relId = node.ChildNodes(0).getattribute("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
Function corecteurVML(vml)
Dim xmldoc, nodes, node, imag, ro, x&, lines$, z, w
Set xmldoc = CreateObject("MSXML2.DOMDocument")
xmldoc.async = False
x = FreeFile: Open vml For Input As #x: lines = Input$(LOF(x), #x): Close #x
lines = Replace(Replace(Replace(lines, "v:", ""), "o:", ""), "x:", "")
lines = "<xml>" & Split(lines, "</shapetype>")(1)
For z = 1 To 1000
For w = 1 To 200
If Not lines Like "*relid=""rId" & w & Chr(34) & "*relid=""rId" & w & Chr(34) & "*" Then Exit For
lines = Replace(lines, "relid=""rId" & w & Chr(34) & " relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
lines = Replace(lines, "relid=""rId" & w & Chr(34) & " relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
lines = Replace(lines, "relid=""rId" & w & Chr(34) & " relid=""rId" & w & Chr(34), "relid=""rId" & w & Chr(34))
Next
Next
x = FreeFile: Open vml For Output As #x: Print #x, lines: Close #x
End Function