• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excelden email gönderme

Katılım
23 Temmuz 2004
Mesajlar
59
Excel Vers. ve Dili
Excel 2003 - ing
Merhaba arkadaşlar,

Excelde VBA kullanarak listemdeki kişilere özel email göndermek istiyorum.

Liste şu şekilde,
A sütunu: Ad ve Soyad
B sütunu: Email adresi
C sütunu: Toplam Tutar

Kullandığım mail programı Lotus Notes.

Aşağıdaki kod istediğimi yapıyor ama mail mesajı 255 karaktere sınırlı. Kodları daha fazla karakter gönderecek şekilde düzenlememiz mümkünmü

Kod:
Private Declare Function ShellExecute Lib "Shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEMail()
    Dim Email As String, Subj As String
    Dim msg As String, URL As String
    Dim r As Integer, x As Double
    For r = 2 To 2 'data in rows 2-4
'       Get the email address
        Email = Cells(r, 2)
 
'       Message subject
        Subj = "Subject Here"
'       Compose the message
        msg = ""
        msg = msg & "Dear " & Cells(r, 1) & "," & vbCrLf & vbCrLf
        msg = msg & "Mail body text "
        msg = msg & Cells(r, 3).Text & "." & vbCrLf & vbCrLf
        msg = msg & "William Rose" & vbCrLf
        msg = msg & "President"
 
'       Replace spaces with %20 (hex)
        Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
        msg = Application.WorksheetFunction.Substitute(msg, " ", "%20")
 
'       Replace carriage returns with %0D%0A (hex)
        msg = Application.WorksheetFunction.Substitute(msg, vbCrLf, "%0D%0A")        '       Create the URL
        URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & msg
'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next r
End Sub
 
Geri
Üst