Save Embedded Documents

dhen21dx

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

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top