VBA code to extract images from word.

[mktmohit]

To be honest, I was seriously considering ignoring this thead due to lack of cooperation on your part. However the challenge was interesting so I stuck with it.

Here are some things that you should consider before posting again.

1. Answer the questions ask. Doing so may help you discover and resolve the confusion that peoople trying to help you are experiencing. Stamping your foot and endlessly repeating your same question does not help.

2. Provide helpful attachements. Sending a file with two .jpg images and three .png images with code to rename all as .png is not helpful.

3. Declare you're varialbes. I do, and I think most regulars here do, and getting your code with a bunch of undeclared variables is frustrating.

[vba]Sub SaveImage()
Dim strFullName As String, strFileName As String
Dim strBasePath As String, strDate As String
Dim strFolderName As String, strImageName As String
Dim x As Long
Dim oRng As Word.Range
Dim arrCaptions() As String
Dim strExt As String

ReDim arrCaptions(ActiveDocument.InlineShapes.Count - 1)
For x = 1 To ActiveDocument.InlineShapes.Count
Set oRng = ActiveDocument.InlineShapes(x).Range
oRng.Collapse wdCollapseEnd
oRng.MoveEndUntil Cset:="Screen", Count:=wdForward
oRng.Collapse wdCollapseEnd
oRng.MoveEndUntil Cset:=Chr(13), Count:=wdForward
arrCaptions(x - 1) = oRng.Text
Next x

strFullName = ActiveDocument.FullName
strFileName = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 5)
strBasePath = "C:\Users\Mohit\Desktop\"
strDate = Format(Now, "yyyy-mm-dd")
strFolderName = strDate & "_" & strFileName
'Delete the folder if it exists
On Error Resume Next
Kill strBasePath & strFolderName & "_files\*" 'Delete all files
RmDir strBasePath & strFolderName & "_files" 'Delete folder
On Error GoTo 0
'Save the current document.
ActiveDocument.Save
'Save in HTML format
ActiveDocument.SaveAs2 FileName:=strBasePath & strFolderName & ".html", FileFormat:=wdFormatHTML
ActiveDocument.Close
On Error Resume Next
Kill strBasePath & strFolderName & ".html"
Kill strBasePath & strFolderName & "_files\*.xml"
Kill strBasePath & strFolderName & "_files\*.html"
Kill strBasePath & strFolderName & "_files\*.thmx"
On Error GoTo 0
'Rename image Files
On Error GoTo Err_Ext
For x = 0 To UBound(arrCaptions)
strImageName = Replace(arrCaptions(x), ":", "-")
strExt = ".png"
Name strBasePath & strFolderName & "_files\image00" _
& x + 1 & strExt As strBasePath & strFolderName & "_files\" _
& strFileName & strImageName & strExt
Next
Word.Documents.Open (strFullName)
Word.Application.Visible = True
Word.Application.Activate
Exit Sub
Err_Ext:
strExt = ".jpg"
Resume
End Sub[/vba]

Greg,

Will take care of your points in future.

While running your code, it went for endless loop.

While debuuging the code i came to know that control is not able to come out from loop between below code
Name strBasePath & strFolderName & "_files\image00" _
& x + 1 & strExt As strBasePath & strFolderName & "_files\" _
& strFileName & strImageName & strExt
Next

AND

Err_Ext:
strExt = ".png"
Resume


Can you check once. Did you got my original question or shall i explain again???

[gmaxey]

The code runs without error on the last sample document that you posted. It contains two .jpg format files and three .png format files. Did you test on the same file?

[mktmohit]

The code runs without error on the last sample document that you posted. It contains two .jpg format files and three .png format files. Did you test on the same file?

Yes Greg,

I run that code in that doc only but it is going for endless loop.

I have checked again.

Can you please send me that doc again.

Thanks

[mktmohit]

The code runs without error on the last sample document that you posted. It contains two .jpg format files and three .png format files. Did you test on the same file?

Greg,
Loop problem has been sorted now.
I dont know how shall i show my thanks to you.
Thanks a million Greg sir.
Its working correct with the same name, but still i need some help as when i pasted more pictures on my doc it is going to endless loop again.

I have done lot of testing but cant able to find which things should i avoid while pasting images.

Please can you tell me which things should i avoid while pasting like space after image, size etc. so that endless loop will be avoided.

[gmaxey]

This is more complicated than I expected. While it doesn't occur in the document that you posted here, when I created and tested with a new document I discovered that when the HTML file is create that it will "typically" create two image files for each inlineshape in the active documet. This means if you have two images in the original file there will be four files in the extraction folder. I've managed to deal with a one for one count and a two for one count, but I can't be certain that there will always be two images files created for every inline shape. So, the following would fail in that situation.

Just be sure that the caption text is in the paragraph immediately following the inlineshape. With the exception of the ":" which I've addressed in the code, don't use text that would be an invalid file name character.


[vba]Sub ExtractImages()
Dim strFileNameAndPath As String, strFileName As String, strName As String
Dim strBasePath As String, strDate As String
Dim strExtractionFolder As String, strImageName As String
Dim bThumbnails As Boolean
Dim lngIndex As Long
Dim oRng As Word.Range
Dim arrCaptions() As String
Dim lngCount As Long

'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
Set oRng = ActiveDocument.InlineShapes(lngIndex).Range
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

strFileNameAndPath = ActiveDocument.FullName
'Define folder for extracted images.
strBasePath = SpecialFolderPath & Application.PathSeparator
strDate = Format(Now, "yyyy-mm-dd")
strFileName = GetFileNameWithoutExtension(ActiveDocument.Name)
strExtractionFolder = strDate & "_" & strFileName

'Delete the folder if it exists.
On Error Resume Next
'Delete any files.
Kill strBasePath & strExtractionFolder & "_files\*"
RmDir strBasePath & strExtractionFolder & "_files"
On Error GoTo 0

'Save the current document.
ActiveDocument.Save

'Save document in HTML format. This creates the "_files\" folder in the Extraction Folder.
ActiveDocument.SaveAs2 filename:=strBasePath & strExtractionFolder & ".html", FileFormat:=wdFormatHTML

ActiveDocument.Close

On Error Resume Next
'Get rid of extraneous data files. Keep only the images.
Kill strBasePath & strExtractionFolder & ".html"
Kill strBasePath & strExtractionFolder & "_files\*.xml"
Kill strBasePath & strExtractionFolder & "_files\*.html"
Kill strBasePath & strExtractionFolder & "_files\*.thmx"
On Error GoTo 0

'Rename image files.
'When converting to HTML format images in the original document may be duplicated as thumbnails in the HTML file.
'We need to get if the image file count mathches the original InlineShape count of the document.
lngCount = Count_Files(strBasePath & strExtractionFolder & "_files")
Select Case True
Case lngCount = UBound(arrCaptions) + 1
'Image count matches so do a one for one rename.
lngIndex = 0
strName = Dir(strBasePath & strExtractionFolder & "_files\")
While strName <> ""
'Some characters are invalid in file names. A colon is invalid and could be used in the caption e.g., Screenshot 1: The Mona Lisa"
strImageName = Replace(arrCaptions(lngIndex), ":", "-")
Name strBasePath & strExtractionFolder & "_files\" & strName As strBasePath & strExtractionFolder & "_files\" & strImageName & ".png"
strName = Dir()
lngIndex = lngIndex + 1
Wend
Case lngCount = 2 * (UBound(arrCaptions) + 1)
'Duplicates where created.
lngIndex = 0
bThumbnails = True
strName = Dir(strBasePath & strExtractionFolder & "_files\")
While strName <> ""
'strExt = ".png"
strImageName = Replace(arrCaptions(lngIndex), ":", "-")
If bThumbnails Then
Name strBasePath & strExtractionFolder & "_files\" & strName As strBasePath & strExtractionFolder & "_files\" & strImageName & ".png"
Else
Name strBasePath & strExtractionFolder & "_files\" & strName As strBasePath & strExtractionFolder & "_files\" & strImageName & " thumbnail" & ".png"
End If
strName = Dir()
If Not bThumbnails Then lngIndex = lngIndex + 1
bThumbnails = Not bThumbnails
Wend
Case Else
MsgBox "File count mismatch occurred. Images were not renamed."
End Select
Word.Documents.Open (strFileNameAndPath)
Word.Application.Visible = True
Word.Application.Activate
Exit Sub
lbl_Exit:
Exit Sub
End Sub
Function Count_Files(strFolder As String) As Long
Dim strName As String
Dim lngCount As Integer

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
lngCount = 0
strName = Dir(strFolder)
While strName <> ""
lngCount = lngCount + 1
strName = Dir()
Wend
Count_Files = lngCount
lbl_Exit:
Exit Function
End Function
Function GetFileNameWithoutExtension(ByRef strFileName As String) As String
On Error GoTo Err_NoExtension
GetFileNameWithoutExtension = VBA.Left(strFileName, (InStrRev(strFileName, ".", -1, vbTextCompare) - 1))
lbl_Exit:
Exit Function
Err_NoExtension:
GetFileNameWithoutExtension = strFileName
Resume lbl_Exit
End Function
Function SpecialFolderPath() As String
Dim objWSHShell As Object
Dim strSpecialFolderPath

Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop")
Set objWSHShell = Nothing
lbl_Exit:
Exit Function
End Function[/vba]

[gmaxey]

Ok, it seems that changing the fileformat to wdFilteredHTML prevents the duplicate files:

[VBA]Sub ExtractImages()
Dim strFileNameAndPath As String, strFileName As String, strName As String
Dim strBasePath As String, strDate As String
Dim strExtractionFolder As String, strImageName As String
Dim lngIndex As Long
Dim oRng As Word.Range
Dim arrCaptions() As String

'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
Set oRng = ActiveDocument.InlineShapes(lngIndex).Range
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

strFileNameAndPath = ActiveDocument.FullName
'Define folder for extracted images.
strBasePath = SpecialFolderPath & Application.PathSeparator
strDate = Format(Now, "yyyy-mm-dd")
strFileName = GetFileNameWithoutExtension(ActiveDocument.Name)
strExtractionFolder = strDate & "_" & strFileName

'Delete the folder if it exists.
On Error Resume Next
'Delete any files.
Kill strBasePath & strExtractionFolder & "_files\*"
RmDir strBasePath & strExtractionFolder & "_files"
On Error GoTo 0

'Save the current document.
ActiveDocument.Save

'Save document in HTML format. This creates the "_files\" folder in the Extraction Folder.
ActiveDocument.SaveAs2 filename:=strBasePath & strExtractionFolder & ".html", FileFormat:=wdFormatFilteredHTML

ActiveDocument.Close

On Error Resume Next
'Get rid of extraneous data files. Keep only the images.
Kill strBasePath & strExtractionFolder & ".html"
Kill strBasePath & strExtractionFolder & "_files\*.xml"
Kill strBasePath & strExtractionFolder & "_files\*.html"
Kill strBasePath & strExtractionFolder & "_files\*.thmx"
On Error GoTo 0

'Rename image files.
lngIndex = 0
strName = Dir(strBasePath & strExtractionFolder & "_files\")
While strName <> ""
'Some characters are invalid in file names. A colon is invalid and could be used in the caption e.g., Screenshot 1: The Mona Lisa"
strImageName = Replace(arrCaptions(lngIndex), ":", "-")
Name strBasePath & strExtractionFolder & "_files\" & strName As strBasePath & strExtractionFolder & "_files\" & strImageName & ".png"
strName = Dir()
lngIndex = lngIndex + 1
Wend
Word.Documents.Open (strFileNameAndPath)
Word.Application.Visible = True
Word.Application.Activate
Exit Sub
lbl_Exit:
Exit Sub
End Sub
Function GetFileNameWithoutExtension(ByRef strFileName As String) As String
On Error GoTo Err_NoExtension
GetFileNameWithoutExtension = VBA.Left(strFileName, (InStrRev(strFileName, ".", -1, vbTextCompare) - 1))
lbl_Exit:
Exit Function
Err_NoExtension:
GetFileNameWithoutExtension = strFileName
Resume lbl_Exit
End Function
Function SpecialFolderPath() As String
Dim objWSHShell As Object
Dim strSpecialFolderPath

Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop")
Set objWSHShell = Nothing
lbl_Exit:
Exit Function
End Function[/VBA]

[mktmohit]

Ok, it seems that changing the fileformat to wdFilteredHTML prevents the duplicate files:

[VBA]Sub ExtractImages()
Dim strFileNameAndPath As String, strFileName As String, strName As String
Dim strBasePath As String, strDate As String
Dim strExtractionFolder As String, strImageName As String
Dim lngIndex As Long
Dim oRng As Word.Range
Dim arrCaptions() As String

'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
Set oRng = ActiveDocument.InlineShapes(lngIndex).Range
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

strFileNameAndPath = ActiveDocument.FullName
'Define folder for extracted images.
strBasePath = SpecialFolderPath & Application.PathSeparator
strDate = Format(Now, "yyyy-mm-dd")
strFileName = GetFileNameWithoutExtension(ActiveDocument.Name)
strExtractionFolder = strDate & "_" & strFileName

'Delete the folder if it exists.
On Error Resume Next
'Delete any files.
Kill strBasePath & strExtractionFolder & "_files\*"
RmDir strBasePath & strExtractionFolder & "_files"
On Error GoTo 0

'Save the current document.
ActiveDocument.Save

'Save document in HTML format. This creates the "_files\" folder in the Extraction Folder.
ActiveDocument.SaveAs2 filename:=strBasePath & strExtractionFolder & ".html", FileFormat:=wdFormatFilteredHTML

ActiveDocument.Close

On Error Resume Next
'Get rid of extraneous data files. Keep only the images.
Kill strBasePath & strExtractionFolder & ".html"
Kill strBasePath & strExtractionFolder & "_files\*.xml"
Kill strBasePath & strExtractionFolder & "_files\*.html"
Kill strBasePath & strExtractionFolder & "_files\*.thmx"
On Error GoTo 0

'Rename image files.
lngIndex = 0
strName = Dir(strBasePath & strExtractionFolder & "_files\")
While strName <> ""
'Some characters are invalid in file names. A colon is invalid and could be used in the caption e.g., Screenshot 1: The Mona Lisa"
strImageName = Replace(arrCaptions(lngIndex), ":", "-")
Name strBasePath & strExtractionFolder & "_files\" & strName As strBasePath & strExtractionFolder & "_files\" & strImageName & ".png"
strName = Dir()
lngIndex = lngIndex + 1
Wend
Word.Documents.Open (strFileNameAndPath)
Word.Application.Visible = True
Word.Application.Activate
Exit Sub
lbl_Exit:
Exit Sub
End Sub
Function GetFileNameWithoutExtension(ByRef strFileName As String) As String
On Error GoTo Err_NoExtension
GetFileNameWithoutExtension = VBA.Left(strFileName, (InStrRev(strFileName, ".", -1, vbTextCompare) - 1))
lbl_Exit:
Exit Function
Err_NoExtension:
GetFileNameWithoutExtension = strFileName
Resume lbl_Exit
End Function
Function SpecialFolderPath() As String
Dim objWSHShell As Object
Dim strSpecialFolderPath

Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop")
Set objWSHShell = Nothing
lbl_Exit:
Exit Function
End Function[/VBA]

Greg,

Thanks, now its working fine on one of the document, I will test on other documents and will let u know if any issues occurs.

Thank you Greg, you simply awesome

[mktmohit]

Greg,

Thanks, now its working fine on one of the document, I will test on other documents and will let u know if any issues occurs.

Thank you Greg, you simply awesome

Greg,

I have tested your code in other documents, i came to know that some files are naming conventions are wrong, means image name went ahead from the image itself. E.g name of image one is given to the name of image 3 or 4.

Secondly, code is still stucking giving mostly two type of errors "Invalid call procedure" and "File already exist".

According to your code please let me know what points should we keep in mind while preparing docs.

latest test result
=============
Docs having 200 images, when run the code till 130 images name were there acc. to that present in the doc(With some errors as described above) after that images were saved as image131 image132 and so on.


Greg please let have some change in code or tell me what points should i keep in mind while adding images to our docs.

Greg, we already reached near end, please help here also so that w can finish it off.
Thanks

[gmaxey]

I don't really know what else that I can do for you. Needless to say, I've spent considerably more free time on this than I could afford.

You need to set stops or breaks in the code and see if you can identify where and why the errors occur. Ensure you have no invalid characters in your caption text. I don't recall what all are invalid but for example "\" is invalid as well as ":"

[mktmohit]

I don't really know what else that I can do for you. Needless to say, I've spent considerably more free time on this than I could afford.

You need to set stops or breaks in the code and see if you can identify where and why the errors occur. Ensure you have no invalid characters in your caption text. I don't recall what all are invalid but for example "\" is invalid as well as ":"

Greg,

Thank you for your time, i have made necessary changes in it, now its working fine.

Thank you all who replied and viewed my thread, thank you vba express

[mesp9942]

Hi,
Greg-I am wondering if you have a suggestion how to then replace the images with a string in the format "{{imagename}}". For example I would want to replace image001 with "{{image001.jpg}}". My images are in different formats so I would somehow need to figure out how to name them with their respective extensions. Either that, or convert all the images to the same extension/format.
Any suggestions for code that would work?
Thanks,
Meghan

[ced]

thank you greg for this great job

Ok, it seems that changing the fileformat to wdFilteredHTML prevents the duplicate files:

[VBA]Sub ExtractImages()
Dim strFileNameAndPath As String, strFileName As String, strName As String
Dim strBasePath As String, strDate As String
Dim strExtractionFolder As String, strImageName As String
Dim lngIndex As Long
Dim oRng As Word.Range
Dim arrCaptions() As String

'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
Set oRng = ActiveDocument.InlineShapes(lngIndex).Range
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

strFileNameAndPath = ActiveDocument.FullName
'Define folder for extracted images.
strBasePath = SpecialFolderPath & Application.PathSeparator
strDate = Format(Now, "yyyy-mm-dd")
strFileName = GetFileNameWithoutExtension(ActiveDocument.Name)
strExtractionFolder = strDate & "_" & strFileName

'Delete the folder if it exists.
On Error Resume Next
'Delete any files.
Kill strBasePath & strExtractionFolder & "_files\*"
RmDir strBasePath & strExtractionFolder & "_files"
On Error GoTo 0

'Save the current document.
ActiveDocument.Save

'Save document in HTML format. This creates the "_files\" folder in the Extraction Folder.
ActiveDocument.SaveAs2 filename:=strBasePath & strExtractionFolder & ".html", FileFormat:=wdFormatFilteredHTML

ActiveDocument.Close

On Error Resume Next
'Get rid of extraneous data files. Keep only the images.
Kill strBasePath & strExtractionFolder & ".html"
Kill strBasePath & strExtractionFolder & "_files\*.xml"
Kill strBasePath & strExtractionFolder & "_files\*.html"
Kill strBasePath & strExtractionFolder & "_files\*.thmx"
On Error GoTo 0

'Rename image files.
lngIndex = 0
strName = Dir(strBasePath & strExtractionFolder & "_files\")
While strName <> ""
'Some characters are invalid in file names. A colon is invalid and could be used in the caption e.g., Screenshot 1: The Mona Lisa"
strImageName = Replace(arrCaptions(lngIndex), ":", "-")
Name strBasePath & strExtractionFolder & "_files\" & strName As strBasePath & strExtractionFolder & "_files\" & strImageName & ".png"
strName = Dir()
lngIndex = lngIndex + 1
Wend
Word.Documents.Open (strFileNameAndPath)
Word.Application.Visible = True
Word.Application.Activate
Exit Sub
lbl_Exit:
Exit Sub
End Sub
Function GetFileNameWithoutExtension(ByRef strFileName As String) As String
On Error GoTo Err_NoExtension
GetFileNameWithoutExtension = VBA.Left(strFileName, (InStrRev(strFileName, ".", -1, vbTextCompare) - 1))
lbl_Exit:
Exit Function
Err_NoExtension:
GetFileNameWithoutExtension = strFileName
Resume lbl_Exit
End Function
Function SpecialFolderPath() As String
Dim objWSHShell As Object
Dim strSpecialFolderPath

Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop")
Set objWSHShell = Nothing
lbl_Exit:
Exit Function
End Function[/VBA]