How to save Word document pictures to a folder RRS feed

  • Question

  • Hi everyone,

    I currently want to use Word VBA to save all pictures in a Word document to a folder.

    I know there is a way to save the document as html file, and also the changing extension way. But I want to know the macro codes of "Save as Picture" command, which is on the extended menu while right click on a picture.

    I tried to record macro but then I can't access the extended menu.

    So please help!



    Wednesday, March 8, 2017 7:35 AM


  • The following macro will extract all embedded media files from a set of selected .docx and/or .docm documents. After selecting the documents to process, the code extracts the images and outputs them to a new 'DocMedia' folder in that folder. Each output file's name is prefixed with the parent document's name. If the files have media other than images embedded, these will be extracted too. The macro does all this by saving a copy of the file as a zip archive, then extracting the content from there. Note that, the macro only processes .docx & .docm files - .doc files can't be processed this way.

    Sub ExtractDocxMedia()
    ' The following macro extracts the media objects from a docx or docm
    ' file and outputs them to a new 'Media' folder in the document's folder.
    ' The 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 StrInFold As String, StrMediaFold As String, StrTmpFold As String
    Dim StrDocFile As String, StrZipFile As String, Obj_App As Object
    Dim FoundFile As Variant, StrTmp As String, StrMediaFile As String
    'Create FileDialog object as File Picker dialog box
    With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
      'Use Show method to display File Picker dialog box and return user's action
      If .Show = -1 Then
        'Step through each string in the FileDialogSelectedItems collection
        For Each FoundFile In .SelectedItems
          StrDocFile = FoundFile
          StrInFold = Left(StrDocFile, InStrRev(StrDocFile, "\"))
          StrTmp = Split(Right(StrDocFile, Len(StrDocFile) - Len(StrInFold)), ".")(0)
          'Define the zip name
          StrZipFile = Split(StrDocFile, ".")(0) & ".zip"
          'Create the zip file, by simply copying to a new file with a zip extension
          FileCopy StrDocFile, StrZipFile
          StrMediaFold = StrInFold & "Media"
          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(StrMediaFold, vbDirectory) = "" Then MkDir StrMediaFold
          'Create a Shell App for accessing the zip archives
          Set Obj_App = CreateObject("Shell.Application")
          'Next, process any media
          On Error Resume Next 'In case the file is in use or zip file has no media
          'Extract the zip archive's media files to the temporary folder
          Obj_App.NameSpace(StrTmpFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\media\").Items
          On Error GoTo 0 'Restore error trapping
          'Delete the zip file - the loop takes care of timing issues
          Do While Dir(StrZipFile) <> ""
            Kill StrZipFile
          'Get the temporary folder's file listing
          StrMediaFile = Dir(StrTmpFold & "\*.*", vbNormal)
          'Process the temporary folder's files
          While StrMediaFile <> ""
            'Copy the file to the output folder, prefixed with the source file's name
            FileCopy StrTmpFold & "\" & StrMediaFile, StrMediaFold & "\" & StrTmp & StrMediaFile
            'Delete the media file
            Kill StrTmpFold & "\" & StrMediaFile
            'Get the next media file
            StrMediaFile = Dir()
          'Delete the temporary folder
          RmDir StrTmpFold
      End If
    End With
    Application.ScreenUpdating = True
    End Sub

    Paul Edstein
    [MS MVP - Word]

    Wednesday, March 8, 2017 8:05 AM