Send Access Report in body of email

[Beyuduzz]

Below is the code that will generate an email with the report text in the
email body and not as an attachment.

There are a few SQL statements that you'll have to modify from your
database.
Create a command button on a form along with an unbound text box called
DateEnter. The rest you'll have to customize for you needs.

****************************************************

Private Sub Command13_Click()

On Error GoTo Err_Command13_Click
Dim strBody As String
Dim rs As Object
Dim con As Object
Dim DateEnter As Date
Dim NoMeetings As Integer
Dim Meeting(100) As Integer
Dim i As Integer
Dim j As Integer
Dim room As String

i = 0
j = 0


If Not IsNull(Me![DateEnter]) Then

'this is an sql string to search by date. You'll need to change the name to
fit your database.
sqlst = "Select Distinct MeetingID " _
& "From MeetingData " _
& "WHERE ((MeetingData.MeetingDate) = #" & Me![DateEnter] & "#)"

Set con = Application.CurrentProject.Connection
Set rs = CreateObject("ADODB.recordset")

rs.Open sqlst, con, 1

If Not rs.EOF Then

While Not rs.EOF

Meeting(i) = rs![MeetingID]
i = i + 1
rs.MoveNext
Wend

Else
MsgBox ("No meetings on this date") 'this is your msgbox for the user to
enter the date.
Exit Sub
End If


rs.Close

For j = 0 To i

'the following is a sql string that you will need to edit according to your
needs. Enter sql string
'after the sqlst=. There was a problem with carriage returns so leave
undercores in after each line along with ampersands

sqlst = "SELECT MeetingData.MeetingTitle, MeetingData.MeetingDate, " _
& "MeetingData.Description, MeetingData.SetupTime, " _
& "MeetingData.StartTime,MeetingData.EndTime, [Port-KivUsage].TimeID, " _
& "[Port-KivUsage].PortID,[Port-KivUsage].DialUpNo " _
& "FROM MeetingData Left JOIN [Port-KivUsage] ON " _
& "MeetingData.MeetingID=[Port-KivUsage].MeetingID " _
& "WHERE ((MeetingData.MeetingID) = " & Meeting(j) & ")"

'Set con = Application.CurrentProject.Connection
'Set rs = CreateObject("ADODB.recordset")

rs.Open sqlst, con, 1

If Not rs.EOF Then

strBody = strBody & "Port Assignments: " & Format(rs![MeetingDate],
"Long Date") & vbCr
strBody = strBody & vbCr
strBody = strBody &
"-------------------------------------------------------------" & vbCr
strBody = strBody & "Subject: " & rs![MeetingTitle] & vbCr
strBody = strBody &
"-------------------------------------------------------------" & vbCr
strBody = strBody & "Setup Time: " & Format(TimeSerial(3, 0, 0) +
rs![SetupTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0) +
rs![SetupTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![SetupTime], "Short Time") & " M " & Format(rs![SetupTime], "Short Time")
& " P " & vbCr
strBody = strBody & "Start Time: " & Format(TimeSerial(3, 0, 0) +
rs![StartTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0) +
rs![StartTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![StartTime], "Short Time") & " M " & Format(rs![StartTime], "Short Time")
& " P " & vbCr
strBody = strBody & "End Time: " & Format(TimeSerial(3, 0, 0) +
rs![EndTime], "Short Time") & " E " & Format(TimeSerial(2, 0, 0) +
rs![EndTime], "Short Time") & " C " & Format(TimeSerial(1, 0, 0) +
rs![EndTime], "Short Time") & " M " & Format(rs![EndTime], "Short Time") & "
P " & vbCr
strBody = strBody & "Description: " & rs![Description] & vbCr & vbCr
strBody = strBody & "Participants" & vbTab & "Port Number" & vbTab &
"Dial Number" & vbCr
While Not rs.EOF
If IsNull(rs![TimeID]) Then
room = ""
Else
room = DLookup("RoomName", "TimeCard", "[TimeID] = " &
rs![TimeID])
End If

strBody = strBody & room & vbTab & vbTab & rs![PortID] & vbTab &
rs![DialUpNo] & vbCr
rs.MoveNext
Wend
strBody = strBody & vbCr &
"********************************************************************************************" & vbCr

End If
rs.Close

Next j

Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.createitem(0)
myItem.Subject = "Subject" 'enter your email subject line here
myItem.Body = strBody
myItem.To = "(e-mail address removed)" 'enter your destination email here
myItem.Cc = ""
myItem.display

Set rs = Nothing

Else
MsgBox ("Please enter a date") 'this is your error msgbox if no date is
entered. you can change this message if you'd like
End If


Exit_Command13_Click:
Exit Sub

Err_Command13_Click:
MsgBox Err.Description
Resume Exit_Command13_Click

End Sub