AccessTr.neT

Merhaba,

Mail gönderirken metin alanının renlendirmek istiyorum. aşağıdaki kodda nasıl bir değişiklik yapılmalıdır.

Teşekkürler , iyi akşamlar

///

Function SendMail()

Dim objCDOMail As Object

 

Const cdoAnonymous = 0

Const cdoBasic = 1

Const cdoNTLM = 2

Set objMessage = CreateObject("CDO.Message")

objMessage.Subject = Me.txtKonu

objMessage.From = Me.txtGonderen & "<" & Me.txtmailadresi & ">"

objMessage.To = Me.Metin7



objMessage.HTMLBody = txtmetin



On Error GoTo Hata



If IsNull(Me.txtEklenti) Or Me.txtEklenti = "" Then

Else

    If InStr(1, Me.txtEklenti, ",") > 0 Then

        Dosya = Split(Me.txtEklenti, ",")

        For I = LBound(Dosya) To UBound(Dosya)

            objMessage.AddAttachment Dosya(I)

        Next

    Else

        objMessage.AddAttachment Me.txtEklenti

    End If

End If



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Me.txtsunucuadresi



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/sendusername") = Me.txtmailadresi



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Me.txtmailsifre



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False



objMessage.Configuration.Fields.Item _

("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60



objMessage.Configuration.Fields.Update



objMessage.Send



MsgBox "Mail gönderimi başarılı.", vbInformation, "İşlem tamam"

Exit Function

Hata: MsgBox "Mail gönderimi başarısız.", vbCritical, "Hata oluştu."

End Function



Private Sub Ayrıntı_Click()



End Sub



Private Sub Ekle_Click()

If IsNull(Me![txtEklenti]) Then

    Dosya = GetOpenFile_CLT("", "Gönderilecek Dosya Seçin.")

    Me![txtEklenti] = Dosya

    Me.Metin22 = Dir(Dosya)

    Dosya = ""

Else

    Dosya = GetOpenFile_CLT("", "Gönderilecek Dosya Seçin.")

    Me![txtEklenti] = Me![txtEklenti] & "," & Dosya

    Me.Metin22 = Me.Metin22 & "," & Dir(Dosya)

End If

End Sub



Private Sub Form_Open(Cancel As Integer)

Me.ProgressBar1.Visible = False

End Sub



Private Sub Kapat_Click()

DoCmd.Close



End Sub

Private Sub Komut13_Click()



If IsNull(Metin7) Or IsNull(txtGonderen) Or IsNull(txtKonu) Or IsNull(txtsunucuadresi) Or IsNull(txtmailadresi) Or IsNull(txtmailsifre) Then

    

        MsgBox "Tüm alanları eksiksiz olarak doldurmanız gerekmektedir kontrol edip tekrar deneyiniz!! ", vbCritical + vbOKOnly, "Eksik Bırakılan Alan !!!"

        Exit Sub

Else

Me.ProgressBar1.Visible = True



Dim I As Integer



   For I = 1 To 10000



      ProgressBar1.Value = (I / 10000) * 100







Next I

SendMail

End If

Me.ProgressBar1.Visible = False

End Sub



Private Sub Sil_Click()

Me.txtEklenti = Null

Me.Metin22 = Null

End Sub

///

objMessage.HTMLBody = txtmetin

satırında Html kodları yollayabilirsiniz. dizaynınız karşı tarafa aynen gider.

svs007

Yandemir