Mail gönderme Sorunu

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Merhabalar,

Daha önce aşağıda ki kodlar ile mail gönderimi yapabiliyordum. Ancak bilgisayarı formatladıktan sonra gönderemiyorum. Pdfmaker eklentisini kuramıyorum. Bunun için ne yapmam gerekiyor ?

Yardımlarınız için teşekkür ederim.

Kod: 
Sub MailGonderGündüzVardiya()

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
 
    If [G2] = "" Then
MsgBox "Lütfen Tarih Giriniz!", vbInformation, "MSC"
Range("G2").Select
GoTo 10
Else
    If [G4] = "" Then
MsgBox "Lütfen Vardiya Belirtiniz!", vbInformation, "MSC"
Range("G4").Select
GoTo 10
Else
   If [B93] = "" Then
MsgBox "Lütfen İmza Belirtiniz!", vbInformation, "MSC"
Range("B93").Select
GoTo 10
Else
 
 
  Title = [G2] & " - " & [G4]
  Kime = Range("V2")
  Bilgi = Range("V3")
  'Gizli = Range("V4")
  Mesaj = Range("V5")
                    
'  PdfFile = ActiveWorkbook.FullName
'  i = InStrRev(PdfFile, ".")
'  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "" & [G2] & "  " & [G4] & ".pdf"

  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    '"....," & vbLf & vbLf _
     '     & " ....." & vbLf & vbLf _
      '    & "...." & vbLf _
       '   & [C81] & vbLf _
        '  & [C83] & vbLf & vbLf
    .Attachments.Add PdfFile
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"
    End If
    On Error GoTo 0
  
  End With

  Kill PdfFile

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing


Hata Ekranı ekli resim
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosyayı yada sayfayı PDF olarak kaydetme özelliği 2010 versiyonla beraber gelmiştir.

Eğer Excel 2007 kullanıyorsanız PDF kaydetmek için bir eklenti kurmanız gerekmektedir. Eklentiye nette bazı kaynaklardan ulaşabilirsiniz.
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Dosyayı yada sayfayı PDF olarak kaydetme özelliği 2010 versiyonla beraber gelmiştir.

Eğer Excel 2007 kullanıyorsanız PDF kaydetmek için bir eklenti kurmanız gerekmektedir. Eklentiye nette bazı kaynaklardan ulaşabilirsiniz.
Genişletmek için tıkla ...
Merhaba hocam, Ofiice 2016 Pro kullanıyorum.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu durumda sayfayı PDF olarak kayıt etmede sorun yaşamamanız gerekir.

Kaydedilen dosyanın maile eklenmesinde sorununuz var sanırım.

Dosyanızı paylaşırsanız inceleme fırsatımız olabilir.
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Bu durumda sayfayı PDF olarak kayıt etmede sorun yaşamamanız gerekir.

Kaydedilen dosyanın maile eklenmesinde sorununuz var sanırım.

Dosyanızı paylaşırsanız inceleme fırsatımız olabilir.
Genişletmek için tıkla ...
Merhaba hocam, ilginç bir durumla karşılaştım. Ofiice'yi ekli resimde belirtilen linkten online indirdiğimde PDFMaker eklentisi ekleyemiyorum. Çok uğraştım bir çözüm bulamadım. Ancak Ofiice'yi CD'den yüklediğimde herhangi bir sorun yok.


Teşekkür ederim.
 

Ekli dosyalar

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Bu durumda sayfayı PDF olarak kayıt etmede sorun yaşamamanız gerekir.

Kaydedilen dosyanın maile eklenmesinde sorununuz var sanırım.

Dosyanızı paylaşırsanız inceleme fırsatımız olabilir.
Genişletmek için tıkla ...

Pdf ekleme kısmını aşağıda ki mantık gibi yapılabilir mi diğer dosya ki mantıkta gönderim sıkıntısı olmuyor.

Pdf dosyası masaüstünde bir klasöre kaydedildikten sonra e-mail e ekliyor.

Kod: 
Set nesne = CreateObject("Scripting.FileSystemObject")
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")

yol = masaustuyolu & "\" & Format(Date, "yyyy") & " Üretim Raporları"
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol

altklas = Format(Date, "dd.mm.yyyy") & " " & " - " & [B11]
yol = yol & "\" & altklas
If nesne.FolderExists(yol) = False Then nesne.CreateFolder yol

Filename:=yol & "\" & pdff, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ofis 2016 kullanıyorsanız PDFMaker eklentisine ihtiyacınız olmayacaktır. Ayrıca bu eklentiyi neden yükleyemediğiniz konusunda açıkçası bir fikrim yok. Sistemsel bir sorun olabilir.

İlk paylaştığınız kod kontrol ettiğim kadarıyla makroyu çalıştırdığınız dosyanızın bulunduğu klasöre PDF dosyasını kayıt edip mail olarak gönderiyor.

Son gönderdiğiniz örnek dosyada kod satırlarında eksiklik var. Sanırım kopyala-yapıştır yaparken bir eksiklik oldu. Bu sebeple inceleyemedim.
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Ofis 2016 kullanıyorsanız PDFMaker eklentisine ihtiyacınız olmayacaktır. Ayrıca bu eklentiyi neden yükleyemediğiniz konusunda açıkçası bir fikrim yok. Sistemsel bir sorun olabilir.

İlk paylaştığınız kod kontrol ettiğim kadarıyla makroyu çalıştırdığınız dosyanızın bulunduğu klasöre PDF dosyasını kayıt edip mail olarak gönderiyor.

Son gönderdiğiniz örnek dosyada kod satırlarında eksiklik var. Sanırım kopyala-yapıştır yaparken bir eksiklik oldu. Bu sebeple inceleyemedim.
Genişletmek için tıkla ...
Hocam, forumda araştırma yaparken şu mesajınızı gördüm. Dosyama uyguladım çalışıyor ancak bir değişikliğe ihtiyacım var. Dosyayı masaüstünde Vardiya Klasörü içerisine kaydettikten sonra mail göndersin istiyorum. Ayrıca dosya ismini iki farklı hücreden alıyor onu ekyemedim.

Şu satırı Dosya_Adi = Range("AX18").Value & ".pdf" şöyle yapmak istedim Dosya_Adi = Range("G2").Value & Range("G4").Value & ".pdf"


Kod: 
Sub PDF_KAYDET()
    If Range("AX18").Value = "" Then
        MsgBox "Lütfen dosya adını yazınız!", vbCritical
        Exit Sub
    End If

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Dosya_Adi = Range("AX18").Value & ".pdf"

    Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    MsgBox "Dosyanız kayıt edilmiştir."
End Sub

Sub MAIL_GONDER()
    Dim Uygulama As Object
    Dim Yeni_Mail As Object
   
    If Range("AX18").Value = "" Then
        MsgBox "Lütfen dosya adını yazınız!", vbCritical
        Exit Sub
    End If

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Dosya_Adi = Range("AX18").Value & ".pdf"

    Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
   
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    With Yeni_Mail
        .Subject = Range("AX14").Value
        .Body = Range("AX21").Value
        .Attachments.Add Yol & "\" & Dosya_Adi
        .Save
        If Range("AX10").Value = "" Then
            .To = ""
            .Display
        Else
            .To = Range("DN17").Value
            .Send
            MsgBox "Mail gönderildi."
        End If
    End With
   
    Set Uygulama = Nothing
    Set Yeni_Mail = Nothing
End Sub

Teşekkür ederim.
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Hocam, şu şekilde yapıyorum ama çalışmıyor.

Kod: 
 Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   klasoradi = Yol & "\" & ("Vardiya Raporları")
   dosyaadi = [G2] & [G4] & ".pdf"
    
      

    Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & klasoradi & "\" & dosyaadi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    MsgBox "Dosyanız kayıt edilmiştir."

 
 
 
  Title = [G2] & " - " & [G4]
  Kime = Range("V2")
  Bilgi = Range("V3")
  Gizli = Range("V4")
  Mesaj = Range("V5")
                    

 

  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
        
  .Attachments.Add Yol & "\" & klasoradi & "\" & dosyaadi
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"
    End If
    On Error GoTo 0
  
  End With

  Kill PdfFile

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Verdiğiniz kod içinde kaydedilen PDF dosyası en sonunda klasörden siliniyor.

Bu şekilde mi olmasını istiyorsunuz?
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Verdiğiniz kod içinde kaydedilen PDF dosyası en sonunda klasörden siliniyor.

Bu şekilde mi olmasını istiyorsunuz?
Genişletmek için tıkla ...
Hocam en Son şu şekilde düzenledim.

Kod: 
Sub MailGonderGündüzVardiya()

  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
 
    If [G2] = "" Then
MsgBox "Lütfen Tarih Giriniz!", vbInformation, "MSC"
Range("G2").Select
GoTo 10
Else
    If [G4] = "" Then
MsgBox "Lütfen Vardiya Belirtiniz!", vbInformation, "MSC"
Range("G4").Select
GoTo 10
Else
   If [B93] = "" Then
MsgBox "Lütfen İmza Belirtiniz!", vbInformation, "MSC"
Range("B93").Select
GoTo 10
Else
 
 
Set nesne = CreateObject("Scripting.FileSystemObject")
masaustuyolu = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
AyAdi = Format(Date, "mmmm yyyy") & " Vardiya Üretim Raporları"
dosyaadi = [G2] & " " & [G4]
klasorara = nesne.FolderExists(masaustuyolu & "\" & AyAdi)
If klasorara = False Then nesne.CreateFolder masaustuyolu & "\" & AyAdi

ActiveSheet.Range("$B$2:$R$96").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        masaustuyolu & "\" & AyAdi & "\" & dosyaadi & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
 
  Title = [G2] & " - " & [G4]
  Kime = Range("V2")
  Bilgi = Range("V3")
  'Gizli = Range("V4")
  Mesaj = Range("V5")
                    
  PdfFile = PdfFile & "" & [G2] & "  " & [G4] & ".pdf"

  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

With OutlApp.CreateItem(0)
  
    .Subject = Title
    .To = Kime
    .CC = Bilgi ' bilgi olarak kime
    .BCC = Gizli
    .Body = Mesaj
    
     .Attachments.Add masaustuyolu & "\" & AyAdi & "\" & dosyaadi & ".pdf"
 
  
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail gonderilemedi", vbExclamation, "MSC"
    Else
      MsgBox " E-mail gonderildi... İşleminiz tamamlanmıştır..! ", vbInformation, "MSC"
    End If
    On Error GoTo 0
  
  End With

  If IsCreated Then OutlApp.Quit

  Set OutlApp = Nothing
 
End If
10:
End If
End If

Application.Calculation = xlAutomatic

End Sub

Masaüstünde 2020 Üretim Vardiya Raporları klasörü oluşturup, 2020 Üretim Vardiya Raporları klasörü içerisine bu ayki raporlar klasörü oluşturup, dosyayı kaydetsin ve mail göndersin istiyorum.

Teşekkür ederim.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
       
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
       
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("2020 GÜNDÜZ")
       
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
       
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
       
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
       
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "yyyy mm")
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    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 Yeni_Mail = Uygulama.CreateItem(0)
   
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".pdf"

    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    With Yeni_Mail
        .Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V4").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
   
    'S1.PageSetup.PrintArea = "$B$2:$R$96"
    'S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
   
    MsgBox "E-mail gönderilmiştir.", vbInformation
   
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
      
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
      
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("2020 GÜNDÜZ")
      
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
      
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
      
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
      
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "yyyy mm")
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    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 Yeni_Mail = Uygulama.CreateItem(0)
  
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".pdf"

    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    With Yeni_Mail
        .Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V4").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
  
    'S1.PageSetup.PrintArea = "$B$2:$R$96"
    'S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
  
    MsgBox "E-mail gönderilmiştir.", vbInformation
  
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub
Genişletmek için tıkla ...
Hocam, gayet güzel çalışıyor.Emeğinize sağlık, teşekkür ederim.


Şu şekilde düzenledim.

Kod: 
Option Explicit

Sub MailGonderGündüzVardiya()


  Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
      
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
      
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("2020 GÜNDÜZ")
      
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
      
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
      
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
      
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "mmmm yyyy") & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    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 Yeni_Mail = Uygulama.CreateItem(0)
  
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".pdf"

    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    With Yeni_Mail
        '.Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V5").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
  
   MsgBox "E-mail gönderilmiştir.", vbInformation
  
    S1.PageSetup.PrintArea = "$B$2:$R$96"
    S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
  
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
      
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
      
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("2020 GÜNDÜZ")
      
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
      
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
      
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
      
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "yyyy mm")
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    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 Yeni_Mail = Uygulama.CreateItem(0)
  
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".pdf"

    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    With Yeni_Mail
        .Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V4").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
  
    'S1.PageSetup.PrintArea = "$B$2:$R$96"
    'S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
  
    MsgBox "E-mail gönderilmiştir.", vbInformation
  
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub
Genişletmek için tıkla ...
Hocam, Sayfa adını A1 hücresinden aldırmak için kodda nasıl değişiklik yapmam gerekiyor ?

Kod: 
Set S1 = K1.Sheets("2020 GÜNDÜZ")
Yardımlarınız için teşekkür ederim
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Set S1 = K1.Sheets(Range("A1").Text)
 
M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Altın Üyelik Bitiş Tarihi
08-09-2028
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
      
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
      
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets(Range("D1").Text)
      
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
      
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
      
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
      
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "yyyy mm")
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    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 Yeni_Mail = Uygulama.CreateItem(0)
  
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".pdf"

    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

    With Yeni_Mail
        .Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V4").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
  
    'S1.PageSetup.PrintArea = "$B$2:$R$96"
    'S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
  
    MsgBox "E-mail gönderilmiştir.", vbInformation
  
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub
Genişletmek için tıkla ...
Merhaba Hocam, daha önce verdiğiniz bu kodlarla tabloyu, EXCEL sayfası olarak gönderim yapmak istiyorum. Uğraştım ama yapamadım.
Yardımlarınız için teşekkür ederim.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Excel dosyası formatında mı göndermek istiyorsunuz?
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,731
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
      
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
      
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets(Range("D1").Text)
      
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
      
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
      
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
      
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "yyyy mm")
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    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 Yeni_Mail = Uygulama.CreateItem(0)
  
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".xlsx"

    S1.Copy
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Yol & Application.PathSeparator & Dosya_Adi, 51
    Application.DisplayAlerts = True
    
    With Yeni_Mail
        .Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V4").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
  
    'S1.PageSetup.PrintArea = "$B$2:$R$96"
    'S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
  
    MsgBox "E-mail gönderilmiştir.", vbInformation
  
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst