[COLOR=#0000ff]Option Compare Database[/COLOR]
[COLOR=#0000ff]Option Explicit[/COLOR]
[COLOR=#008000]'=========================================================================='[/COLOR]
[COLOR=#008000]'Module Name: modExportData '[/COLOR]
[COLOR=#008000]'Module Type: Code Module '[/COLOR]
[COLOR=#008000]'Purpose : Export Access Query to Excel and then Email Workbook '[/COLOR]
[COLOR=#008000]'=========================================================================='[/COLOR]
[COLOR=#008000]'Author : Matt Mickle '[/COLOR]
[COLOR=#008000]'Date : 22 February 2015 '[/COLOR]
[COLOR=#008000]'=========================================================================='[/COLOR]
[COLOR=#008000]'For this VBA Code to work you need to reference '[/COLOR]
[COLOR=#008000]'Microsoft Outlook XX.X Object Library '[/COLOR]
[COLOR=#008000]'Microsoft Excel XX.X Object Library '[/COLOR]
[COLOR=#008000]'=========================================================================='[/COLOR]
[COLOR=#0000ff]Sub [/COLOR]GetQueryInExcel()
[COLOR=#0000ff] Dim[/COLOR] xlApp [COLOR=#0000ff]As [/COLOR]Excel.Application
[COLOR=#0000ff]Dim[/COLOR] rstDb [COLOR=#0000ff]As[/COLOR] Recordset
[COLOR=#0000ff] Dim[/COLOR] conDb [COLOR=#0000ff]As[/COLOR] Database
[COLOR=#0000ff] Dim[/COLOR] xlWbkNew [COLOR=#0000ff] As[/COLOR] Workbook
[COLOR=#0000ff] Dim[/COLOR] OutApp [COLOR=#0000ff] As Object[/COLOR]
[COLOR=#0000ff] Dim[/COLOR] OutMail [COLOR=#0000ff] As Object[/COLOR]
[COLOR=#0000ff] Dim [/COLOR]TempFilePath [COLOR=#0000ff] As String[/COLOR]
[COLOR=#0000ff] Dim [/COLOR]TempFileName [COLOR=#0000ff] As String[/COLOR]
[COLOR=#0000ff] Dim[/COLOR] WBName [COLOR=#0000ff] As String[/COLOR]
[COLOR=#0000ff] Dim[/COLOR] lngLoop [COLOR=#0000ff] As Long[/COLOR]
[COLOR=#0000ff] [/COLOR]
[COLOR=#0000ff] Const[/COLOR] strQryName [COLOR=#0000ff] As String [/COLOR]= "LowInventory" [COLOR=#008000]'<---Defines Query Name[/COLOR]
[COLOR=#0000ff] On Error GoTo[/COLOR] ErrHandler
[COLOR=#0000ff] Set[/COLOR] conDb = CurrentDb()
[COLOR=#0000ff] Set[/COLOR] OutApp = CreateObject("Outlook.Application")
[COLOR=#0000ff] Set[/COLOR] OutMail = OutApp.CreateItem(0)
[COLOR=#0000ff] Set[/COLOR] rstDb = conDb.OpenRecordset(strQryName)[COLOR=#008000] 'Opens the Query LowInventory[/COLOR]
[COLOR=#0000ff] If[/COLOR] rstDb.RecordCount > 0 [COLOR=#0000ff]Then[/COLOR]
rstDb.MoveLast
rstDb.MoveFirst
[COLOR=#0000ff]Set[/COLOR] xlApp = CreateObject("Excel.Application")
[COLOR=#0000ff] Set [/COLOR]xlWbkNew = xlApp.Workbooks.Add(1)
[COLOR=#0000ff] With[/COLOR] xlWbkNew.Worksheets(1)
[COLOR=#0000ff] For[/COLOR] lngLoop = 0 [COLOR=#0000ff]To [/COLOR]rstDb.Fields.Count - 1
.Range("A1").Offset(, lngLoop).Value = rstDb.Fields(lngLoop).Name [COLOR=#008000] 'Get Header Fields[/COLOR]
[COLOR=#0000ff] Next[/COLOR] lngLoop
.Range("A1").Offset(1, 0).CopyFromRecordset rstDb[COLOR=#008000] 'Print All Data in Query to Worksheet[/COLOR]
[COLOR=#0000ff] End With[/COLOR]
[COLOR=#ff0000]
'Change this section to accomodate your needs[/COLOR]
xlWbkNew.Worksheets(1).Name = "InventoryReport" [COLOR=#008000]'Name Worksheet[/COLOR]
TempFilePath = Environ$("temp") & "\" [COLOR=#008000]'This defines the filepath ---> C:\Users\username\AppData\Local\Temp[/COLOR]
TempFileName = "FD_Inventory Report_" & Format(Now, "MM.DD.YYYY h.mm AM/PM") & ".xlsx" [COLOR=#008000]'Name File with TimeStamp[/COLOR]
xlWbkNew.SaveAs TempFilePath & TempFileName [COLOR=#008000]'Save file in Temporary Directory[/COLOR]
[COLOR=#0000ff] End If[/COLOR]
[COLOR=#ff0000] 'Comment this section out[/COLOR]
[COLOR=#008000] 'Email Workbook to people[/COLOR]
[COLOR=#008000] 'With OutMail[/COLOR]
[COLOR=#008000] '.To = "YourName@Email.Com"[/COLOR]
[COLOR=#008000] '.CC = ""[/COLOR]
[COLOR=#008000] '.BCC = ""[/COLOR]
[COLOR=#008000] '.Subject = "This is the Subject line"[/COLOR]
[COLOR=#008000] '.Body = "This is the email body" 'Use "Blah Blah Blah" & Chr(13) & "This is another line"[/COLOR]
[COLOR=#008000] '.Attachments.Add TempFilePath & TempFileName[/COLOR]
[COLOR=#008000] '.Send[/COLOR]
[COLOR=#008000] 'End With[/COLOR]
[COLOR=#008000] 'Close WorkBook and DB Connections[/COLOR]
rstDb.Close
conDb.Close
xlWbkNew.Close [COLOR=#0000ff]True[/COLOR]
[COLOR=#008000] 'Delete the Temporary File & Clear All Variables[/COLOR]
Kill TempFilePath & TempFileName
[COLOR=#0000ff] Set [/COLOR]rstDb = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set[/COLOR] conDb = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set[/COLOR] xlApp = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set [/COLOR]xlWbkNew =[COLOR=#0000ff] Nothing[/COLOR]
[COLOR=#0000ff] Set [/COLOR]OutMail = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set[/COLOR] OutApp = [COLOR=#0000ff]Nothing[/COLOR]
lngLoop = [COLOR=#0000ff]Empty[/COLOR]
TempFilePath = vbNullString
TempFileName = vbNullString
MsgBox "Inventory Report was emailed successfully!", vbInformation, "Inventory Report"
[COLOR=#0000ff] Exit Sub[/COLOR]
ErrHandler:
MsgBox "An error has occured. Please close this file and then" _
& Chr(13) & "Reopen the file. If the problem persists please" _
& Chr(13) & " contact the file administrator." _
& Chr(13) & Chr(13) & "Error Number:- " & Err.Number _
& Chr(13) & "Description:- " & Err.Description _
, vbCritical, "Error Handler"
Kill TempFilePath & TempFileName
[COLOR=#0000ff]Set[/COLOR] rstDb = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set[/COLOR] conDb = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set[/COLOR] xlApp = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set[/COLOR] xlWbkNew = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff] Set [/COLOR]OutMail = [COLOR=#0000ff]Nothing[/COLOR]
[COLOR=#0000ff]Set[/COLOR] OutApp = [COLOR=#0000ff]Nothing[/COLOR]
lngLoop = [COLOR=#0000ff]Empty[/COLOR]
TempFilePath = vbNullString
TempFileName = vbNullString
[COLOR=#0000ff]End Sub[/COLOR]