öncelikle referanslardan Microsof ActiveX Data Object x.x library eklenmeli
çalışmanıza modül ekleyip modüle aşağıdaki kodu yazın
Function GenHTMLTable() As String ' (sQuery As String) As String
Dim RS As ADODB.Recordset
Dim Fld As ADODB.Field
Set RS = New ADODB.Recordset
sQuery = " SELECT Table1.ID, Table1.ADI, Table1.SOYADI, Table1.NOTE FROM Table1;"
On Error GoTo Error_Handler
RS.Open sQuery, CurrentProject.Connection
RS.MoveFirst
With RS
sHTML = "<table>" & vbCrLf
sHTML = sHTML & vbTab & "<tr>" & vbCrLf
For Each Fld In RS.Fields 'loop through all the fields of the tables
sHTML = sHTML & vbTab & vbTab & "<th>" & Fld.Name & "</th>" & vbCrLf
Next
sHTML = sHTML & vbTab & "</tr>" & vbCrLf
If .RecordCount <> 0 Then
Do While Not .EOF
sHTML = sHTML & vbTab & "<tr>" & vbCrLf
For Each Fld In RS.Fields 'loop through all the fields of the tables
sHTML = sHTML & vbTab & vbTab & "<td>" & Fld.Value & "</td>" & vbCrLf
Next
sHTML = sHTML & vbTab & "</tr>" & vbCrLf
.MoveNext
Loop
End If
sHTML = sHTML & "</table>"
End With
GenHTMLTable = sHTML
Error_Handler_Exit:
On Error Resume Next
If Not RS Is Nothing Then
RS.Close 'Close the recordset
Set RS = Nothing
End If
' If Not db Is Nothing Then Set db = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GenHTMLTable" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
mail butonunun kodu
Private Sub Command0_Click()
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.To = Me.Text42
.subject = Me.Text46
.HTMLBody = GenHTMLTable
'.DeleteAfterSubmit = True 'This would let Outlook send th note without storing it in your sent bin
.Send
End With
'MsgBox MailOutLook.Body
MsgBox ""
Exit Sub
email_error:
MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Description
Resume Error_out
Error_out:
'Debug.Print GenHTMLTable
End Sub
dilerim işinize yarar
#1
Mail.7z
(Dosya Boyutu: 22,58 KB | İndirme Sayısı: 4)
Mail.rar
(Dosya Boyutu: 22,34 KB | İndirme Sayısı: 6)
