Question

实际上我的代码完全正常工作。代码实际上是在Access中为每个供应商创建一个临时查询，我在表中。创建查询后，下一步是将查询保存为我提交的路径中的Excel文件。之后，我的代码创建了一个邮件，其中PDF为Attachement，Excel文件作为每个供应商的附件。

但是有可能在TransferSpreadsheet之后或之后格式化 - 保存Excel文件后的列宽度方法吗？如果第一行有一个债券也会很好。这是我的代码

    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
     Dim filename As String

     filename = Me.txt_path_pdf_description

     Set rs = CurrentDb.OpenRecordset("Mail")  'Get name for the&amp;nbsp;email recipient

     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 = "inquiry" & "_" & rs!supplier Then
                       dbs.QueryDefs.Delete "inquiry" & "_" & rs!supplier 
                       Exit For

                     End If
                 Next

                 Set qdfTemp = dbs.CreateQueryDef("inquiry" & "_" & rs!supplier) '
                 With dbs
                      qdfTemp.SQL = "SELECT * FROM [Filter_inquiry_original] WHERE [supplier] = '" & rs![supplier] & "'"
                      DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "inquiry" & "_" & rs!supplier, Me.txt_path & "\inquiry" & "_" & rs!supplier & ".xlsx", True
                      DoCmd.DeleteObject acQuery, "inquiry" & "_" & rs!Lsupllier
                 End With

         .To = toMulti
'          MsgBox toMulti
         .Subject = "Anfrage zur Ausschreibung" & "_" & rs!Lieferant
         .HTMLBody = "Sehr geehrte Damen und Herren,<br><br>" & _
         "anbei erhalten Sie eine Ausschreibung, mit der Bitte um Bearbeitung!"
         .Display
'          .Send
         .Attachments.Add filename
         .Attachments.Add (Me.txt_path & "\inquiry" & "_" & rs!supplier & ".xlsx")


     End With

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



 End Sub

非常感谢你的帮助！

Answer 1

问题解决了。这是我的代码：

 Sub ExcelExportuSenden3()

 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
 Dim filename As String
' Dim filename3 As String
 Dim xlApp As Object, xlWB As Object, xlsheet As Object
 Dim TabNam As String
 TabNam = "Tabelle1"

 filename = Me.txt_Pfad_mitKunde

    Set rs = CurrentDb.OpenRecordset("Mailversand")  'Get name for the&amp;nbsp;email recipient

        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" & "_" & rs!Lieferant Then
                    dbs.QueryDefs.Delete "Anfrage" & "_" & rs!Lieferant
                    Exit For
                 End If

        Next

             Set qdfTemp = dbs.CreateQueryDef("Anfrage" & "_" & rs!Lieferant) '
                With dbs
                  qdfTemp.SQL = "SELECT * FROM [_Anfragematrix] WHERE [Lieferant] = '" & rs![Lieferant] & "'"
                  DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Anfrage" & "_" & rs!Lieferant, Me.txt_Speicherpfad & "\Anfrage" & "_" & rs!Lieferant & ".xlsx", True _
                                                    , TabNam

                  Set xlApp = CreateObject("Excel.Application")
                  xlApp.Visible = True
                  Set xlWB = xlApp.Workbooks.Open(Me.txt_Speicherpfad & "\Anfrage" & "_" & rs!Lieferant & ".xlsx")
                  Set xlsheet = xlWB.Sheets(TabNam)

                        With xlsheet
                            .Columns.AutoFit

                            With .Range("A1:O1")

                                With .Interior
                                    .ColorIndex = 15
                                    .Pattern = xlSolid

                                End With

                            End With

                        End With

                    xlWB.Save
                    xlWB.Close True
                    Set xlWB = Nothing
                    xlApp.Quit
                    Set xlApp = Nothing

                    DoCmd.DeleteObject acQuery, "Anfrage" & "_" & rs!Lieferant

                 End With

         .To = toMulti
'          MsgBox toMulti
         .Subject = "Anfrage zur Ausschreibung" & "_" & rs!Lieferant
         .HTMLBody = "Sehr geehrte Damen und Herren,<br><br>" & _
         "anbei erhalten Sie eine Ausschreibung, mit der Bitte um Bearbeitung!"
         .Display
'         .Send
         .Attachments.Add filename
         .Attachments.Add (Me.txt_Speicherpfad & "\Anfrage" & "_" & rs!Lieferant & ".xlsx")


     End With

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



 End Sub

使用方法TransferSpreadsheet格式化

1 个答案: