Userform Gözat butonu ile dosya ekleyip mail gönderme.

[Kavinsky]

Üstatlar herkese merhaba.
Userform aracılığı kendi çapımda mail gönderme sistemi yaptım. Textbox lara göre bilgileri seçip mail gönderiyor. Lakin attachments.add olayında takıldım.
Userforma eklediğim Gözat butonu ile dosya seçiyorum. Ama gönderirken hata alıyorum. Benim istediğim gözat butonu ile seçip dosya konumunu yazdırdığım userform8 içerisinde TextBox4 teki path bilgileri attachment olarak alıp göndersin. Eğer böyle bir şey mümkünse çok müteşekkir olurum. Şimdiden yardımlarınız için teşekkür ederim. Dosya çok büyük ve içinde çok kişisel bilgi olduğu için maalesef yükleyemedim.

Mail gönderme kodu

Private Sub CommandButton1_Click()
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim email_ As String
Dim subject_ As String
Dim body_ As String
Dim attach_ As String

Set OutlookApp = CreateObject("Outlook.Application")

email_ = UserForm8.TextBox1.Value
subject_ = UserForm8.TextBox2.Value
body_ = UserForm8.TextBox3.Value

'create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)

Application.DisplayAlerts = False
With MItem
.To = email_
.Subject = subject_
.Body = body_
'.Attachments.Add "C:\FolderName\Filename.txt"
.Send
End With
Application.DisplayAlerts = True
Me.TextBox1 = Empty
Me.TextBox2 = Empty
Me.TextBox3 = Empty
Me.ComboBox1 = Empty
MsgBox "Mail başarıyla gönderildi."
UserForm8.HIDE
End Sub

Gözat Butonu kodları

Mümkünse aşağıdaki kodlarda tüm dosyaları seçebilme imkanı var mı ? sadece Excel uzantılı dosyaları seçiyor.

Private Sub CommandButton2_Click()
Dim txt
txt = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx, Excel macro files (*.xlsm),*.xlsm", 2)
Me.TextBox4 = txt
End Sub

 

[Kavinsky]

Arkadaşlar ufak bir hata yapmışım sanırım ama çözdüm. Kullanmak isteyen olursa aşağıda paylaşıyorum kodları. Userform8 userformun ismidir ,TextBox1: Mail adresi , TextBox2 : Konu TextBox3: Yazacağınız mail ve TextBox4 gözat butonuna bağlı dosya yolu ve mail adresini çektiği sayfa olan ŞİRKET sayfasında mail adreslerinin yazılı olduğu J2:J500 aralığıdır kendinize uyarlayıp kullanabilirsiniz.

Mail gönder butonu kodları

Private Sub ComboBox1_Change()
Me.TextBox1 = Empty
If ComboBox1.Value <> "" Then TextBox1.Value = ComboBox1.Value
End Sub
Private Sub CommandButton2_Click()
Dim txt
txt = Application.GetOpenFilename()
Me.TextBox4 = txt
End Sub
Private Sub UserForm_initialize()
Me.TextBox1 = Empty
With Sheets("ŞİRKET")
For Each Veri In .Range("J2:J500")
If Veri.Value <> "" Then
ComboBox1.AddItem Veri.Value
End If
Next
End With
ComboBox1.ListIndex = 0
ComboBox1.Text = ComboBox1.List(0)
ComboBox1 = Empty
End Sub
Private Sub CommandButton1_Click()
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim email_ As String
Dim subject_ As String
Dim body_ As String
Dim attach_ As String

Set OutlookApp = CreateObject("Outlook.Application")

email_ = UserForm8.TextBox1.Value
subject_ = UserForm8.TextBox2.Value
body_ = UserForm8.TextBox3.Value
bodyS_ = UserForm8.TextBox4.Value

'create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)

Application.DisplayAlerts = False
With MItem
.To = email_
.Subject = subject_
.Body = body_
.Attachments.Add bodyS_
.Send
End With
Application.DisplayAlerts = True
Me.TextBox1 = Empty
Me.TextBox2 = Empty
Me.TextBox3 = Empty
Me.ComboBox1 = Empty
MsgBox "Mail başarıyla gönderildi."
UserForm8.HIDE
End Sub

Gözat Butonu Kodları

Private Sub CommandButton2_Click()
Dim txt
txt = Application.GetOpenFilename()
Me.TextBox4 = txt
End Sub

 

[turist]

Aşağıdaki gibi deneyin.

Private Sub CommandButton2_Click()
Dim txt
txt = Application.GetOpenFilename()
Me.TextBox4 = txt
End Sub

 

[Kavinsky]

Turist hocam , teşekkür ederim emeğinize sağlık.

 

[turist]

turist hocam , teşekkür ederim emeğinize sağlık.

Sağ olun, iyi çalışmalar.

 

[dogu34]

Merhaba biraz yeniyim buralarda kendimce birşeyler yapmaya çalışıyorum bende çalısmaniz için tebrikler bende kullanmak istedim fakat yolu kendime göre nasıl düzenleyeceğimi çözemedim yardımcı olur musunuz

 

[Korhan Ayhan]

Merhaba,

Hangi yolu düzenleyemediniz.

 

[dogu34]

hocam hallettim sağolasın çözdüm

 

[dogu34]

hocam sizi yakalamışken bi sorum olsa bu çalışmayı toplu maile nasıl çevirebiliriz örneğin:musterı adlı sayfamda L Sutununda 200den fazla mail adresim var bunlara göre hangi kodları eklememiz gerekir yardımcı olabilirmisiniz birde aynı sayfada B Sutununda İsimler var bu isimleride body mesajın önüne nasıl alırız farklı şekillerde denedim başarılı olamadım

 

[Korhan Ayhan]

Örnek dosya paylaşınız.

 

[dogu34]

buyrun ekledim.şimdiden ilginize teşekkür ederim

 

[dogu34]

hocam bakma şansınız oldumu

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub CommandButton5_Click()
    Dim Uygulama As Object, Yeni_Mail As Object
    Dim S1 As Worksheet, Veri As Range, Son As Long

    If TextBox9.Value = "" Then
        MsgBox "Lütfen başlık bilgisini giriniz!", vbCritical
        TextBox9.SetFocus
        Exit Sub
    End If

    If TextBox19.Value = "" Then
        MsgBox "Lütfen konu bilgisini giriniz!", vbCritical
        TextBox19.SetFocus
        Exit Sub
    End If
    
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
    
    Set Uygulama = CreateObject("Outlook.Application")

    Set S1 = Sheets("MUSTERI")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    For Each Veri In S1.Range("L2:L" & Son)
        If Veri.Value <> "" Then
            Set Yeni_Mail = Uygulama.CreateItem(0)
            With Yeni_Mail
                .Display
                .To = Veri.Value
                .CC = ""
                .BCC = ""
                .Subject = TextBox9.Value
                .HTMLBody = TextBox19.Value & vbLf & vbLf & .HTMLBody
                .Attachments.Add TextBox20.Value
                .BodyFormat = 2
                .Save
                .Send
            End With
            Application.Wait Now + TimeValue("00:00:05")
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub

Private Sub CommandButton6_Click()
    Dim Dosya As Variant
    Dosya = Application.GetOpenFilename()
    TextBox20 = Dosya
End Sub

 

[dogu34]

hocam elinize emeğinize sağlık çok ama çok teşekkür ederim hiçbir sorun yok çalışmada yanlız outlook ekranda gözüküyor hiç gözükmemesi için nereyi değiştirmemiz lazım birde 5dk arayla 50 şer adrese gönderim sağlayacak dimi

 

[Korhan Ayhan]

Eğer Outlook'ta kullandığınız imzanız yoksa pencereyi göstermeyebiliriz.

Her mailden sonra 5 saniye beklemektedir.

 

[dogu34]

hocam imza yok

 

[Korhan Ayhan]

Kod içindeki .Display satırını silip deneyiniz.

 

[dogu34]

hocam teşekkürler çalışmalarınızda başarılar

 

[dogu34]

Hocam şimdi dikkatimi çekti mail sorunsuz çalışıyor ama htmlbodye yazılan mesajdan önce olması gereken B sütunundaki isimler mailde gözükmüyor zahmet olmazsa onuda eklermisiniz teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

.HTMLBody = Veri.Offset(, -10).Value & vbLf & vbLf & TextBox19.Value & vbLf & vbLf & .HTMLBody