VBA - Rename Images With Paragraph Underneath it - Multiple Documents

[dj44]

Good day folks,

Paul made this superb program to take images out of documents.

And that does do a great job.

I just had a query.

I wanted to know how i may rename the images with the paragraph underneath it.

I found some code and did my ususual testing for many weeks.

now not too make so much of a dogs dinner I tried to keep things simple as laid out below

Sub Extract_Images()

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, StrMediaFile As String, j As Long
Dim arrCaptions() As String




StrInFold = GetFolder
If StrInFold = "" Then Exit Sub
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
StrOutFold = StrInFold & "\DocMedia"
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\media\").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
  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

       
       
     '========  Rename the Images using the Paragraph underneath the image
     
     '--- Idea Stolen from Greg :)
    

    'Store image caption names. The paragraph immediately following the shape paragraph defines the image caption.
     ReDim arrCaptions(ActiveDocument.InlineShapes.Count - 1)
      
      For lngIndex = 1 To ActiveDocument.InlineShapes.Count     'StrDocFile
      Set oRng = ActiveDocument.InlineShapes(lngIndex).Range     'StrDocFile
      oRng.Collapse wdCollapseEnd
     'Move range to start of caption paragraph text.
     oRng.Move wdParagraph, 1
     'Extend range to end of paragraph.
     oRng.MoveEndUntil Cset:=Chr(13), Count:=wdForward
     arrCaptions(lngIndex - 1) = oRng.Text
     Next lngIndex
   '---------------------------------------------


    FileCopy StrTmpFold & "\" & StrMediaFile, StrOutFold & "\" & Split(Split(StrFileList, "|")(i), ".")(0) & StrMediaFile
    'Delete the media file
    Kill StrTmpFold & "\" & StrMediaFile




    'Get the next media file
    StrMediaFile = 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


'http://windowssecrets.com/forums/showthread.php/144880-Macro-needed-to-find-embedded-MS-Word-graphics-and-save-out-to-a-file-name
End Function

I hope if its not too much trouble on some advice on how i can get my images renamed with the paragraph underneath it
That way i can easily find my images when i need to



thank you as always

[macropod]

The code you're using opens the document as a zip archive and extracts the images from that. There is no way for such a process to identify where in the document the image came from.

[dj44]

Hello Paul,
nice to see you.

oh thats such a shame.

Thats one thing word doesnt have the ability to rename your images as you put them in
then i could easily know which ones i wanted.

I do hate the image001,002 format
which image has my dog in it

ok well let me do some investigation maybe a different method to help me name my images easily
I could extract my image text and then later rename them some other way

but its only a problem becuase i have 10 documents and well now that becomes more complex

[macropod]

ok well let me do some investigation maybe a different method to help me name my images easily
I could extract my image text and then later rename them some other way

but its only a problem becuase i have 10 documents and well now that becomes more complex

At least the macro puts in each image in a folder with the same name as the document it came from...

[dj44]

It makes it very easy I can copy and paste my images on to the word document without having to save it manually to a folder

later extract all my images

But i created so many images

The only thing i can think of is after extraction -
a macro to look in each document and some how rename
image001 with paragraph named imagedesc1 - Annual Meeting
image002 with paragraph named imagedesc2 - Office Wall 3J


The images are in a subfolder within the same folder

If document name = folder name then
open document and look for these image descriptions
rename these images in a loop

i am thinking out loud...
I'll keep my eye out for anything of interest that may help solve this puzzle