toplu olarak pdf mail atma

[Emir Hüseyin Çoban]

. . .

İmzanız bilgisayarda html olarak kayıtlıdır. Öncelikle bu dosyanın yolu gerekiyor.
Genelde şu dosya yolunda olur.
C:\Users\KullanıcıAdı\AppData\Roaming\Microsoft\Signatures

Bu dosya yolundan cıkmazsa. Bilgisayarınızda C sürücüsünde imza isminizi aratın.

IP olur, harddisk olur başka seri numaralarına göre açılışta kontrol ettirebilirsiniz. Ancak excel ve vba yı iyi bilen birini durdurmaz...

. . .

 

[somon1]

hocam,
imza yolunu buldum explorer'a kopyala enter deyice çıkıyor sıkıntı yok.
Sizden mevcut koda IP ve bu yolu eklemem gereken yeri rica edebilirmiyim.
Bu arada amacım arkadaşların kurcalamasını ordan oraya taşımasını engellemek.

teşekkürler

 

[Emir Hüseyin Çoban]

. . .

Kodların son halini ekleyiniz.

Tablonun taşınması değil ama, taşındığı yerde çalışmamasını yapabiliriz.

. . .

 

[somon1]

Sub KOD()

Dim SG As Worksheet: Set SG = Sheets("GÖNDEREN")
Dim SF As Worksheet: Set SF = Sheets("FİRMALAR")
Dim S16 As Worksheet: Set S16 = Sheets("2016 FİYAT TEKLİFİ")
Dim SR As Worksheet: Set SR = Sheets("RAPOR")

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

For i = SG.Range("B6") To SG.Range("C6")

S16.Range("F6") = SF.Cells(i + 1, "B")
S16.Range("F8") = SF.Cells(i + 1, "C")
S16.Range("F9") = SF.Cells(i + 1, "D")
S16.Range("F10") = SF.Cells(i + 1, "E")
S16.Range("F11") = SF.Cells(i + 1, "F")
S16.Range("F12") = SF.Cells(i + 1, "G")
S16.Range("B16") = SF.Cells(i + 1, "C")

If SF.Cells(i + 1, "F") Like "*" & "@" & "*" Then

On Error Resume Next
yol = ThisWorkbook.Path & "\PDF\"
Soldan = Left(SF.Cells(i + 1, "B"), 15)
isim = Soldan & "_Fiyat Teklif_" & Format(Now, "ddmmyy_hhmmss")
S16.Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=yol & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error GoTo 0

Dim xlOutlook As Object
Dim xlMail As Object
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)

With xlMail
.To = SF.Cells(i + 1, "F").Value
.CC = ""
.Subject = SF.Cells(i + 1, "G").Value
.Body = ""
.Attachments.Add yol & isim & ".pdf"
.Save
'.Display
.Send
End With

sonsat = SR.Cells(Rows.Count, "A").End(3).Row + 1
SR.Cells(sonsat, "A") = SF.Cells(i + 1, "B")
SR.Cells(sonsat, "B") = SF.Cells(i + 1, "F").Value
SR.Cells(sonsat, "C") = Now

Set xlMail = Nothing
Set xlOutlook = Nothing
Kill yol & isim & ".pdf"

Application.Wait (Now() + TimeValue("00:00:59")) ' 59 SANİYE
End If
Next i

SG.Select

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox " B i t t i"
End Sub

 

[Emir Hüseyin Çoban]

. . .

IP kodlarını forumdan aldım. Deneyiniz.

Sub KOD()
    
    If Err.Number <> 0 Then
        MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _
        "Windows Management Instrumentation"
        Exit Sub
        On Error GoTo 0
    End If
    strComputer = "."
    Set objWMI = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    
    Set collIP = objWMI.ExecQuery _
    ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")
    
    For Each RetVal In collIP
        If Left(RetVal.IPAddress(0), 1) <> 0 Then
            ip1 = RetVal.IPAddress(0)
        End If
    Next
    
    If ip1 <> "192.168.1.1" Then
        MsgBox "Tabloyu Kullanma Yetkiniz Yok!..", vbCritical
        Exit Sub
    Else
        
        Dim SG As Worksheet: Set SG = Sheets("GÖNDEREN")
        Dim SF As Worksheet: Set SF = Sheets("FİRMALAR")
        Dim S16 As Worksheet: Set S16 = Sheets("2016 FİYAT TEKLİFİ")
        Dim SR As Worksheet: Set SR = Sheets("RAPOR")
        
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        
        For i = SG.Range("B6") To SG.Range("C6")
            
            S16.Range("F6") = SF.Cells(i + 1, "B")
            S16.Range("F8") = SF.Cells(i + 1, "C")
            S16.Range("F9") = SF.Cells(i + 1, "D")
            S16.Range("F10") = SF.Cells(i + 1, "E")
            S16.Range("F11") = SF.Cells(i + 1, "F")
            S16.Range("F12") = SF.Cells(i + 1, "G")
            S16.Range("B16") = SF.Cells(i + 1, "C")
            
            If SF.Cells(i + 1, "F") Like "*" & "@" & "*" Then
                
                On Error Resume Next
                yol = ThisWorkbook.Path & "\PDF\"
                Soldan = Left(SF.Cells(i + 1, "B"), 15)
                isim = Soldan & "_Fiyat Teklif_" & Format(Now, "ddmmyy_hhmmss")
                S16.Select
                ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=yol & isim & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                On Error GoTo 0
                
                Dim xlOutlook As Object
                Dim xlMail As Object
                Set xlOutlook = CreateObject("Outlook.Application")
                Set xlMail = xlOutlook.CreateItem(0)
                
                With xlMail
                    .To = SF.Cells(i + 1, "F").Value
                    .CC = ""
                    .Subject = SF.Cells(i + 1, "G").Value
                    '.Body = ""
                    Set FSO = CreateObject("Scripting.FileSystemObject")
                    imzayolu = "C:\Users\Hüseyin\AppData\Roaming\Microsoft\Signatures\imzaara.htm"
                    Set imza = FSO.OpenTextFile(imzayolu, 1)
                    .HTMLBody = imza.readall
                    .Attachments.Add yol & isim & ".pdf"
                    .Save
                    .Display
                    .Send
                End With
                
                sonsat = SR.Cells(Rows.Count, "A").End(3).Row + 1
                SR.Cells(sonsat, "A") = SF.Cells(i + 1, "B")
                SR.Cells(sonsat, "B") = SF.Cells(i + 1, "F").Value
                SR.Cells(sonsat, "C") = Now
                
                Set xlMail = Nothing
                Set xlOutlook = Nothing
                Kill yol & isim & ".pdf"
                
                Application.Wait (Now() + TimeValue("00:00:59")) ' 59 SANİYE
            End If
        Next i
        
        SG.Select
        
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        MsgBox " B i t t i"
        
    End If
End Sub

. . .

 

[somon1]

hocam,

IP adresimi yazdım çalışmadı.http://www.excel.web.tr/f118/ip-adresinin-bulunmas-305-wmi-11-t7209.html bu linkteki makro ile 3 IP adresim çıktı (pc de vmware var ondan olabilir) gerçek IP almasını nasıl sağlarım.
ikincisi ise imza konusu tamam fakat imzamın altındaki resmi almıyor bunu nasıl aldırabilirim.

teşekkür ederim

 

[Emir Hüseyin Çoban]

. . .

Bana imzanızın olduğu boş bir mail atın.

IP kontrolü yerine diğer seri nolarına kontrol yaptıralım. Yine aynı mantıkla onlarda bilgisayara göre değişik ve uymuyorsa çalışmayı engeller.

. . .

 

[somon1]

gmail hesabınıza gönderdim hocam.

 

[somon1]

hocam bakabildiniz mi?

illa bir bilgisayara sınırlamak zorunda değiliz ben sadece kontrol altında olsun istedim.

resmin gözükme isini çözsek benim için yeterli.

zaten kullanmaya başlayınca sıkıntılar ortaya çıkıyor.

teşekkürler

 

[Emir Hüseyin Çoban]

. . .

Sıkıntılar nedir.

İmzadaki resim eklenemiyor. Farklı yollar denemek gerek.

. . .

 

[somon1]

hocam,

Muhasebeci olduğumdan ay sonu olması ve sayım filan derken anca bakaldim kusura bakmayın.

Sıkıntı derken resmin eklenmemesini kastettim.Ve akla gelen yeni konular olabiliyor.

Mesela mail gidince boş gidiyor.Yazı kısmına metin yazdırabilirmilyiz.Gönderen sayfasına bir hücre girip oraya sabit metin girsek,sadece hitap kısmını mail atarken değiştirse hitap isminide FİRMALAR sayfasından yetkili isminden alsa..

teşekkürler

 

[exceluygulamalari]

hocam,

Muhasebeci olduğumdan ay sonu olması ve sayım filan derken anca bakaldim kusura bakmayın.

Sıkıntı derken resmin eklenmemesini kastettim.Ve akla gelen yeni konular olabiliyor.

Mesela mail gidince boş gidiyor.Yazı kısmına metin yazdırabilirmilyiz.Gönderen sayfasına bir hücre girip oraya sabit metin girsek,sadece hitap kısmını mail atarken değiştirse hitap isminide FİRMALAR sayfasından yetkili isminden alsa..

teşekkürler

Merhabalar,

Kod yazmadan bu işi topluca halletmek isterseniz, adres posta birleştirme kullanabileceğinizi biliyor muydunuz?

Eğer müşterilerin anket vb. cevaplarına istinaden PDF mailler atılacak ise bunu tamamen otomatik olarak kurabileceğinizi biliyor muydunuz?

Sırası ile ilgili linkleri paylaşıyorum:

https://exceluygulamalari.wordpress.com/2016/03/08/mailings-sablon-ile-coklu-dosya-olusturma/


https://exceluygulamalari.wordpress.com/2016/03/10/mailings-internet-uzerinden-otomasyon/

Umarım faydalı bulursunuz.
Saygılarımla.

 

[hamitcan]

Sayın exceluygulamalari, tebrikler güzel bir makale olmuş. Moderatör arkadaşlardan rica ederseniz Excel Dershanesi bölümüne ekleyebilirler belki.

 

[Eyupcan Tasar]

Sayın exceluygulamari, gerçekten çok güzel bir çalışma olmuş. Birçok kişinin faydalanacağına eminim.

 

[exceluygulamalari]

Sayın exceluygulamalari, tebrikler güzel bir makale olmuş. Moderatör arkadaşlardan rica ederseniz Excel Dershanesi bölümüne ekleyebilirler belki.

Sayın exceluygulamari, gerçekten çok güzel bir çalışma olmuş. Birçok kişinin faydalanacağına eminim.

Teşekkür ederim,
Türkçe olarak bu tarz detaylı ve uygulamaya yönelik anlatımları bulmakta zorlanıyoruz, özellikle de eğitimine devam eden, iş dünyasında yoğunluk, evrak yükü altında zorluk çekenlerin kolayca ulaşabileceği bir kaynak oluşturmak istedim.

Beğenmeniz sevindirici gerçekten, sağolun.
Saygılarımla.