フォルダ内のすべての単語文書から埋め込み文書を抽出する

Question

私はvbaを初めて使用しています。質問があります。私はアクティブな文書に埋め込まれた文書を開いて保存するためにマクロを書きました。私が書いたコードは以下の通りです：

Sub Extract() 

    Dim num As Integer 
    Dim AD As Document 
    Set AD = ActiveDocument 

    Dim numObjects As Integer 
    numObjects = AD.InlineShapes.Count 

    'MsgBox numObjects ' prints "11" 

    For num = 1 To numObjects 
     If AD.InlineShapes(num).Type = 1 Then 
      'it's an embedded OLE type so open it. 
      AD.InlineShapes(num).OLEFormat.Open 
      AD.InlineShapes(num).OLEFormat.Object.SaveAs FileName:="C:\Users\Ankita\Desktop\New folder\x.xlsx", FileFormat:=51 


     End If 
    Next num 

End Sub 

私がやりたいどのソースフォルダに存在するすべてのWord文書内のすべての埋め込まれた文書を抽出し、保存先のフォルダにそれらのすべてを保存しています。

私はdocsという単語にアクセスし、それらをループする必要があり、上記と同じコードスニペットを持つ必要があることを理解していますが、どのように書きますか。

ご協力いただければ幸いです。

Answer 1

最初のステップは、抽出元のソースフォルダ内のすべてのファイルのリストを取得することです。

Sub GetAllFiles(Folder As String, StrArray() As String) 
    'Stores all file names from a folder into a string array. 
    Dim objFSO As Object 
    Dim objFolder As Object 
    Dim objFile As Object 
    Dim i As Integer 

    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 objFile 

    If i = 1 Then 
     ReDim Preserve StrArray(1) 
    End If 
End Sub 

次の手順は、Word文書ファイル以外のすべてを除外することです。

Dim FileSpec(1) As String 
FileSpec(0) = Source & "\*.doc" 
FileSpec(1) = Source & "\*.docx" 

Sub GetFileList(ByRef FileSpec() As String, objDict As Object) 
    Dim FileName As String 
    objDict.RemoveAll 
    On Error GoTo NoFilesFound 
    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 i 
    If objDict.count = 0 Then GoTo NoFilesFound 
Exit Sub 

'Error Handler 
NoFilesFound: 
'ERROR HANDLING 
End Sub 

これはキーとファイル名などのデータとどんな数のキーになるこの周りを変更することができ、0の値として辞書に.DOCまたは.docxの拡張子を持つすべてのファイルを追加しますが、それはあなたの選択です。

ここから、辞書内の各項目のSubを開いて呼び出す必要があります。

Sub OpenAndExtract() 
Dim AD As Document 
    Documents(ActiveDocument.FullName).Close SaveChanges:=wdDoNotSaveChanges 
    For each Key in objDict 
     Set Ad = Documents.Open(Source & "\" & Key).Activate 
     Call Extract 
    Next 
End Sub 

それはおおよそです。おそらく、目的のフォルダを選択する方法を変更する必要があることに注意してください（パラメータを取ったり、グローバル変数を設定するなど）。私はあなたが作業しているプロジェクトの組織を知らないので、この部分について少しずつ作業を進める必要があります。また、私はこれをエディタで手作業で書いているので、どこかで構文が間違っている可能性があります。神の言葉としてそれを取ってはいけませんが、それはあなたの目標へのあなたの道にうまくいくはずです。