' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Private Const projectClassName = "ExportImages"
Private Const projectClassVersion = "1.0"
Option Compare Text
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub ExportImages_files()
Dim file, files, destDirectories$
files = DialogExplorer(sFilter:="*.xlsx; *.xls; *.xlsm; *.xlsb")
destDirectories = ""
If IsArray(files) Then
ExportImagesByFiles files, "D", "G", 11, destDirectories
End If
End Sub
Sub ExportImages_folder()
Dim folder$, files(), destDirectories$
folder = DialogExplorer(FileDialog:=4)
destDirectories = ""
If folder <> "" Then
ListAllFiles folder, files, glbFSO, True
If (Not Not Files) Then ExportImagesByFiles files, "D", "G", 11, destDirectories
End If
End Sub
Private Sub ExportImagesByFiles(ByVal files, ByVal cellID$, ByVal cellImage$, ByVal startRow&, Optional ByVal destDirectories$)
Dim file
For Each file In files
ExportImages file, cellID, cellImage, startRow, destDirectories
Next
ActiveWorkbook.FollowHyperlink destDirectories, , True
MsgBox "Hoan thanh", , "ExportImages"
End Sub
Private Function ExportImages(ByVal fileName$, ByVal cellID$, ByVal cellImage$, ByVal startRow&, Optional destDirectories$) As Boolean
On Error Resume Next
Dim file$
Dim s$, s1$, s2$, s3$, s4$, re, re1, re2, re3, oFile As Object
Dim oFolder As Object, b As Boolean
Dim oSh, ms, ms2, FSO As Object, tPath, tPath2, fn$, fn2$, app As Object
Dim it, ZipFile, Ext$, xl_type&, i%
Dim fName$, cc&, cc2&, adr$, imExt$, DOM
adr = cellID 'Split(cellID.EntireColumn.Address(0, 0), ":")(0)
With ThisWorkbook.sheets(1)
cc = .Range(cellID & ":" & cellID).Column: cc2 = .Range(cellImage & ":" & cellImage).Column
End With
Set re = glbRegex
Set re1 = glbRegex
Set re2 = glbRegex(False)
Set re3 = glbRegex(False)
Set FSO = glbFSO
Set oSh = glbShellA
Set DOM = glbXMLDOM
'-----------------------------------------------
file = fileName
Select Case True
Case file Like "*.xla": xl_type = 18: Ext = ".xla": b = True
Case file Like "*.xlsb": xl_type = 50: Ext = ".xlsb": b = True
Case file Like "*.xlsx": xl_type = 51: Ext = ".xlsx"
Case file Like "*.xlsm": xl_type = 52: Ext = ".xlsm"
Case file Like "*.xlam": xl_type = 55: Ext = ".xlam"
Case file Like "*.xls": xl_type = 56: Ext = ".xls": b = True
Case Else: Exit Function
End Select
If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
With FSO
Set oFile = .GetFile(file)
If oFile Is Nothing Then Exit Function
fn = oFile.Name
If b Then fn = Replace(fn, Ext, ".xlsx", , , 1): Ext = ".xlsx"
fn2 = Left$(fn, Len(fn) - Len(Ext))
If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\images\"
CreateFolder destDirectories, FSO
tPath = Environ$("temp") & "\VBE\exportImages\"
tPath2 = tPath & fn2 & "\xl\"
CreateFolder tPath2, FSO
ZipFile = tPath & fn2 & "\" & fn & ".zip"
If b Then
Set app = CreateObject("Excel.Application")
With app
.EnableEvents = False
.DisplayAlerts = False
.Calculation = -4135
With .Workbooks.Open(fileName:=file, UpdateLinks:=False, ReadOnly:=True)
.SaveAs ZipFile, 51: .Close False
End With
.Quit
End With
Set app = Nothing
Else
.copyFile file, ZipFile, True
End If
End With
err.Clear: DoEvents:
oSh.Namespace(CVar(tPath2)).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items, 4 Or 16
Dim wbxml$, pwbxml$, pwbrels$, mmm, shrd
Dim shName$, shID$, ID$, shXML$, imageID$, j&, r&, c&
fName = tPath2 & "workbook.xml": GoSub readfile: pwbxml = s
fName = tPath2 & "_rels\workbook.xml.rels": GoSub readfile: pwbrels = s
fName = tPath2 & "sharedStrings.xml": GoSub readfile: shrd = s
're.Pattern = "<!--(.*?)-->|\r?\n\s*\B"
re.Pattern = "<sheet [^<>]*name=""((?:""""|[^""])+)"" [^<>]*sheetId=""([^""]+)"" [^<>]*r:id=""([^""]+)""[^<>]*/>"
re1.Pattern = "<xdr:from><xdr:col>(\d+)</xdr:col>.+?<xdr:row>(\d+)</xdr:row>.+?<xdr:cNvPr[^<>]* id=""([^""]*)""[^<>]* name=""([^""]*)""[^<>]*>.+?<a:blip [^<>]+r:embed=""([^""]+)""[^<>/]*/>"
re3.Pattern = "<Relationship[^<>]* Id=""([^""]+)"" [^<>]*Target=""\.\.\/drawings\/([^ ]+\.xml)""[^<>]*\/>"
Set ms = re.Execute(pwbxml)
If ms.count = 0 Then GoTo E
For i = 1 To ms.count
Set mmm = ms(i - 1).submatches
shName = mmm(0): shID = mmm(1): ID = mmm(2)
With re2
.Pattern = "<Relationship[^<>]* Id=""" & ID & """ [^<>]*Target=""worksheets\/([^ ]+\.xml)""[^<>]*\/>"
shXML = .Execute(pwbrels)(0).submatches(0)
fName = tPath2 & "worksheets\" & shXML: GoSub readfile: s1 = s
fName = Replace$(fName, "\worksheets\", "\worksheets\_rels\") & ".rels": GoSub readfile: s2 = s
fName = tPath2 & "drawings\" & re3.Execute(s2)(0).submatches(1): GoSub readfile: s3 = s
fName = Replace$(fName, "\drawings\", "\drawings\_rels\") & ".rels": GoSub readfile: s4 = s
Set ms2 = re1.Execute(s3)
For j = 1 To ms2.count
Set mmm = ms2(j - 1).submatches: r = mmm(1) + 1: c = mmm(0) + 1: imageID = mmm(4)
If r >= startRow And c = cc2 Then
.Pattern = "<Relationship[^<>]* Id=""" & imageID & """ [^<>]*Target=""\.\.\/media\/([^""/>]+(\.[^""/>]+))""[^<>]*\/>"
Set mmm = .Execute(s4)(0).submatches: fn2 = tPath2 & "media\" & mmm(0): imExt = mmm(1)
.Pattern = "<c r=""" & adr & CStr(r) & """[^>]+t=""([^""]*)"">(?:<f(?: [^>]+)?>.*?</f>)?<v>(.*?)</v></c>"
err.Clear: Set mmm = .Execute(s1)(0).submatches
fn = mmm(1)
If mmm(0) = "str" Then
Else
.Pattern = "(?:<si><t[^>]*>(?:\r|\n|.)+?</t></si>){" & CStr(CLng(fn)) & "}<si><t[^>]*>((?:\r|\n|.)+?)</t></si>"
fn = .Execute(shrd)(0).submatches(0)
End If
DoEvents: FSO.MoveFile fn2, destDirectories & Replace$(fn, vbNewLine, " ") & imExt
End If
Next
End With
Next
ExportImages = True
E:
FSO.GetFolder(tPath).Delete
Exit Function
readfile:
DOM.Load fName: s = DOM.xml
Return
End Function
Private Function CreateFolder(ByVal folderPath As String, Optional ByRef FileSystem As Object) As Boolean
Dim FolderArray, Tmp$, i As Integer, UB As Integer, tFolder$
tFolder = folderPath
If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
FolderArray = Split(tFolder, "\")
If FileSystem Is Nothing Then Set FileSystem = glbFSO
On Error GoTo Ends
FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
UB = UBound(FolderArray)
With FileSystem
For i = 0 To UB
Tmp = Tmp & FolderArray(i) & "\"
If Not .FolderExists(Tmp) Then DoEvents: .CreateFolder (Tmp)
CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
Next
End With
Ends:
End Function
Private Function glbRegex(Optional bglobal = True, Optional IgnoreCase = True, Optional MultiLine = True) As Object
Set glbRegex = CreateObject("VBScript.RegExp")
With glbRegex: .Global = bglobal: .IgnoreCase = IgnoreCase: .MultiLine = MultiLine: End With
End Function
Private Function glbFSO() As Object
Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Private Function glbShellA() As Object
Set glbShellA = CreateObject("Shell.Application")
End Function
Private Function StandardPath(ByVal Path As String) As String
StandardPath = Path & IIf(Right(Path, 1) <> "\", "\", "")
End Function
Private Function glbXMLDOM() As Object
Set glbXMLDOM = CreateObject("MSXML2.DOMDocument.6.0")
End Function
Private Function ThisPath(Optional ByVal fileName As String) As String
ThisPath = ThisWorkbook.Path & "\" & fileName
End Function
Private Function DialogExplorer(Optional folderPath$, _
Optional sDesc$ = "All File", _
Optional sFilter$ = "*.*", _
Optional Title$ = "File Open", _
Optional FileDialog& = 1, _
Optional InitialView& = 2, _
Optional ButtonName$ = "&Select", _
Optional MultiSelect As Boolean = -1) As Variant
DialogExplorer = ""
Dim arr(), k&, it
With Application.FileDialog(FileDialog) '1|4'
If ButtonName <> vbNullString Then .ButtonName = ButtonName
If FileDialog = 1 Then
.Filters.Clear
.Filters.Add sDesc, sFilter
If sDesc$ <> "All File" Then .Filters.Add "All File", "*.*"
End If
If Title <> vbNullString Then .Title = Title
.InitialView = InitialView 'msoFileDialogViewDetails'
.AllowMultiSelect = IIf(FileDialog = 4, False, MultiSelect)
If folderPath <> vbNullString Then
.InitialFileName = folderPath
Else
.InitialFileName = ThisWorkbook.Path ' Application.DefaultFilePath
End If
If .Show = -1 Then
If FileDialog = 4 Or Not MultiSelect Then
DialogExplorer = .SelectedItems(1)
Else
For Each it In .SelectedItems
k = k + 1: ReDim Preserve arr(1 To k): arr(k) = it:
Next it
DialogExplorer = arr
End If
End If
If FileDialog = 1 Then .Filters.Clear
End With
End Function
Private Sub ListAllFiles(ByVal Paths, _
ByRef files(), _
Optional ByVal FSO As Object, _
Optional ByVal IncludeSubfolders As Boolean = False)
On Error Resume Next
Dim r As Long, c%
Dim ItemName As String
Dim Item, folder, oFolder
'-------------------------------------------
If Not IsArray(Paths) Then Paths = Array(Paths)
r = 0: r = UBound(files)
For Each folder In Paths
Set oFolder = FSO.GetFolder(folder)
For Each Item In oFolder.files
ItemName = LCase(Item.Name)
If Not ItemName Like "[~.]*" Then
Select Case True
Case ItemName Like "*.xlsm", ItemName Like "*.xlsx", ItemName Like "*.xls", ItemName Like "*.xlsb"
r = r + 1: ReDim Preserve files(1 To r): files(r) = Item.Path
End Select
End If
Next Item
If IncludeSubfolders Then
For Each Item In oFolder.SubFolders
Call ListAllFiles(Item.Path, files, FSO, True)
Next Item
End If
Next folder
End Sub
