|
Question : SMTP e-mailing queries
|
|
http://www.experts-exchange.com/Databases/MS_Access/Q_20699546.html
Looking at the code in the above link is there anyway to attach an Acc Table/Query/Rport directly without dumping it to a file first?
-------------
paq'd by special request, 125 refund
ee ai construct on 8/30/06
|
|
|
Answer : SMTP e-mailing queries
|
|
My final solution:
Option Compare Database
Option Explicit
Public Function SendSMTPMail(Subject As String, MsgTxt As String, RecipientEmails As String, _
Optional RecieveDisplayName As String = "", Optional AttachFile As String = " ", _
Optional AttachTableQueryReport As String = " ")
'Make sure you have a reference set to "SMTP Send Mail for VB6.0"
'(Menu bar --> Tools --> References)
'The list of attachments is expected to be a semi-colon delimted list.
Dim strExchangeServer As String
Dim poSendMail As vbSendMail.clsSendMail
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim SQL As String
Dim AtchList As String
Dim Attch As Boolean
AtchList = ""
'Build the list of tables or files that are to be sent _
along withthe e-mail.
If Trim(AttachTableQueryReport) <> "" Or Trim(AttachFile) <> "" Then
Call OutputAttchForSend(AttachTableQueryReport, AttachFile)
Attch = True
End If
'Actually send the e-mail
Set poSendMail = New clsSendMail
poSendMail.SMTPHost = "DancingFurryPanda"
'This can be hardcoded or use something like getusername function _
to build it on the fly such as _
poSendMail.from = getusername & "@foo.boo" _
Note that building it on the fly you would want to modify the _
FromDisplayName name as well.
poSendMail.from = "[email protected]"
poSendMail.FromDisplayName = "Network Admin"
poSendMail.Recipient = RecipientEmails
poSendMail.RecipientDisplayName = RecieveDisplayName
poSendMail.Subject = Subject
If Attch = True Then
SQL = "SELECT File_Name, File_Date, Transmitted, Delete_Later " & _
"FROM tbl_Attachments " & _
"ORDER BY File_Name "
Set DB = CurrentDb()
Set RS = DB.OpenRecordset(SQL)
Do Until RS.EOF
AtchList = AtchList & RS!File_Name & ";"
With RS
.Edit
!Transmitted = True
.Update
End With
RS.MoveNext
Loop
Set RS = Nothing
Set DB = Nothing
AtchList = Left(Trim(AtchList), Len(Trim(AtchList)) - 1)
Debug.Print AtchList
poSendMail.Attachment = AtchList ' file attachment(s), optional
End If
poSendMail.Message = MsgTxt
poSendMail.Send
'Delete the files that were created on the fly for sending.
SQL = "SELECT File_Name, File_Date, Transmitted, Delete_Later " & _
"FROM tbl_Attachments " & _
"WHERE Delete_Later = True" & _
"ORDER BY File_Name "
Set DB = CurrentDb()
Set RS = DB.OpenRecordset(SQL)
Do Until RS.EOF
Kill RS!File_Name
RS.MoveNext
Loop
Set RS = Nothing
Set DB = Nothing
End Function
Public Function OutputAttchForSend(Optional ExistToAttch As String = "", _
Optional CreateToAttach As String = "")
'This takes a semi-colon deleted list of tables or files to be _
attached and inserts them into tbl_Attachments. The ExistToAttch _
are files already on a drive. The CreateToAttach are tables, queries _
or reports that need to be dumped to disk and then attached.
Dim I As Integer
Dim ReportName As String
Dim AttachType As Long
Dim SQL As String
'If this is the first run then tbl_Attachments doesn't exist and this calls a _
function to create the table on the fly.
If DCount("Name", "MSysObjects", "Name = 'tbl_Attachments' And Type = 1") = 0 Then
Call CreateAttachmentsTable
End If
SQL = "DELETE * FROM tbl_Attachments"
DoCmd.SetWarnings False
DoCmd.RunSQL SQL, True
DoCmd.SetWarnings True
CreateToAttach = Trim(CreateToAttach)
If Right(CreateToAttach, 1) = ";" Then
CreateToAttach = Left(CreateToAttach, Len(CreateToAttach) - 1)
End If
Do Until Len(Trim(CreateToAttach)) = 0
If InStr(1, CreateToAttach, ";", vbTextCompare) = 0 And Len(Trim(CreateToAttach)) > 0 Then
ReportName = Trim(CreateToAttach)
CreateToAttach = " "
Else
ReportName = Left(Trim(CreateToAttach), InStr(1, CreateToAttach, ";", vbTextCompare) - 1)
CreateToAttach = Trim(Mid(CreateToAttach, Len(ReportName) + 2, 150))
End If
AttachType = DLookup("Type", "MSysObjects", "Name = '" & ReportName & "'")
'-32764 = Report
'1 = Native Acc Table
'6 = Attached Acc/Excel/Foxpro Tables
'4 = ODBC Tables
'5 = Queries
DoCmd.SetWarnings False
If UCase(Dir("C:\TEMP", vbDirectory)) <> "TEMP" Then
MkDir "C:\TEMP"
End If
Select Case AttachType
Case -32764
DoCmd.OutputTo acOutputReport, ReportName, acFormatRTF, _
"C:\TEMP\" & ReportName & ".rtf", False
SQL = "INSERT INTO tbl_Attachments (File_Name, Delete_Later) " & _
"VALUES( 'C:\TEMP\" & ReportName & ".rtf',True)"
Case 1, 4, 5, 6
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, ReportName, _
"C:\TEMP\" & ReportName & ".xls", True
SQL = "INSERT INTO tbl_Attachments (File_Name, Delete_Later) " & _
"VALUES( 'C:\TEMP\" & ReportName & ".xls',True)"
Case Else
DoCmd.TransferText acExportDelim, , ReportName, _
"C:\TEMP\" & ReportName & ".txt", True
SQL = "INSERT INTO tbl_Attachments (File_Name, Delete_Later) " & _
"VALUES( 'C:\TEMP\" & ReportName & ".txt',True)"
End Select
DoCmd.RunSQL SQL, True
Debug.Print ReportName
DoCmd.SetWarnings True
Debug.Print CreateToAttach & " -- " & ReportName
Loop
ExistToAttch = Trim(ExistToAttch)
If Right(ExistToAttch, 1) = ";" Then
ExistToAttch = Left(ExistToAttch, Len(ExistToAttch) - 1)
End If
Do Until Len(Trim(ExistToAttch)) = 0
If InStr(1, ExistToAttch, ";", vbTextCompare) = 0 And Len(Trim(ExistToAttch)) > 0 Then
ReportName = Trim(ExistToAttch)
ExistToAttch = " "
Else
ReportName = Left(Trim(ExistToAttch), InStr(1, ExistToAttch, ";", vbTextCompare) - 1)
ExistToAttch = Trim(Mid(ExistToAttch, Len(ReportName) + 2, 150))
End If
SQL = "INSERT INTO tbl_Attachments (File_Name, Delete_Later) " & _
"VALUES('" & ReportName & "',False)"
DoCmd.SetWarnings False
DoCmd.RunSQL SQL, True
Debug.Print ReportName
DoCmd.SetWarnings True
Loop
End Function
Public Function CreateAttachmentsTable()
'This function creates a table to store the list of attachments _
to be sent with an e-mail.
Dim DB As DAO.Database
Dim TableName As DAO.TableDef
Dim FieldName As DAO.Field
Dim FieldProperty As Property
Dim I As Integer
Set DB = CurrentDb()
Set TableName = DB.CreateTableDef("tbl_Attachments")
With TableName
.Fields.Append .CreateField("File_Date", dbDate)
.Fields.Append .CreateField("File_Name", dbText, 75)
.Fields.Append .CreateField("Transmitted", dbBoolean)
.Fields.Append .CreateField("Delete_Later", dbBoolean)
.Fields.Append .CreateField("Index_Num")
.Fields("Index_Num").Type = dbLong
.Fields("Index_Num").Attributes = dbAutoIncrField
.Fields("File_Name").AllowZeroLength = True
.Fields("File_Date").DefaultValue = "Date()"
End With
DB.TableDefs.Append TableName
DoCmd.SelectObject acTable, "tbl_Attachments", True
End Function
< edited server name, email addresses as an anti-SPAM measure jimhorn PE >
|
|
|
|
|
