VBAにアクセスしてAttachement（QueryDef）付きメールをループに送信

Question

達成しようとしていることは何ですか？

メールアイテムごとに作成しようとしています。このメールアイテムには添付ファイルとしての一時的なクエリが必要です。私は一時的なクエリをフォルダに読み込みます。

問題を示すコードの部分を貼り付けます。

問題はクエリです。それは添付ファイルに常に同じデータを表示し、各rsのデータは表示しません。私は私のループにクエリdefを含める必要があることをお勧めしますが、私はあなたの助けが必要です。

Sub ExcelExportuSenden() 

Dim day As Integer 
day = Weekday(Date, vbSunday) 
Dim olApp As Outlook.Application 
Dim toMulti, waarde As String 
Dim mItem As Outlook.MailItem ' An Outlook Mail item 
Dim dbs As Database 
Dim qdfTemp As QueryDef 
Dim qdfNew As QueryDef 
Dim originalSql As String 
Dim Identified_name As Recordset 
Dim qdf As DAO.QueryDef 
Set dbs = CurrentDb 
Set olApp = CreateObject("Outlook.Application") 
Set mItem = olApp.CreateItem(olMailItem) 
Dim rs As Recordset 

Set rs = CurrentDb.OpenRecordset("Mailversand") 'Get name for the email distro 

If rs.RecordCount > 0 Then 
    rs.MoveFirst 
    Do Until rs.EOF 
     With mItem 
      Set mItem = olApp.CreateItem(olMailItem) 
      .BodyFormat = olFormatHTML 
      toMulti = rs![email] 
      waarde = toMulti 
      For Each qdf In dbs.QueryDefs 
       If qdf.Name = "Anfrage_zur_Ausschreibung" Then 
        dbs.QueryDefs.Delete "Anfrage_zur_Ausschreibung" 
        Exit For 
       End If 
      Next 

      Set qdfTemp = dbs.CreateQueryDef("Anfrage_zur_Ausschreibung") 
      With dbs 
       'Run query on selected Name product manager 
       qdfTemp.SQL = "SELECT * FROM [Filter_Ausschreibung_original] WHERE [Lieferant] = '" & rs![Lieferant] & "'" 
       DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Anfrage_zur_Ausschreibung", "Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx", True 

      End With 

     .To = toMulti 
     MsgBox toMulti 
     .Subject = "Anfrage zu Ausschreibung" 
     .HTMLBody = "Sehr geehrte Damen und Herren" 
     .Display 
     .Attachments.Add ("Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx") 

    End With 

     rs.MoveNext 
    Loop 
Else 
    MsgBox "No email address!" 
End If 
olApp.Quit 
Set olApp = Nothing 
Exit Sub 

End Sub 

結果はどのようなものでしょうか？ 各rsには異なる添付ファイルが必要です。 "Lieferant"に属する部分。

実際の結果はどうなりますか？ （エラーを含めてください） 私は添付ファイルが1つしかありません。これは常に同じ内容です。

更新 私はパフェのソリューションを使用しようとしています。

'Export temp table to Excel 
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _ 
      "Anfrage_zur_Ausschreibung_TEMP", _ 
      "Q:\LU\_Rothenhöfer\Test\Anfrage_zur_Ausschreibung_TEMP.xlsx", True 

完全なコードは以下のようになります。：

Sub ExcelExportuSenden() 

Dim day As Integer 
day = Weekday(Date, vbSunday) 
Dim olApp As Outlook.Application 
Dim toMulti, waarde As String 
Dim mItem As Outlook.MailItem ' An Outlook Mail item 
Dim dbs As Database 
Dim qdfTemp As QueryDef 
Dim qdfNew As QueryDef 
Dim originalSql As String 
Dim Identified_name As Recordset 
Dim qdf As DAO.QueryDef 
Set dbs = CurrentDb 
Set olApp = CreateObject("Outlook.Application") 
Set mItem = olApp.CreateItem(olMailItem) 
Dim rs As Recordset 

Set rs = CurrentDb.OpenRecordset("Mailversand") 'Get name for the email distro 

If rs.RecordCount > 0 Then 
    rs.MoveFirst 

Do Until rs.EOF 
    With mItem 
     Set mItem = olApp.CreateItem(olMailItem) 
     .BodyFormat = olFormatHTML 
     toMulti = rs![email] 
     waarde = toMulti 

     Set qdfTemp = dbs.CreateQueryDef("Anfrage_zur_Ausschreibung") 
     qdfTemp.SQL = "PARAMETERS LieferantParam Text (255); " & _ 
         "SELECT * INTO Anfrage_zur_Ausschreibung_TEMP " & _ 
         "From Filter_Ausschreibung_original " & _ 
         "WHERE [Lieferant] = rs![Lieferant]" 

     Set qdfTemp = Nothing 

     'Export temp table to Excel 
     DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _ 
       "Anfrage_zur_Ausschreibung_TEMP", _ 
       "Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx", True 

     .To = toMulti 
     MsgBox toMulti 
     .Subject = "Anfrage zu Ausschreibung" 
     .HTMLBody = "Sehr geehrte Damen und Herren" 
     .Display 
     .Attachments.Add ("Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx") 
    End With 
    rs.MoveNext 
Loop 
Else 
    MsgBox "No email address!" 
End If 
olApp.Quit 
Set olApp = Nothing 
Exit Sub 

End Sub 

私が間違っているのは何の問題は今、次の部分でエラーになりますか？

' UPDATE QUERY 
Set qdfTemp = dbs.CreateQueryDef("Anfrage_zur_Ausschreibung") 
qdfTemp.SQL = "<SQL Query>" 
Set qdfTemp = Nothing     ' RELEASES QUERYDEF 

' EXPORT QUERY TO EXCEL 
DoCmd.TransferSpreadsheet acExport ... 

ただし、SQL文にVBA変数を連結することで、クエリを削除し、再作成のこのアプローチを再考：あなたはそのSQLを更新した後

Answer 1

単純にそうでなければ変更が伝達されていない、あなたのQTEMPをリリース。より洗練され、保守しやすく、やや効率的なコードのために、Excelをエクスポートするための一時テーブルを反復的に構築するには、parameterizationを検討してください。

SQL（PARAMETERS句永久テーブル作成アクションクエリとして保存）

PARAMETERS LieferantParam TEXT; 
SELECT * INTO Anfrage_zur_Ausschreibung_TEMP 
FROM [Filter_Ausschreibung_original] 
WHERE [Lieferant] = [LieferantParam]; 

VBA（ループ部は、現在のパラメータによってアクション上に実行されている）

Do Until rs.EOF  
    With mItem 
     Set mItem = olApp.CreateItem(olMailItem) 
     .BodyFormat = olFormatHTML 
     toMulti = rs![email] 
     waarde = toMulti 

     'Retrieve make-table query and bind parameter to name product manager 
     Set qdfTemp = dbs.QueryDef("Anfrage_zur_Ausschreibung_QUERY") 
     qdfTemp![LieferantParam] = rs![Lieferant] 
     qdfTemp.Execute, dbFailOnError 

     'Export temp table to Excel 
     DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _ 
       "Anfrage_zur_Ausschreibung_TEMP", _ 
       "Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx", True 

     .To = toMulti 
     MsgBox toMulti 
     .Subject = "Anfrage zu Ausschreibung" 
     .HTMLBody = "Sehr geehrte Damen und Herren" 
     .Display 
     .Attachments.Add ("Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx")  
    End With  
    rs.MoveNext 
Loop