makro ile gmail üzerinden sıkıştırıp mail göndermek

[fkalelinet]

bikaç konu var mail gönderme konusunu çözdüm ekdeki dosya çok açık ve yardımcı oluyor ancak bir klasör içerisindeki 5 excel dosyasını rar il sıkıştırıp gönderme işlemini halledemedim. birçok kod buldum ama win8 ve ofis 2013 kullanıyorum bi türlü çalıştıramadım rar sıkıştırmasını. rar.exe siyah ekranda açılıp kapanıyor ama bir icraat olmuyor.
birde bu benim dosyada şifreyi soruyor sormadan sadece göndermek istiyormusunuz efet hayır çıksın mail şifresi kodda olsun istedim. ama onu da beceremedim.
güncel bir kod bulunması adına yardımcı olurmusunuzz acaba..

 

[fkalelinet]

en azından elinde dosyayı makro ile sıkıştırma kodu olan arkadaşlar varsa ben mail göndermeye adapte etmye çalışayımm

 

[Korhan Ayhan]

Ben kendi raporlarım için aşağıdaki kodu kullanıyorum.

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
    As String, ByVal lpFile As String, ByVal lpParameters _
    As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
    As String, ByVal lpFile As String, ByVal lpParameters _
    As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Sub RAPORU_WINRARLA_SIKIŞTIR_MAİL_GÖNDER()
    Dim Outlook_Uygulaması As Object
    Dim Outlook_Mail As Object
    Dim Program_Yolu As String
    Dim Dosya_Adı As Variant, Örnek_Dosya_Adı As String, Arşiv_Dosya_Adı As String
    Dim Ay As String, Ay_Adı As String, Yıl As Integer
    
    'WinRar uygulamasının tam yolunu yazın
    Program_Yolu = "C:\Program Files\WinRAR\WinRAR.exe"
    
    If Dir(Program_Yolu) = "" Then
        MsgBox "Sisteminizde yüklü WinRAR sıkıştırma programını bulunamamıştır !" & vbCrLf & "Lütfen daha sonra tekrar deneyiniz !", vbCritical, "Dikkat !"
        Exit Sub
    End If

    Ay = Format(DateSerial(Year(Now), Month(Now), 0), "mm")
    Ay_Adı = Evaluate("=UPPER(""" & Format(DateSerial(Year(Now), Month(Now), 0), "mmmm") & """)")
    Yıl = Year(Now)
    Örnek_Dosya_Adı = Ay & "_" & Ay_Adı & "_" & Yıl & "_" & "AYLIK_MALİYET_RAPORU.xls"
    
    Dosya_Adı = Application.InputBox("Lütfen arşivlenecek dosyanıza isim veriniz !", "DOSYA ADI", Örnek_Dosya_Adı)
    If Dosya_Adı = "" Or Dosya_Adı = False Then
        MsgBox "Hatalı dosya adı girdiniz yada işlemi iptal ettiniz !" & vbCrLf & "Lütfen daha sonra tekrar deneyiniz !", vbExclamation, "Dikkat !"
        Exit Sub
    End If
    
    Dosya_Adı = "C:\" & Dosya_Adı
    
    ActiveWorkbook.SaveCopyAs Filename:=Dosya_Adı
    
    'Sıkıştırıldıktan sonra rar dosyasına verilecek isim
    Arşiv_Dosya_Adı = "C:\" & Left(Dir(Dosya_Adı), Application.Find(".", Dir(Dosya_Adı)) - 1)
    
    'Rar dosyası oluşturuluyor
    ShellExecute 0, "Open", Program_Yolu, "a " & Arşiv_Dosya_Adı & " " & Dosya_Adı, "", vbHide
    
    Application.Wait Now + TimeValue("00:00:20")
    
    'Setup dosyası oluşturuluyor
    'ShellExecute 0, "Open", Program_Yolu, "s " & Arşiv_Dosya_Adı & ".rar", "", vbHide
    
    'Application.Wait Now + TimeValue("00:00:10")
    
    'Mail Olarak Göndermek
    Set Outlook_Uygulaması = CreateObject("Outlook.Application")
    Outlook_Uygulaması.Session.Logon
    Set Outlook_Mail = Outlook_Uygulaması.CreateItem(0)
    
    With Outlook_Mail
        .To = Sheets("MAİL_PARAMETRELERİ").[B2]
        .CC = Sheets("MAİL_PARAMETRELERİ").[B3]
        .BCC = ""
        .Subject = Sheets("MAİL_PARAMETRELERİ").[B4]
        .BodyFormat = 2
        .Attachments.Add Arşiv_Dosya_Adı & ".rar"
        .Display
        '.Send
    End With
    
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulaması = Nothing
 
    'Arşivlenen ve yedeklenen dosyaları sistemden silmek
    Kill Dosya_Adı
    Kill Arşiv_Dosya_Adı & ".rar"
End Sub

 

[fkalelinet]

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
    As String, ByVal lpFile As String, ByVal lpParameters _
    As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
    As String, ByVal lpFile As String, ByVal lpParameters _
    As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Sub rar()
    Dim Program_Yolu As String
    Dim Dosya_Adı As Variant, Örnek_Dosya_Adı As String, Arşiv_Dosya_Adı As String
 
    'WinRar uygulamasının tam yolunu yazın
    Program_Yolu = "C:\Program Files\WinRAR\WinRAR.exe"

    If Dir(Program_Yolu) = "" Then
        MsgBox "Sisteminizde yüklü WinRAR sıkıştırma programını bulunamamıştır !" & vbCrLf & "Lütfen daha sonra tekrar deneyiniz !", vbCritical, "Dikkat !"
        Exit Sub
    End If

    Dosya_Adı = "d:\rapor\rapor\sayac\"
    
   
    'Sıkıştırıldıktan sonra rar dosyasına verilecek isim
    Arşiv_Dosya_Adı = "d:\rapor\rapor\sayac\sayac"
    
    'Rar dosyası oluşturuluyor
    ShellExecute 0, "Open", Program_Yolu, "a  " & Arşiv_Dosya_Adı & " " & Dosya_Adı, "", vbHide
    
 Call GmailYolla
 
    'Arşivlenen ve yedeklenen dosyaları sistemden silmek
    'Kill Dosya_Adı
    'Kill Arşiv_Dosya_Adı & ".rar"
End Sub

bu şekilde sıkıştıma işlemlerini başarı ile yaptım. sadece sorun sıkıştırılan dosya içserisinde yol içinde geçen kademeler klasör olarak çıkıyor. yani d:\rapor\rapor\sayac\ yolundaki tüm dosyalar sıkıştırıldığında sıkışan dosya açmak isteyince rapor rapor sayac klasörlerinden sonra çlıkıyor dosyalar yani yol olmadan direk klaösr içerisine alabilir miyim.

ayrıca outlook kullanmıyor gmail kulllanıyorum ve siteden daha önce aldığım kod ile tek dosya olarak göndermekte sorun yaşamıyorum. ancak bu şekilde sıkıştırılmış bir dosyayı göndermek istediğimde. hata alıyorum.
araştırdım 0x800CCCD6 IMAP_BUFFER_OVERFLOW Arabellek sınırı aşıldı
böyle bir hatadan bahsediyor mesaj.
mail gödnermek için kullnadığım kod da bu.

Sub GmailYolla()
'On Error Resume Next
Dim adres As String, Subject As String, HTMLBody As String, BCC As String
Dim iMsg As Object, iConf As Object, Flds
Application.DisplayAlerts = False

Set t = Sheets("SAYAÇ ENDEKS GÖNDER")
kime = t.Range("c2").Value
konu = t.Range("c3").Value
mesaj = t.Range("c4").Value
bilgi = t.Range("c5").Value
gizli = t.Range("c6").Value
dosyaeki = t.Range("c7").Value
sifre = "123456789"
MsgBox "seçmiş olduğunuz dosya mail olarak gönderilecektir"
If kime = "" Then
MsgBox "Gönderilecek kişi bulunamadı.   ", vbCritical, "DİKKAT"
Exit Sub
End If
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = "deneme@gmail.com" 'Kendizine uyarlayın
Flds.Item(schema & "sendpassword") = sifre
Flds.Item(schema & "smtpusessl") = 1
Flds.Update
    With iMsg
        .To = kime
        .CC = bilgi
        .BCC = gizli
        .From = "deneme TM<deneme@gmail.com>" 'Kendizine uyarlayın
        .Subject = konu
        .HTMLBody = mesaj
        .AddAttachment dosyaeki
        .Sender = "deneme TM" 'Kendizine uyarlayın
        .Organization = "KSKYTM" 'Kendizine uyarlayın
        .ReplyTo = "deneme@gmail.com" 'Kendizine uyarlayın
    Set .Configuration = iConf
        SendEmailGmail = .Send
        syol = vbNullString
        mailadresi = vbNullString
        adres = vbNullString
        Application.DisplayAlerts = True
    End With
    If Err.Number = 0 Then
    MsgBox "E-posta ve/veya dosya gönderildi.   ", vbInformation, "İletim Raporu"
End If
Set t = Nothing
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub

 

[fkalelinet]

winrar ile klasöre girer dosyaları sıkıştırırsam gönder dediğim de gidiyor ancak
kod ile sıkıştırdığım dosya gönderilemiyor??

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Belirttiğiniz klasördeki dosyaları masaüstünde "Raporlar" isimli rar dosyası ile sıkıştırıyor.

Sub RAR()
    Dim Program_Yolu As String, Dosya_Adı As Variant, Arşiv_Dosya_Adı As String
 
    'WinRar uygulamasının tam yolunu yazın
    Program_Yolu = "C:\Program Files\WinRAR\WinRAR.exe"

    If Dir(Program_Yolu) = "" Then
        MsgBox "Sisteminizde yüklü WinRAR sıkıştırma programını bulunamamıştır !" & vbCrLf & "Lütfen daha sonra tekrar deneyiniz !", vbCritical, "Dikkat !"
        Exit Sub
    End If

    Dosya_Adı = "d:\rapor\rapor\sayac"
    
    'Sıkıştırıldıktan sonra rar dosyasına verilecek isim
    Arşiv_Dosya_Adı = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Raporlar"
    
    'Rar dosyası oluşturuluyor
    ShellExecute 0, "Open", Program_Yolu, "A -ep " & Arşiv_Dosya_Adı & " " & Dosya_Adı, "", vbHide
    
    Call GmailYolla
 
    'Arşivlenen ve yedeklenen dosyaları sistemden silmek
    'Kill Dosya_Adı
    'Kill Arşiv_Dosya_Adı & ".rar"
End Sub

 

[fkalelinet]

sorun şu sıkıştırılacak klasör içerisinde kısa yol varsa yada bu mail excel dosyası aynı klasörde ise. hata veriyor. dışarıya aldım ve hiç kısayol koymadım klasör içerisini şimdi gönderiyor.
ayrıca A -ep de sıkışan klasör içerisindeki gereksiz klasörleri kaldırdı teşekkürler.