Outlook ile ilet denilen iletilerin içeriğidek email adreslerini kime kısmına ekleme

[mustilem23]

Merhaba arkadaşlar,

Outlook u kullanır iken bir sıkıntım mevcut ,şöyleki,

bana gelen iletiler genelde iş denetçisi tarafından denetlenip bana iletiliyor dolayısı ile tümünü yanıtla dediğim de müşteri emailleri kime yada bilgi emailine eklenemiyor ,outlok için vba kodu yapılabilmesi mümkün mü ,

ileti içerisin deki tüm email adreslerini alıp bilgi kısmına yada kime kısmına ekleyebilecek bir outlook vba kodu hakkında yardımcı olabilir misiniz rica etsem ,resmen tek tek 10 müşterinin emailini kopyala yapıştır yapıyorum.

 

[mustilem23]

arkadaşlar ,

excel için böyle bir kod buldum outlook için uyarlanabilir mi acaba yardımcı olabilir misiniz rica etsem.


birde ricam benim emailler genelde [mailto:goktenur.paksoy@tirsan.com.tr] bu şekilde geliyor .

Sub ayikla()
For x = 1 To [a65536].End(3).Row
    d = Split(Cells(x, 1))
        For Each elem In d
            If InStr(elem, "@") Then
               a = a + 1
                   Sheets("sayfa2").Cells(a, 1) = Trim(Replace(Replace(Replace(elem, ",", ""), "e-mail:", ""), Chr(160), ""))
            End If
        Next elem
Next x
Sheets("sayfa2").Select
End Sub

 

[Asri]

Bu liknte işizi kolaylaştıracak bir kaç yöntem var,

https://www.msoutlook.info/question/564

Anladığım en basit hali ile,

Maili açın, eklentinin başındaki İleti tıklayıp Ctrl+a ve ctrl+a yapın.

Tümünü yanıtla yapıp Ctrl+v yapın.

İsimler ve ekler aynı maile gelmiş olacaktır.

 

[mustilem23]

Asri bey ilginiz için teşekkürler ,

verdiğiniz linkteki uygulama ve makrolar e-mail içindeki ek dosyalar için benim sıkıntım ,bana emeil gönderenleri bir tuşa basarak email içindeki tüm email adreslerini alıp kime kısmını yapıştırmak istiyorum ekler çok önemli değil yani.

olay şöyleki müşteriden gelen email iş denetçisi callcenter e geliyor oda ilgili kişiye iletiyor dolayısı ile tümünü yanıtla işlevsiz kalıyor ,bende mecburen kopyala yapıştır yapıyorum,

outlok vba kodu ile yapılabilir mi ? yada geçiçi çözüm için benim göndermiş olduğum kodda düzenleme yapabilmemiz mümkün mü şöyle ki ,

Email i ilet diyerek açacağım tüm yazıları kopyalayıp bir excele yapıştıracağım ve içinden sadece
emil adreslerini alacak ve aralarına ; ekleyerek tek bir hücrede göstertebilir miyiz ,

sonucu böyle yapmak istiyorum ,

sales@gfscargo.co.uk;info@goldcity.co.uk;nastaran@goldcity.co.uk;anika@goldcity.co.uk;roksana@goldcity.co.uk;enquiries@hi-speedfreight.com;enquiries@keyair.co.uk;cs@smaworldwide.com;united.links@btconnect.com;bob@shipit.co.uk

 

[Asri]

Asri bey ilginiz için teşekkürler ,

sonucu böyle yapmak istiyorum ,

sales@gfscargo.co.uk;info@goldcity.co.uk;nastaran@goldcity.co.uk;anika@goldcity.co.uk;roksana@goldcity.co.uk;enquiries@hi-speedfreight.com;enquiries@keyair.co.uk;cs@smaworldwide.com;united.links@btconnect.com;bob@shipit.co.uk

Konuyu yanlış anlamışım, siz mail gövdesindeki mail adreslerini almak istiyormuşsunuz.

Size ilet yapıldığında mail adresleri açık şekilde görünüyor mu? İsim olarak mı görünüyor.

Örnek bir mail içeriği gönderebilir misiniz?

 

[Asri]

Mail gövde metnini text olarak A1 e yapıştırınız.

Aşağıdaki konu deneyiniz.

Sub mail_ayir_regile()
  veri = Cells(1, 1).Value
  Set reg = CreateObject("vbscript.regexp")
  reg.Global = True
  reg.MultiLine = True
  reg.Pattern = "[\_]*([a-z0-9]+(\.|\_*)?)+@([a-z][a-z0-9\-]+(\.|\-*\.))+[a-z]{2,6}"
  Set mailler = reg.Execute(veri)
  liste = ""
  For i = 0 To mailler.Count - 1
      liste = liste & ";" & mailler(i)
  Next
  Cells(1, 2).Value = liste
End Sub

Mail ayırmak için benim yazdığım kod, regular exp. kullanmadan.
Outlook da vba da regular da sorun çıkarıyor. İhtiyaçtan yazıldı. : )

Sub Mail_Ayir_Regsiz()
    harfler = "@._-ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    veri = Cells(1, 1).Value
    say = 1
    sondurum = 1
    liste = ""
    For i = 1 To Len(veri)
      nerede = InStr(sondurum, veri, "@")
      If nerede = 0 Then Exit For
      sagtaraf = ""
      For i1 = nerede To Len(veri)
         harf = Mid(veri, i1, 1)
         If InStr(harfler, harf) > 0 Then
            sagtaraf = sagtaraf + harf
         Else
          Exit For
        End If
      Next i1
      sondurum = i1
      soltaraf = ""
      For i1 = nerede - 1 To 1 Step -1
         harf = Mid(veri, i1, 1)
         If InStr(harfler, harf) > 0 Then
            soltaraf = harf + soltaraf
         Else
          Exit For
        End If
      Next i1
      mail = soltaraf + sagtaraf
      say = say + 1
      liste = liste & ";" & mail
      i = sondurum
    Next i
    Cells(2, 2).Value = liste
End Sub

 

[mustilem23]

Çok teşekkürler.süper oldu şimdilik epey iş görecek ,outlook için vba bulunca bur da diğer arkadaşlar ile yine paylaşırım .

 

[Asri]

Çok teşekkürler.süper oldu şimdilik epey iş görecek ,outlook için vba bulunca bur da diğer arkadaşlar ile yine paylaşırım .

outlook vba sı ile hiç uğramadım. Benimde ilgimi çekiyor. Bir kaç deneme yapıp sonuç alırsam paylaşırım.

 

[mustilem23]

ben inanıyorum sizin uğraşıp ta yapamayacağınız bir excel kodu daha türemedi

 

[Asri]

Mail ayırma ile ilgili benim yazdığım kodu da ekledim.
Sanki daha hızlı çalışıyor gibi : )

 

[Asri]

Outlook VBA ya giriş yapmış olduk. Hadi hayırlısı : )

Bu kod outlook vba da çalıştırılacak.
Önce güvenik merkezinden makroları sorarak etkinleştir deyin.
Tümünü demeyin bu outlook ne olur ne olmaz.

Daha sonra gelen bir mailde İLET deyin. Çıkan ekranda yukarıdaki çubukta sağ tuş / Şeridi Özelliştir deyin.
Geliştirici yi tikleyin.

Bu kodu geliştiricideki menüyü kullanarak Outlook vba da module yapıştırın. Kaydedin.

Daha sonra yine çubukta sağ tuş / şeridi özelleştir deyin.
Yeni Sekme
Yeni Grub dedikten sonra soldaki makrolar dan bu makroyu kısayol olarak atayın.

Artık makronuz kısa yol olarak kullanıma hazır.

Sub Mail_Adresleri_ekle()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim msgbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.ActiveInspector.CurrentItem
    veri = OutMail.Body
    
    harfler = "@._-ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    dahiletme = "asriakdeniz@gmail.com;"
    sondurum = 1
    liste = ""
    For i = 1 To Len(veri)
      nerede = InStr(sondurum, veri, "@")
      If nerede = 0 Then Exit For
      sagtaraf = ""
      For i1 = nerede To Len(veri)
         harf = Mid(veri, i1, 1)
         If InStr(harfler, harf) > 0 Then
            sagtaraf = sagtaraf + harf
         Else
          Exit For
        End If
      Next i1
      sondurum = i1
      soltaraf = ""
      For i1 = nerede - 1 To 1 Step -1
         harf = Mid(veri, i1, 1)
         If InStr(harfler, harf) > 0 Then
            soltaraf = harf + soltaraf
         Else
          Exit For
        End If
      Next i1
      mail = soltaraf + sagtaraf
      If Left(mail, 5) <> "image" And InStr(liste, mail) <= 0 And InStr(dahiletme, mail) <= 0 Then
         liste = liste & ";" & mail
      End If
      i = sondurum
    Next i
    
    OutMail.To = liste
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[mustilem23]

Asri bey günaydın ,

ben biliyordum sizin el atıp ta uygulayamayacağınız bir kod dizini olmasın ,

kod süper çalışıyor ...
fakat geliştirmek adına ,2 sorun tespit ettim şöyleki;

1 örnek aynı email adresinden emailde 10 tane var ise 10 unu da ekliyor yani mükereri engelemek mümkün mü ?

2 imzalar genelde @ ile outlokta kayıtlı olduğu için bunu email sanıyor makro (image002.jpg@01D22AB3.90798000) engellenebilir mi (@ işareti bulunan fakat başı image ise almasın gibi)

 

[Asri]

....
1 örnek aynı email adresinden emailde 10 tane var ise 10 unu da ekliyor yani mükereri engelemek mümkün mü ?

2 imzalar genelde @ ile outlokta kayıtlı olduğu için bunu email sanıyor makro (image002.jpg@01D22AB3.90798000) engellenebilir mi (@ işareti bulunan fakat başı image ise almasın gibi)

Kod güncellendi.
image ile başlayanları almayacak, mükerrer olanları eklemeyecek.

 

[Asri]

dahiletme="asriakdeniz@gmail.com;" satırı eklendi.

Bu değişkene atayacağınız mailleri to kısmına eklemeyecek.
Örneğin kendi mail adresinizi ve diğer eklenmesini istemediğiniz mailleri burada tanımlayabilirsiniz.

 

[mustilem23]

Asri bey ,

müthiş bir macro oldu ,bence siz bunu eklenti haline getirip microsoffta satınız.
Allah razı olsun çok güzel bir işlem oldu ,ellerinize sağlık.

:icelim::icelim::icelim::dua2::mutlu::mutlu:

 

[mustilem23]

dahiletme="asriakdeniz@gmail.com;" satırı eklendi.

Bu değişkene atayacağınız mailleri to kısmına eklemeyecek.
Örneğin kendi mail adresinizi ve diğer eklenmesini istemediğiniz mailleri burada tanımlayabilirsiniz.

Üstad merhaba ,

Dahil etme kısmında güncelleme yapabilmek mümkün müdür ,çok fazla kişi oldu bu alanda belirli bir sayıda kişi eklediğimde alt satıra geçiyor ve hata veriyor şöyle yapılabilir mi dahil etme .....@şirket ismi .com.tr +manuel eklenecek kişiler gibi mümkün müdür.

 

[Asri]

Üstad merhaba ,

Dahil etme kısmında güncelleme yapabilmek mümkün müdür ,çok fazla kişi oldu bu alanda belirli bir sayıda kişi eklediğimde alt satıra geçiyor ve hata veriyor şöyle yapılabilir mi dahil etme .....@şirket ismi .com.tr +manuel eklenecek kişiler gibi mümkün müdür.

Kodlar dahil etme listesini dizi olarak eklenecek şekilde düzenlendi.
Test edilmedi.

Kontrol ediniz.

Sub Mail_Adresleri_ekle()
Dim OutApp As Object
Dim OutMail As Object
Dim msgbody As String
Dim dahiletmeliste(100)

'Dahil edilmeyecek mailleri index i arttırarak yazın.
dahiletmeliste(1) = "asriakdeniz@gmail.com"
dahiletmeliste(2) = "mailadresi2"
dahiletmeliste(3) = "mailadresi3"
dahiletmeliste(4) = "mailadresi4"
dahiletmeliste(5) = "mailadresi5"
dahiletmeliste(6) = "mailadresi6"

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.ActiveInspector.CurrentItem
veri = OutMail.Body

harfler = "@._-ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"


sondurum = 1
liste = ""
For i = 1 To Len(veri)
nerede = InStr(sondurum, veri, "@")
If nerede = 0 Then Exit For
sagtaraf = ""
For i1 = nerede To Len(veri)
harf = Mid(veri, i1, 1)
If InStr(harfler, harf) > 0 Then
sagtaraf = sagtaraf + harf
Else
Exit For
End If
Next i1
sondurum = i1
soltaraf = ""
For i1 = nerede - 1 To 1 Step -1
harf = Mid(veri, i1, 1)
If InStr(harfler, harf) > 0 Then
soltaraf = harf + soltaraf
Else
Exit For
End If
Next i1
Mail = soltaraf + sagtaraf

ekle = True
For j = 1 To UBound(dahiletmeliste)
If InStr(dahiletmeliste(j), Mail) > 0 Then ekle = False
Next j

If Left(Mail, 5) <> "image" And InStr(liste, Mail) <= 0 And ekle Then
liste = liste & ";" & Mail
End If
i = sondurum
Next i

OutMail.To = liste
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[mustilem23]

Üstadım eline sağlık güzel bir güncelleme oldu.