I will preface this question with I have very little experience with coding and much of this code is pulled from other questions but I can't seem to get it to work for me.
I am trying to extract embedded files from multiple Word documents in a folder and save them to that folder. When I try to run the code I get nothing, no errors and no extracted files.
Sub Main()
GetAllFiles CurDir
GetFileList
OpenAndExtract
End Sub
Sub GetAllFiles(Folder, StrArray())
'Stores all file names from a folder into a string array.
Dim objFSO, objFolder, objFile, i
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Folder)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve StrArray(i)
StrArray(i) = objFile.Name
i = i + 1
Next
If i = 1 Then
ReDim Preserve StrArray(1)
End If
End Sub
Dim FileSpec(1)
FileSpec(0) = Source & "\*.doc"
FileSpec(1) = Source & "\*.docx"
Sub GetFileList(ByRef FileSpec(), objDict)
Dim FileName
objDict.RemoveAll
On Error GoTo 0
For i = LBound(FileSpec) + 1 To UBound(FileSpec)
FileName = Dir(FileSpec(i))
' Loop until no more matching files are found
Do While FileName <> ""
If Not objDict.Exists(FileName) Then objDict.Add FileName, 0
FileName = Dir()
Loop
Next
If objDict.count = 0 Then Exit Sub
End Sub
Sub OpenAndExtract()
Dim AD
Documents.Close (wdDoNotSaveChanges)
For each Key in objDict
Set Ad = Documents.Open(Source & "\" & Key).Activate
Call ExtractAndSaveEmbeddedFiles
Next
End Sub
Sub ExtractAndSaveEmbeddedFiles()
Dim objEmbeddedShape
Dim strShapeType, strEmbeddedDocName
Dim objEmbeddedDoc
With ActiveDocument
For Each objEmbeddedShape In .InlineShapes
' Find and open the embedded doc.
strShapeType = objEmbeddedShape.OLEFormat.ClassType
objEmbeddedShape.OLEFormat.Open
' Initialization
Set objEmbeddedDoc = objEmbeddedShape.OLEFormat.Object
' Save embedded files with names as same as those of icon label.
strEmbeddedDocName = objEmbeddedShape.OLEFormat.IconLabel
objEmbeddedDoc.SaveAs CurDir() & "\" & strEmbeddedDocName
objEmbeddedDoc.Close
Set objEmbeddedDoc = Nothing
Next
End With
End Sub