Formatting with method TransferSpreadsheet - excel

Question

actually my code is perfectly working. Code is actually creating a temporary query in Access for each supplier, i have in a table. After creating the query, next step is, saving the query as a Excel - file in my submitted path. After that, my code is creating a mail with an PDF as Attachement and with the Excel file as attachement for each supplier.
But is there a possibility to formatting after or into TransferSpreadsheet - method the columns widthness after saving the Excel - file? It would be also nice if first row has a bond. Here's my code
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 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
Many thanks for your help!

Answer 1

Problem is solved. Here my code:
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 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