Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: Save Embedded Documents

  1. #1
    Board Regular
    Join Date
    May 2013
    Posts
    97
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Save Embedded Documents

    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

  2. #2
    Moderator Macropod's Avatar
    Join Date
    Aug 2007
    Location
    Canberra, Australia
    Posts
    3,175
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Save Embedded Documents

    Cross-posted at: http://www.msofficeforums.com/word/4...side-word.html
    Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-a...rum-rules.html
    Cheers
    Paul Edstein
    [MS MVP - Word]

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •