Soru Textboxlarda Görünen Yüklü Dosyaları Winrar ile Sıkıştırarak Tek textboxta Gösterme

[TURKOLOG]

Listboxta bir listem var daha önce veri girilmiş .listboxa tıklayınca veriler textboxlara geliyor.

Benim sorunum şu.
Textbox8
Textbox9
Textbox10
Textbox11
Textbox12
Textbox13 de dosya adı konumu ve uzantısı olan dosyaları Winrar ile sıkıştırıp Textbox33 de göstermek böylece mail atınca tüm dosyalar tek bir texboxun içinde.Textbox33 ün icinde mail gonder diyince gidecek .
Ama tüm textboxlarda dosya olmak zorunda değil. Dosya yoksa hata vermeden dosya olan Texboxlardaki dosyaları Winrar yapıp Textbox33 de gösterecek

 

[TURKOLOG]

Bu konuda hiç mi kimsenin bilgisi yok.

 

[PLİNT]

Merhaba
Aşağıdaki gibi olabilir

Dim yol As String, tx As Variant, a As Long, dosyalar As String, m as string
yol = ThisWorkbook.Path
tx = Array("8", "9", "10", "11", "12", "13")
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And Dir(Me.Controls("TextBox" & tx(a)), vbDirectory) <> "" Then
If dosyalar <> "" Then m = " "
dosyalar = dosyalar & m & Dir(Me.Controls("TextBox" & tx(a)), vbDirectory)
End If
Next
ChDir yol
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a TOPLU.rar " & dosyalar, vbHide
TextBox33 = yol & "\TOPLU.rar"

 

[TURKOLOG]

O zaman sicil yazınca textbox27 'ye mail adresi ve diğer bilgiler mail gönderme formununa otomotik geliyor . Sub Textbox27_Change () olayının devamına

Sub Textbox27_Change ()
Dim yol As String, tx As Variant, a As Long, dosyalar As String, m as string
yol = ThisWorkbook.Path
tx = Array("8", "9", "10", "11", "12", "13")
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And Dir(Me.Controls("TextBox" & tx(a)), vbDirectory) <> "" Then
If dosyalar <> "" Then m = " "
dosyalar = dosyalar & m & Dir(Me.Controls("TextBox" & tx(a)), vbDirectory)
End If
Next
ChDir yol
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a TOPLU.rar " & dosyalar, vbHide
TextBox33 = yol & "\TOPLU.rar"
End Sub

kodlarını mı eklemem gerekiyor ki . Sicil yazınca hem istediğim bilgiler gelsin ki geliyor bununla beraber sicil yazınca textbox33 e Winrar şekliyle dosya yolu gelsin ve mail gonder deyince dosyalari toplu göndersin.

 

[PLİNT]

Eğer "mail gönder" butonu ile "Textbox8-9-...33" aynı "userform" üzerinde ise
yukarıdaki kodları

sub rar_hazırla
Dim yol As String, tx As Variant, a As Long, dosyalar As String, m as string
yol = ThisWorkbook.Path
tx = Array("8", "9", "10", "11", "12", "13")
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And Dir(Me.Controls("TextBox" & tx(a)), vbDirectory) <> "" Then
If dosyalar <> "" Then m = " "
dosyalar = dosyalar & m & Dir(Me.Controls("TextBox" & tx(a)), vbDirectory)
End If
Next
ChDir yol
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a TOPLU.rar " & dosyalar, vbHide
TextBox33 = yol & "\TOPLU.rar" 
end sub

gibi bir makro başlığı altına ekleyin

sub commandbutton1_click()          'Mail gönderen buton

call rar_hazırla '<----------------
'.....
'....kodlar
'....
'....
        .Attachments.Add textbox33.text '<----------------------------------------
  '....
  '.....diğer kodlar
  '..
  end sub'

'

sizin yukarıda belirttiğiniz gibide olabilir (mail gönderen kodlarda ".Attachments.Add textbox33.text " olmak şartı ile)

Sub Textbox27_Change ()
call rar_hazırla
'....
end sub

 

[PLİNT]

Yukarıdaki "sub rar_hazırla" makrosu "userform" kod penceresinde olsun

 

[PLİNT]

"rar" lanacak dosya (veya dosyalar) bulunamazsa ihtimali içinde aşağıdaki gibi; ek yapılan kodları kullanın

Private Sub CommandButton1_Click() 'MAİL GÖNDEREN BUTON
Call rar_hazırla

'....
'....kodlar
'....

If textbox33 <> "" Then                            '<------------
  .Attachments.Add s2.Cells(a, "H").Value '<------------
End If                                                      '<------------------------

  .send

'....
'......diğer kodlar

End Sub

'*****************************************
'
Sub rar_hazırla()
Dim yol As String, tx As Variant, a As Long, dosyalar As String
yol = ThisWorkbook.Path
tx = Array("8", "9", "10", "11", "12", "13")
textbox33 = ""
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And Dir(Me.Controls("TextBox" & tx(a)), vbDirectory) <> "" Then
If dosyalar <> "" Then m = " "
dosyalar = dosyalar & m & Dir(Me.Controls("TextBox" & tx(a)), vbDirectory)
End If
Next
ChDir yol
If dosyalar <> "" Then
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a TOPLU.rar " & dosyalar, vbHide
textbox33 = yol & "\TOPLU.rar"
Else
MsgBox "Dosya bulunamadı"
End If
End Sub

"rar_hazırla" makrosunu eğer mail gönderen butona eklemek istemezseniz ve yukarıdaki belittiğiniz gibi "textbox27" ye otomatik veri gelmez ve manual giriş yapma ihtimalide var ise "exit" başlığı altına yazın

Private Sub TextBox27_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Call rar_hazırla

End Sub

 

[TURKOLOG]

Sayın @PLİNT dosya üzerinde çok uğraştım ama hata veriyor. kendi kodlarımı da revize ettim textboxları gücelledim sizin kodlarla birleştirince olmadı. Userform açılmıyor
Olmayınca sabah bir çok yeri formda sildim. yeniden textbox yaptım ama hala taha mesajı verince dosyayı size göndermenin daha mantıklı olduğuna karar verdim.

Private Sub TextBox14_Change()
Dim Bul
    On Error Resume Next
    Bul = Sheets("VERİ").Range("B2:B100000").Find(What:=TextBox14, LookIn:=xlValues, LookAt:=xlWhole).Row
    TextBox15.Value = Sheets("VERİ").Cells(Bul, 3).Value
    TextBox16.Value = Sheets("VERİ").Cells(Bul, 4).Value
    TextBox17.Value = Sheets("VERİ").Cells(Bul, 20).Value
    TextBox18.Value = Sheets("VERİ").Cells(Bul, 9).Value
    
    Call rar_hazırla
    
End Sub

bu kodla veri sayfasından mail anında geliyordu .

Private Sub Gönder_Click()
Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

'    On Error Resume Next
With OutMail
.To = TextBox17
.CC = ""
.BCC = ""
.Subject = CStr(TextBox19.Text)
.Body = CStr(TextBox20.Text), (txtSira.text), (txtSicili.text), (txtAdi.text), (txtSoyadi.text), (txtRutbesi.text), (txtBurosu.text)
.Attachments.Add Pasif_Düzenleme.TextBox22.Text
.Save
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Gönderildi"
End Sub

bu kod çalışıyordu ama revize edince olmuyor

Sub rar_hazırla()
Dim yol As String, tx As Variant, a As Long, dosyalar As String
yol = ThisWorkbook.Path
tx = Array("8", "9", "10", "11", "12", "13")
TextBox21 = ""
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And Dir(Me.Controls("TextBox" & tx(a)), vbDirectory) <> "" Then
If dosyalar <> "" Then m = " "
dosyalar = dosyalar & m & Dir(Me.Controls("TextBox" & tx(a)), vbDirectory)
End If
Next
ChDir yol
If dosyalar <> "" Then
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a TOPLU.rar " & dosyalar, vbHide
TextBox21 = yol & "\TOPLU.rar"
Else
MsgBox "Dosya bulunamadı"
End If
End Sub

bu kod size ait ve hiç çalıştıramadım.

Programa şöyle bir ekleme yaptım Textbox22 ye de ben anlık başka bir dosya eklemek istersem harici bir yerden onu da ekleyip topluca yollayacak ama dediğim gibi 89-10-11-12-13-21-22. textboxların hepsinde dosya olmak zorunda değil . boş olabilir bazıları başka bir şey yazabilir . Dosya yolu olmayanları atlayacak ve Textbox21 e winrar şeklinde göndermeye hazır hale getirip bırakacak. Textbox22 de isteğe bağlı ben ekleyeceğim.

 

[PLİNT]

Dosyanızı burayada ekleyip https://www.dosyaupload.com adresi verirmisiniz? formdan indiremiyorum

 

[TURKOLOG]

Mail İşlemleri linkinden indirebilirsiniz Sayın @PLİNT

 

[TURKOLOG]

Sayın @PLİNT bir konuda daha yardım isteyecektim . Linkteki userformda listboxum var. Sayfa22 adlı PASİF_IŞLEMLERİ adlı sayfada tüm işlem yapması gerekiyor. Ama naptıysam aktif sayfada işlem yapıyor. Bende Sayfa22 isimli PASİF_IŞLEMLERİ adlı sayfa var listboxtaki tüm işlemlerin tüm kodların başına sub xx () den sonra With sayfa22 End sub() dan önce End With yapmana rağmen olmadı. Bu konuda da yardımcı olabilir misiniz . Çok sevinirim bakabilirseniz eğer.

 

[PLİNT]

https://www.dosyaupload.com/bhfL
Ek dosyadaki gibi;
_ "rar_hazırla" makrosu yukarıda belirttiğim gibi "userform" kod sayfasında olsun
_ "Call rar_hazırla" TextBox14_change" değilde çıkışta olsun

Private Sub TextBox14_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Call rar_hazırla
End Sub

_ Private Sub UserForm_Initialize() başlığı altında " txtAra.Text = "Arama Kutusu" " komutu ile "txtAra" adlı "textbox"
Sub txtAra_Change başlığı altında " ListBox1.Column = askm" kodu ile "listbox" a listeyi ekliyor öyle olunca

ListBox1.RowSource = "PASİF_İŞLEMLERİ!" & "A2:ZZ" & Sayfa22.Range("A60000").End(3).Row
satırı hata verdiriyor

"ListBox1.RowSource" birkaç yerde var "SİL_Click" "UserForm_Initialize"
Bu satırı eklemeden önce "ListBox1.RowSource = Empty" ve "ListBox1.Clear " olsun

ListBox1.RowSource = Empty
ListBox1.Clear
ListBox1.RowSource = "PASİF_İŞLEMLERİ!" & "A2:ZZ" & Sayfa22.Range("A60000").End(3).Row

Son mesajınızdaki sorunun sebebide budur, örnek dosyada yok ama "sayfa22" nin adı "PASİF_İŞLEMLERİ" herhalde

 

[TURKOLOG]

Sayın @PLİNT aşağıda yazdığım şekilde çalışacak değil mi mail gönderme işlemi

Programa şöyle bir ekleme yaptım Textbox22 ye de ben anlık başka bir dosya eklemek istersem harici bir yerden onu da ekleyip topluca yollayacak ama dediğim gibi 89-10-11-12-13-21-22. textboxların hepsinde dosya olmak zorunda değil . boş olabilir bazıları başka bir şey yazabilir . Dosya yolu olmayanları atlayacak ve Textbox21 e winrar şeklinde göndermeye hazır hale getirip bırakacak. Textbox22 de isteğe bağlı ben ekleyeceğim.

 

[PLİNT]

"rar_hazırla" makrosundaki satırı düzenleyin
tx = Array("89", "10", "11", "12", "13", "21", "22")

"Gönder_Click" altındaki
"send" (gönder) satırını silerek veya başına tek tırnak koyarak denemeler yapabilirsiniz
Örnek dosyada aşağıdaki işaretli satırları eklememişsiniz

.Subject = CStr(TextBox19.Text)
.Body = CStr(TextBox20.Text)
If Pasif_Düzenleme.TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then  <----------------------------------1
.Attachments.Add Pasif_Düzenleme.TextBox22.Text
End If '            <-------------------------------------------------------2
.Save
'.Send '////////////Bu satırı geçici olarak silerek deneme yapın ////////////////////////////////

 

[TURKOLOG]

Private Sub Gönder_Click()
Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

'    On Error Resume Next
With OutMail
.To = TextBox17
.CC = ""
.BCC = ""
.Subject = CStr(TextBox19.Text)
.Body = CStr(TextBox20.Text)
.Attachments.Add Pasif_Düzenleme.TextBox21.Text
.Attachments.Add Pasif_Düzenleme.TextBox22.Text
.Save
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Gönderildi"
End Sub

Sayın @PLİNT verdiğiniz kodu uyguladım çalışyor. Ama .Attachments.Add Pasif_Düzenleme.TextBox21.Text içerisinde toplu rar dosyası olup da .Attachments.Add Pasif_Düzenleme.TextBox22.Text içerisinde dosya olmayınca gönder kodu hata veriyor.
ve göndermiyor . Aynı şekilde textbox21 ve textbox22 içi boş olsa dahi uyarı verse ek yok yine de mail göndermek istermisiniz diyip evet dense mail atsa 21. ve 22 textboxların ikidi de dolu olunca uyarmadan mail atsa. Mümkün müdür?
Yine .Body = CStr(TextBox20.Text) kısmına textbox14 ,15 16 da eklense

 

[TURKOLOG]

tx = Array("89", "10", "11", "12", "13", "21", "22")

89 ne onu anlamadım

 

[PLİNT]

dediğim gibi 89-10-11-12-13-21-22. textboxların

Buradaki "89"

 

[TURKOLOG]

If Pasif_Düzenleme.TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then <----------------------------------1
bu satırda hata veriyor
rar_hazrla ()
tx = Array("8", "9", "10", "11", "12", "13", "21", "22") şeklinde düzelttim . Ama olmadı

 

[TURKOLOG]

Private Sub Gönder_Click()
Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

'    On Error Resume Next
With OutMail
.To = TextBox17
.CC = ""
.BCC = ""
.Subject = CStr(TextBox19.Text)
.Body = CStr(TextBox20.Text)
.Attachments.Add Pasif_Düzenleme.TextBox21.Text
.Attachments.Add Pasif_Düzenleme.TextBox22.Text
.Save
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Gönderildi"
End Sub

Sayın @PLİNT verdiğiniz kodu uyguladım çalışyor. Ama .Attachments.Add Pasif_Düzenleme.TextBox21.Text içerisinde toplu rar dosyası olup da .Attachments.Add Pasif_Düzenleme.TextBox22.Text içerisinde dosya olmayınca gönder kodu hata veriyor.
ve göndermiyor . Aynı şekilde textbox21 ve textbox22 içi boş olsa dahi uyarı verse ek yok yine de mail göndermek istermisiniz diyip evet dense mail atsa 21. ve 22 textboxların ikidi de dolu olunca uyarmadan mail atsa. Mümkün müdür?
Yine .Body = CStr(TextBox20.Text) kısmına textbox14 ,15 16 da eklense

bu şekle makroyu getirebilir misiniz rica etsem

 

[PLİNT]

Aşağıdaki gibi deneyelim
(.send başındaki tırnağı kaldırırsınız)

Private Sub Gönder_Click()
Dim OutApp As Object
    Dim OutMail As Object
   Dim msg As String, msg2 As String
  msg = "Mail Ek YOK": msg2 = "Toplu Ek YOK"
If Pasif_Düzenleme.TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then msg = "Mail Ek VAR"
If Pasif_Düzenleme.TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then msg2 = "Toplu Ek VAR"
If msg = "Mail Ek YOK" Or msg2 = "Toplu Ek YOK" Then
sor = MsgBox(msg & "  " & msg2 & vbCrLf & "Mail Gönderilsinmi?", vbYesNo)
If sor = vbNo Then Exit Sub
End If
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
If InStr(1, TextBox17.Text, "@", vbTextCompare) = 0 Then MsgBox "mail adresi hatalı": exit sub
'    On Error Resume Next
With OutMail
.Display   'GÖRÜNTÜLE
.To = TextBox17.Text
.CC = ""
.BCC = ""
.Subject = CStr(TextBox19.Text)
.Body = CStr(TextBox20.Text & " " & TextBox14.Text & " " & TextBox15.Text & " " & TextBox16.Text)
If msg = "Mail Ek VAR" Then .Attachments.Add Pasif_Düzenleme.TextBox22.Text
If msg2 = "Toplu Ek VAR" Then .Attachments.Add Pasif_Düzenleme.TextBox21.Text
.Save
'.Send 'GÖNDERMEK İÇİN EN BAŞTAKİ TIRNAĞI KALDIRIN <---------------------------------------
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Gönderildi"
End Sub