Save Embedded Documents

dhen21dx

Board Regular
Joined
May 10, 2013
Messages
134
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

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
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

Watch MrExcel Video

Forum statistics

Threads
1,108,954
Messages
5,525,877
Members
409,668
Latest member
mitunsLax

This Week's Hot Topics

Top