- 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ü
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
