Userform üzerinden Mail Gönderme

[mathematiqcii]

Merhaba Değerli arkadaşlar
Bir kamu kurumunda çalışıyorum. Kullandığım bir excel dosyam var. Burda firmalara tek tek mail gönderiyoruz. Bu zamana kadar şablon mailler gönderiyorduk.
Ancak Oluşturduğum userform içine istediğimi yazmak istiyorum. Fakat iskur no firma adı vergi no gibi bilgileri döngüden alsın diğer kısımları userforma yazdığım metinden alsın istiyorum . Bir kaç bir şey denedim ancak işin çıkamadım . Yardımcı olacak üstadlarımıza şimdiden çok teşekkür ederim. Yapmak istediğim şeyi resim olarak ekledim. Userform 1 içinde aynı şekilde yapmak istiyorum

 

[mathematiqcii]

Yapmak istediğim tam olarak şu
Ben textbox1 e Sayın Yetkili xiskurnox numaralı firmanızın adresi xadresx şeklinde güncellenmiştir. yazdığımda mailller şu şekilde gitsin istiyorum : 1. Mail : Sayın yetkili 1 numaralı firmanızın adresi 1 şeklinde güncellemiştir 2. Mail: Sayın yetkili 2 numaralı firmanızın adresi 2 şeklinde güncellenmiştir.
Yani metinleri textbox1 den alacak ancak x......x kısmını döngüden alacak şekilde mailin body kısmının oluşmasını istiyorum

Private Sub CommandButton1_Click()

Dim Uygulama As Object
Dim Yeni_Mail As Object
Dim mesaj As String
Dim rng As Shape
Dim yol As String
 Set s1 = Sheets("AKTAR")
Set S2 = Sheets("GENEL İŞYERİ")
Set S3 = Sheets("İŞYERİ İLETİŞİM")
Set S4 = Sheets("BİLGİ")
Set Outlook = CreateObject("Outlook.Application")
Set yeni = Outlook.CreateItem(0)
Application.ScreenUpdating = False

yol = Sheets("AKTAR").Range("h15")

If TextBox4.Value = "" Then
MsgBox "MAİL KONUSU BOŞ BIRAKILAMAZ..", vbCritical, "DİKKAT!!"
Exit Sub
End If
If CheckBox1.Value = True Then
onem = 1
Else
onem = 2
End If


For i = 4 To Sheets("BİLGİ").Cells(Rows.Count, "C").End(3).Row

xiskurnox = S4.Range("a" & i)
xfirmadix = S4.Range("c" & i)


Set Uygulama = CreateObject("Outlook.Application")
Set Yeni_Mail = Uygulama.CreateItem(0)
mesaj = TextBox1.Value

With Yeni_Mail


.Subject = TextBox4.Value
.To = S4.Range("J" & i).Value
.body = vbNewLine & mesaj
.Attachments.Add yol
.Importance = onem

.send

End With
Label10.Caption = "     " & i & " . Mail Gönderiliyor..."

Next i



Label10.Caption = " TOPLAM " & i - 2 & " KİŞİYE MAİLLERİNİZ BAŞARIYLA GÖNDERİLMİŞTİR"

End Sub

 

[mathematiqcii]

Sorunum hala devam ediyor. Yardımcı olabilecek yokmu?

 

[mathematiqcii]

..

 

[cems]

Private Sub CommandButton1_Click()

Dim Uygulama As Object
Dim Yeni_Mail As Object
Dim mesaj As String
Dim yol As String
Dim xiskurnox As String
Dim xfirmadix As String
Dim i As Integer
Dim onem As Integer

Dim s1 As Worksheet
Dim S2 As Worksheet
Dim S3 As Worksheet
Dim S4 As Worksheet
Dim Outlook As Object
Dim yeni As Object

Set s1 = Sheets("AKTAR")
Set S2 = Sheets("GENEL İŞYERİ")
Set S3 = Sheets("İŞYERİ İLETİŞİM")
Set S4 = Sheets("BİLGİ")
Set Outlook = CreateObject("Outlook.Application")
Set yeni = Outlook.CreateItem(0)
Application.ScreenUpdating = False

yol = s1.Range("H15").Value

If TextBox4.Value = "" Then
MsgBox "MAİL KONUSU BOŞ BIRAKILAMAZ..", vbCritical, "DİKKAT!!"
Exit Sub
End If

If CheckBox1.Value = True Then
onem = 1
Else
onem = 2
End If

For i = 4 To S4.Cells(Rows.Count, "C").End(xlUp).Row
xiskurnox = S4.Range("A" & i).Value
xfirmadix = S4.Range("C" & i).Value

Set Uygulama = CreateObject("Outlook.Application")
Set Yeni_Mail = Uygulama.CreateItem(0)
mesaj = Replace(TextBox1.Value, "xiskurnox", xiskurnox)
mesaj = Replace(mesaj, "xfirmadix", xfirmadix)

With Yeni_Mail
.Subject = TextBox4.Value
.To = S4.Range("J" & i).Value
.Body = vbNewLine & mesaj
.Attachments.Add yol
.Importance = onem
.Send
End With
Label10.Caption = " " & i - 3 & ". Mail Gönderiliyor..."
Next i

Label10.Caption = " TOPLAM " & i - 4 & " KİŞİYE MAİLLERİNİZ BAŞARIYLA GÖNDERİLMİŞTİR"
End Sub


Şeklinde ama kesinlikle dosyanın bir kopyasını alarak onun ustunde dener misiniz ?