prkhan56
08-18-2021, 02:24 PM
Dear All,
I am using Office 2013.
I have a folder with many sub folders having word and excel files.
Excel file does not have images but the word documents under each sub folder have many images which I would like to move under each respective folders.
I found this code on the group which used to work but now it is giving run time error '53': File not found and highlights the following:
Kill strPath & "" & strDocumentName & ".htm*"
It used to work and move the images to a folder “MovedToHere”.
Sub GetPicturesFromWordDocument()
Dim strFile As String
Dim strFileType As String
Dim strPath As String
Dim lngLoop As Long
Dim strOriginalFile As String
Dim strDocumentName As String
strOriginalFile = ActiveDocument.FullName
strDocumentName = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
strPath = ActiveDocument.Path
ActiveDocument.SaveAs strPath & "\" & strDocumentName, wdFormatHTML, , , , , True
strFileType = "*.png;*.jpeg;*.jpg;*.bmp" 'Split with semi-colon if you want to specify more file types.
MkDir strPath & "\MovedToHere"
For lngLoop = LBound(Split(strFileType, ";")) To UBound(Split(strFileType, ";"))
strFile = Dir(strPath & "\" & strDocumentName & "_files\" & Split(strFileType, ";")(lngLoop))
Do While strFile <> ""
Name strPath & "\" & strDocumentName & "_files\" & strFile As strPath & "\MovedToHere\" & "New " & strFile
strFile = Dir
Loop
Next lngLoop
ActiveDocument.Close 0
Documents.Open strOriginalFile
Kill strPath & "\" & strDocumentName & ".htm*"
Kill strPath & "\" & strDocumentName & "_files\*.*"
RmDir strPath & "\" & strDocumentName & "_files"
strFile = vbNullString
strFileType = vbNullString
strPath = vbNullString
lngLoop = Empty
End Sub
I want to fix this code and also amend to run on all the sub folders.
Can someone fix this issue for me please.
Thanks in advance
I am using Office 2013.
I have a folder with many sub folders having word and excel files.
Excel file does not have images but the word documents under each sub folder have many images which I would like to move under each respective folders.
I found this code on the group which used to work but now it is giving run time error '53': File not found and highlights the following:
Kill strPath & "" & strDocumentName & ".htm*"
It used to work and move the images to a folder “MovedToHere”.
Sub GetPicturesFromWordDocument()
Dim strFile As String
Dim strFileType As String
Dim strPath As String
Dim lngLoop As Long
Dim strOriginalFile As String
Dim strDocumentName As String
strOriginalFile = ActiveDocument.FullName
strDocumentName = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
strPath = ActiveDocument.Path
ActiveDocument.SaveAs strPath & "\" & strDocumentName, wdFormatHTML, , , , , True
strFileType = "*.png;*.jpeg;*.jpg;*.bmp" 'Split with semi-colon if you want to specify more file types.
MkDir strPath & "\MovedToHere"
For lngLoop = LBound(Split(strFileType, ";")) To UBound(Split(strFileType, ";"))
strFile = Dir(strPath & "\" & strDocumentName & "_files\" & Split(strFileType, ";")(lngLoop))
Do While strFile <> ""
Name strPath & "\" & strDocumentName & "_files\" & strFile As strPath & "\MovedToHere\" & "New " & strFile
strFile = Dir
Loop
Next lngLoop
ActiveDocument.Close 0
Documents.Open strOriginalFile
Kill strPath & "\" & strDocumentName & ".htm*"
Kill strPath & "\" & strDocumentName & "_files\*.*"
RmDir strPath & "\" & strDocumentName & "_files"
strFile = vbNullString
strFileType = vbNullString
strPath = vbNullString
lngLoop = Empty
End Sub
I want to fix this code and also amend to run on all the sub folders.
Can someone fix this issue for me please.
Thanks in advance