Hello,
Please help me, any one has idea on how to manage saving embedded files(PDF,Word,excel) in excel or word into a folder. I have below codes but it not saving the embedded files. Thanks
Please help me, any one has idea on how to manage saving embedded files(PDF,Word,excel) in excel or word into a folder. I have below codes but it not saving the embedded files. Thanks
Code:
Sub ExtractEmbeddedObjects()' The following macro extracts the embedded objects from all docx & docm files in that folder and outputs them
' to a new 'Embedded' folder in that folder. Each output file's name is prefixed with the parent
' document's name.
'
'Note: The macro only processes docx & docm files - doc files can't be processed this way (though they could be converted to the docx format for processing).
'
Application.ScreenUpdating = False
Dim SBar As Boolean ' Status Bar flag
Dim StrInFold As String, StrOutFold As String, StrTmpFold As String
Dim StrDocFile As String, StrZipFile As String, Obj_App As Object, i As Long
Dim StrFile As String, StrFileList As String, StrEmbedFile As String, j As Long
StrInFold = GetFolder
If StrInFold = "" Then Exit Sub
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
StrOutFold = StrInFold & "\Files"
StrTmpFold = StrInFold & "\Tmp"
'Test for existing tmp & output folders, create they if they don't already exist
If Dir(StrTmpFold, vbDirectory) = "" Then MkDir StrTmpFold
If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold
'Create a Shell App for accessing the zip archives
Set Obj_App = CreateObject("Shell.Application")
'Look for docx files to process
StrFile = Dir(StrInFold & "\*.doc?", vbNormal)
'Build the file list
While StrFile <> ""
StrFileList = StrFileList & "|" & StrFile
StrFile = Dir()
Wend
'process the file list
j = UBound(Split(StrFileList, "|"))
For i = 1 To j
'ID the document to process
StrDocFile = StrInFold & "\" & Split(StrFileList, "|")(i)
' Report progress on Status Bar.
Application.StatusBar = "Processing file " & i & " of " & j & ": " & StrDocFile
'Define the zip name
StrZipFile = Split(StrDocFile, ".")(0) & ".zip"
'In case the file is in use or zip file has no media
On Error Resume Next
'Create the zip file, by simply copying to a new file with a zip extension
FileCopy StrDocFile, StrZipFile
'Extract the zip archive's media files to the temporary folder
Obj_App.NameSpace(StrTmpFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\embeddings\").Items
'Delete the zip file - the loop takes care of timing issues
Do While Dir(StrZipFile) <> ""
Kill StrZipFile
Loop
'Restore error trapping
On Error GoTo 0
'Get the temporary folder's file listing
StrEmbedFile = Dir(StrTmpFold & "\*.*", vbNormal)
'Process the temporary folder's files
While StrEmbedFile <> ""
'Copy the file to the output folder, prefixed with the source file's name
FileCopy StrTmpFold & "\" & StrEmbedFile, StrOutFold & "\" & Split(Split(StrFileList, "|")(i), ".")(0) & StrEmbedFile
'Delete the media file
Kill StrTmpFold & "\" & StrEmbedFile
'Get the next media file
StrEmbedFile = Dir()
Wend
Next
'Delete the temporary folder
RmDir StrTmpFold
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function