サブフォルダ内の.msgファイルを検索し、VBA Excelを使用してOutlookでメールを送信します。

Question

添付ファイルが.msgのOutlookメールを自動化するプロジェクトで作業しています。これらのメールの送信は、Excelを介して行われます。私はそれを行うためにVBA Excelを使用しています。

Excelには、必要な電子メール（列T）と.msgファイルの名前の一部を持つ他の列（列R）の列があります。ファイル名の一部は、1つ以上のファイルに含めることができます。さらに多くのファイルが見つかった場合は、列Tで指定された対応するメールにすべて郵送されます。

Excel VBAの新機能ですが、これらのファイルを見つけ出してそこに配置する作業コードがあります列Uのパス（2つのファイルが見つかった場合は、コードUとVで区切られた後のコードになります）を使用して、パスの末尾にあるOutlookメールでパスを送信します。

私の唯一の問題は、これらのファイルがサブフォルダに配布されていることと、すべてのファイルが1つのフォルダにある場合にのみ機能することです。私は（DIR $）を使ってこれらのファイルをワイルドカードで探します。 1つのフォルダではなく、すべてのサブフォルダ内のファイルを検索するコードを最適化するにはどうすればよいですか？

Sub Send_Files() 
Dim OApp As Object 
Dim OMail As Object 
Dim sh As Worksheet 
Dim cell As Range 
Dim FileCell As Range 
Dim rng As Range 
Dim irow As Integer 
Dim i As Integer 
Dim dpath As String 
Dim pfile As String 
Dim FileNames As String 
Dim Sourcewb As Workbook 
Dim Destwb As Workbook 
Dim TempFilePath As String 
Dim TempFileName As String 
Dim Mail_Object, OutApp As Variant 
Dim OutMail As Variant 

With Application 
    .EnableEvents = False 
    .ScreenUpdating = False 
End With 
On Error Resume Next 
irow = 1 
dpath = "H:\My Documents\test\" 
Do While Cells(irow, 18) <> Empty 

pfile = Dir$(dpath & "\*" & Cells(irow, 18) & "*") 
FileNames = "" 
'MsgBox pfile 

Do Until LenB(pfile) = 0 
    If FileNames <> "" Then 
     FileNames = FileNames & ";" & dpath & pfile 
    Else 
     FileNames = dpath & pfile 
    End If 
    pfile = Dir$ 
    For Each cell In Cells(irow, 18) 
    Cells(irow, 21) = FileNames 

    Next cell 

Loop 
irow = irow + 1 
Loop 
'Debug.Print FileNames 

Application.DisplayAlerts = False 
Columns("V:AU").Select 
Selection.ClearContents 
Columns("U:U").Select 
Selection.TextToColumns Destination:=Range("U1"), DataType:=xlDelimited, _ 
    TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _ 
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _ 
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True 

Set sh = ActiveSheet 

Set OApp = CreateObject("Outlook.Application") 

For Each cell In sh.Columns("T").Cells.SpecialCells(xlCellTypeConstants) 

    Set rng = sh.Cells(cell.Row, 1).Range("U1:V1") 

    If cell.Value Like "?*@testmail.nl" And _ 
     Application.WorksheetFunction.CountA(rng) > 0 Then 
     Set OMail = OApp.CreateItem(0) 

     With OMail 
      .To = cell.Value 
      .Body = "Hoi " & cell.Offset(0, -1).Value 
      .Subject = cell.Offset(0, -2).Value 
      For Each FileCell In rng.SpecialCells(xlCellTypeConstants) 
       If Trim(FileCell) <> "" Then 
        If Dir(FileCell.Value) <> "" Then 
         .Attachments.Add FileCell.Value 
        '.Subject = FileCell.Value 
        End If 
       End If 
      Next FileCell 
      .Display 
      ' Application.Wait (Now + TimeValue("0:00:01")) 
      ' Application.SendKeys "%z" 
     End With 
     Set OMail = Nothing 
    End If 
Next cell 
    Set OApp = Nothing 
With Application 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 

End Sub 

Answer 1

まず、あなたが最初のループのバグ

dpath = "H:\My Documents\test\" 
. 
pfile = Dir$(dpath & "\*" & Cells(irow, 18) & "*") 

が

H:\My Documents\test\\* & Cells(irow, 18) & "*" 
        ^^ 

を生成していますが、別の関数にファイル名のリストを作成し、あなたのコードを配置する必要がありますし、パスとファイルマスクをその関数に渡します。

ここで、そのリストを作成するコードは、別のDir $（）ループを使用してファイルを参照しますが、を使用します。ファイルマスク。ファイルとディレクトリの両方を返します。次に、返されたファイル名に設定されているDirectory属性をテストします。あなたはディレクトリ構造に複数のレベルをステップにしたい場合は

llngFileAttribute = GetAttr(<path and name from DIR$()>) 
if llngFileAttribute And vbDirectory <> 0 then 
    'Is a directory, so add the name from DIR$ to the path 
    'and call the list building routine 
else 
    'call list building routine with path and mask built from cell data 
end if 

は、あなただけのあなたの出コードから一度それを呼び出し、別の関数に新しいループを入れて、それを再帰的にする必要があります。

Answer 2

Dir（）を再帰的に使用するのは少し難解です。グローバルなDir（）関数は、見つかったものを一覧表示するために単一のデータ構造を使用します。別のDir（）ループ内からifを呼び出すと、最初のデータ構造が破棄され、再帰から戻ると、 。

これはFileSystemObjectでも実行できますが、これはもう少し簡単です。しかし、あなたが最初のコードでDir（）を使用して以来、私はそれを使用しました。この例では、ワークブックを保持するフォルダ内のすべてのビットマップファイル（* .bmp）とそのフォルダの下にあるすべてのフォルダが検索されます。

必要に応じて以下のコードを変更し、必要に応じてFileSystemObjectを調べてください。

変数宣言：

最初の文字が可変範囲である：L =ローカル;で渡さ=引数。 m =メンバ。 g =グローバル。

変数が次のデータ型の配列であることを示すスコープの後にオプションの「a」を付けることができます。

次の3文字は、データ型です。str = string; lng =ロング; obj = Object; vnt =バリアント。

説明変数名が続き、各単語は大文字で始まります。

したがって、 "lavntSubDirs"はSubDirsという名前のバリアントの配列として使用されるローカル変数です。

サブデータにはデータが返されないため、プレフィックスはありません。関数には返されるデータ型を示す接頭辞があります。

Option Explicit 

Public Sub GetFileList() 
    Dim lstrStartingPath As String 
    Dim lstrFileNames As String 

    'Set starting path as desired 
    lstrStartingPath = ThisWorkbook.Path 
    'lstrStartingPath = "H:\My Documents\test 

'Your row reading loop starts here and sets the 2nd parameter 
    lstrFileNames = strRecurseDirs(lstrStartingPath, "*.bmp") 
    'lstrFileNames = strRecurseDirs(lstrStartingPath, "*" & Cells(irow, 18) & "*") 

    'remove last ";" character 
    lstrFileNames = Left$(lstrFileNames, Len(lstrFileNames) - 1) 

    'Use the returned string as needed 
    MsgBox lstrFileNames 

'End of your row reading loop 
'. 
'. 
'. 

End Sub 
Private Function strRecurseDirs(astrPath As String, astrFileMask As String) As String 
    Dim lstrNextDir As String 
    Dim lstrFileSpec As String 
    Dim llngFileAttr As Long 
    Dim lstrFileNameList As String 
    Dim lstrSubDirs As String 
    Dim lavntSubDirs As Variant 
    Dim llngSubDirIdx As Long 

    'Get the file names in the passed path 
    lstrFileNameList = strGetFileNames(astrPath, astrFileMask) 

    'Look for child directories. Because Dir() is a global function and  it uses it's own data structure to return 
    'the next item, we can't recurse from within a Dir loop. Since our  strGetFileNames() uses Dir() to find the 
    'files it will trash this Dir() loop's item list. So we make a list  of directories found and then recurse for 
    'each of the found directories. 
    lstrNextDir = Dir(astrPath + "\*.*", vbDirectory) 
    Do While Len(lstrNextDir) > 0 
     'Note: "." is current directory, ".." is parent directory. We  don't want either. 
     If lstrNextDir <> "." And lstrNextDir <> ".." Then 
      lstrFileSpec = astrPath + "\" + lstrNextDir 
      llngFileAttr = GetAttr(lstrFileSpec) 
      If (llngFileAttr And vbDirectory) = vbDirectory Then 
       'Is a directory so add it to list of subdirectories to examine 
       lstrSubDirs = lstrSubDirs + lstrFileSpec + ";" 
      End If 
     End If 
     lstrNextDir = Dir() 
    Loop 
    If Len(lstrSubDirs) Then 
     'We found subdirectories so process them one at a time 

     'Remove last ";" so we don't get an empty string as the last item 
     lstrSubDirs = Left$(lstrSubDirs, Len(lstrSubDirs) - 1) 

     'Separate the directories found into indiviual items 
     lavntSubDirs = Split(lstrSubDirs, ";") 

     'Process directories found 
     For llngSubDirIdx = 0 To UBound(lavntSubDirs) 
      lstrFileNameList = lstrFileNameList + strRecurseDirs(CStr(lavntSubDirs(llngSubDirIdx)), astrFileMask) 
     Next 
    End If 

    strRecurseDirs = lstrFileNameList 
End Function 
Private Function strGetFileNames(astrPath As String, astrFileMask As String) As String 
    Dim lstrFileNameList As String 
    Dim lstrFileName As String 
    Dim lstrFileSpec As String 
    Dim llngFileAttr As Long 

    lstrFileName = Dir(astrPath + "\" + astrFileMask) 
    Do While Len(lstrFileName) > 0 
     lstrFileSpec = astrPath + "\" + lstrFileName 
     llngFileAttr = GetAttr(lstrFileSpec) 
     If (llngFileAttr And vbDirectory) = 0 Then 
      'Not a directory 
      lstrFileNameList = lstrFileNameList + lstrFileSpec + ";" 
     End If 
     lstrFileName = Dir() 
    Loop 
    strGetFileNames = lstrFileNameList 
End Function