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

[TURKOLOG]

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

Sayın @PLİNT Kod çalıştı ve hata mesajı vermeden dosyayı mail gönderdi. Ama bundan sonra ne kadar toplu rar istediysem ilk yaptığı toplu rar dosyasını yolluyor. Hata hep aynı ve masaüstüne attığı ilk toplu rar dosyasını yolluyor
Maili toplu rar yapıp gönderdikten sonra masaüstünde ya da hangi konuma toplu rar dosyasını atıyorsa mail gittikten sonra toplu rar dosyasını silse .
Veya her textbox14 den çıkıldıktan sonra konumdaki eski toplu rar dosyasını silse ve yeniden toplu rar dosyası yapsa daha mi mantikli olur maile eklenmesi geç olursa diye bu yolu düşündüm.
Ama her halukarda eski toplu rar dosyasısı silinmeli . Bu hali ile hwpnilk dosyayi gönderiyor.

 

[TURKOLOG]

Sayın @PLİNT Unuttum tabi toplu rar konumunda dosya varsa silsin . Yoksa toplu rar oluştursun. Çünkü yol konumunda toplu rar olmaya da bilir bu durumda hata vermemeli

 

[PLİNT]

Aşağıdaki işaretli satırı eklemeniz eskiyi silmek için yeterli olur.
Veya mail gönderen kodlardaki "mail gönderildi" mesajının altına yada bir üstüne ekleyebilirsiniz, eğer saklamak gerek ise kodlarla bir klasör içinede gönderilebilir
Ayrıca hazırlanan bu "rar" için "toplu" adı vermek şart değildir, sicili veya tarih de olabilir

Sub rar_hazırla()
Dim yol As String, tx As Variant, a As Long, dosyalar As String, m As String
yol = ThisWorkbook.Path
If Dir(yol & "\TOPLU.rar", vbDirectory) <> "" Then Kill yol & "\TOPLU.rar"  '<----------------<<-'

'....
'...kodlar
'....
end sub'

 

[TURKOLOG]

Sayın @PLİNT aslında çok haklısınız ve mantıklı dediniz . Bazı dosyaları saklasa çok mantıklı
Mail gönderdikten sonra
Mail gönderildi textbox21 ve textbox22 de gönderdiğiniz dosyaları Kaydetmek ister misiniz diye sorsa Evet dersek bu excel kitabının SABİTLER sayfasının B3 hücresinde yazan konumuna
Misal
Textbox21 için
23.2.2020_22.53.00_txtsicili_TOPLU.rar
Textbox22 için
23.2.2020_22.53.00_txtsicili_dosyanin adı.uzantısı
yazılı olarak taşınsa
Eğer Hayır dersek toplu.rar dosyasını saklamasın ve hemen silsin winrarın kayıtlı olduğu konumdan.
yol konumunda toplu rar olmaya da bilir bu durumda hata vermemeli

 

[TURKOLOG]

Sayın @PLİNT

With OutMail
.Display 'GÖRÜNTÜLE
.To = TextBox17.Text
.CC = ""
.BCC = ""
.Display silinirse eğer outlook görüntülemeden mı mail direkt olarak gider. Öğrenmek için sordum.

 

[PLİNT]

Sayın
.Display silinirse eğer outlook görüntülemeden mı mail direkt olarak gider. Öğrenmek için sordum.

O sadece görüntülemek içindir, görünsede, görünmesede direkt gönderir; (gönderen ".send" kısmıdır, benim gönderdiğim kodlarda aktif değildi )
"Gönder_Click" makrosunun sonuna aşağıdaki gibi (mesajın altına) "Call kayıt" ekleyin
yine "Gönder_Click" makrosunun altındada "sub kayıt" makrosu olsun (Userform kod sayfasında)

Aşağıdaki kodu:

Private Sub Gönder_Click()
'......
...kodlar
'...
'...
Set OutApp = Nothing
MsgBox "Gönderildi"
         call kayıt   '<----------------------------///////----'
End Sub

Sub kayıt()
sor = MsgBox("Gönderilen dosyalar kaydedilsinmi?", vbYesNo)
If sor = vbYes Then
Dim ad As String, yeniad1 As String, yeniad2 As String, adres As String, cr As Object
adres = Sheets("SABİTLER").[B3].Text & "\"
If Dir(adres, vbDirectory) = "" Then
MkDir adres
adres = adres & "\"
Application.Wait (Now + TimeValue("0:00:02"))
End If
Set cr = CreateObject("scripting.filesystemobject")
If TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then
ad = Replace(cr.GetBaseName(TextBox22.Text) & "_" & Replace(Now, " ", "_"), ":", ".")
yeniad2 = Replace(TextBox22.Text, cr.GetBaseName(TextBox22.Text), ad)
Name TextBox22.Text As yeniad2
cr.moveFile Source:=yeniad2, Destination:=adres
End If
If TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then
ad = Replace(cr.GetBaseName(TextBox21.Text) & "_" & Replace(Now, " ", "_"), ":", ".")
yeniad1 = Replace(TextBox21.Text, cr.GetBaseName(TextBox21.Text), ad)
Name TextBox21.Text As yeniad1
cr.moveFile Source:=yeniad1, Destination:=adres
End If
Else
If Dir(TextBox22, vbDirectory) <> "" Then Kill TextBox22.Text
If Dir(TextBox21, vbDirectory) <> "" Then Kill TextBox21.Text
End If
End Sub

 

[TURKOLOG]

Sub kayıt()

sor = MsgBox("Gönderilen dosyalar kaydedilsinmi?", vbYesNo)

If sor = vbYes Then

Dim ad As String, yeniad1 As String, yeniad2 As String, adres As String, cr As Object

adres = Sheets("SABİTLER").[B3].Text & ""

If Dir(adres, vbDirectory) = "" Then

MkDir adres

adres = adres & ""

Application.Wait (Now + TimeValue("0:00:02"))

End If

Set cr = CreateObject("scripting.filesystemobject")

If TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then

ad = Replace(cr.GetBaseName(TextBox22.Text) & "_" & Replace(Now, " ", "_"), ":", ".")

yeniad2 = Replace(TextBox22.Text, cr.GetBaseName(TextBox22.Text), ad)

Name TextBox22.Text As yeniad2

cr.moveFile Source:=yeniad2, Destination:=adres

End If

If TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then

ad = Replace(cr.GetBaseName(TextBox21.Text) & "_" & Replace(Now, " ", "_"), ":", ".")

yeniad1 = Replace(TextBox21.Text, cr.GetBaseName(TextBox21.Text), ad)

Name TextBox21.Text As yeniad1

cr.moveFile Source:=yeniad1, Destination:=adres

End If

Else

If Dir(TextBox22, vbDirectory) <> "" Then Kill TextBox22.Text

If Dir(TextBox21, vbDirectory) <> "" Then Kill TextBox21.Text

End If

End Sub

cr.moveFile Source:=yeniad2, Destination:=adres
renkli satırda hata veriyor ve maile ek göndermiyor


Sayın @PLİNT toplu rar hazırla textbox21 e geliyordu. Textbox21 i aç kodu ile açmaya çalıştım ama konumda toplu dosyası yok diye açmıyor aslında rar hazırla kodu toplu rar i hazirlamiyormuş
Rar hazırla dosyası raRi hazirlasa excel kitabının Sabitler sayfasının B2 satırındaki yola kaydetse.
Aç komutuyla textbox21 i aç diyorum dosya orda kaydedilmediği için açmıyor.

 

[TURKOLOG]

Mail ek var toplu ek yok diyor aslında toplu eki yadetmedigi için açılmıyor ve gitmiyor

 

[PLİNT]

https://www.dosyaupload.com/bhlU
Ek dosyayı deneyin
(Ekteki rar içinden "deneme" klasörünü çıkartın, "pasif işlem" dosyasını açıp "veri" sayfasındaki buton ile "userform" u açıp değişiklik yapmadan direkt "send" butonuna tıklayın)
"rar hazırla" "send" butonuna alındı
"mail içeriği" dosyasını taşıma yerine kopyala makrosu eklendi
size gerek kodlar zaten kod penceresinin üst sıralarında; incelersiniz

 

[TURKOLOG]

sayın @PLİNT son verdiğiniz kodlarla tamamen karıştı. Rar Hazırlayıp excelin Sabitler sayfasının B1 satırındaki adrese atacak ve Textbox14_Exıt olunca Textbox21 e toplu.rar şeklinde atmıyor artık textbox14 e sicil sazınca bilgiler mail adresi geliyor ama textbox21 e toplu dosya gelmiyor.

Sub rar_hazırla()

Dim yol As String, tx As Variant, a As Long, dosyalar As String
yol = Sheets("SABİTLER").[B1].Text
If Dir(yol & "\TOPLU.rar", vbDirectory) <> "" Then Kill yol & "\TOPLU.rar"  '<----------------<<-'
TextBox21 = ""
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
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

rar hazırlanıp atmıyor

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

mail gönder deyince alttaki renkli kısım hata veriyor

Sub kayıt()
sor = MsgBox("Gönderilen dosyalar kaydedilsinmi?", vbYesNo)
If sor = vbYes Then
Dim ad As String, yeniad1 As String, yeniad2 As String, adres As String, cr As Object
adres = Sheets("SABİTLER").[B3].Text & "\"
If Dir(adres, vbDirectory) = "" Then
MkDir adres
adres = adres & "\"
Application.Wait (Now + TimeValue("0:00:02"))
End If
Set cr = CreateObject("scripting.filesystemobject")
If TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then
ad = Replace(cr.GetBaseName(TextBox22.Text) & "_" & Replace(Now, " ", "_"), ":", ".")
'yeniad2 = Replace(TextBox22.Text, cr.GetBaseName(TextBox22.Text), ad)
cr.CopyFile Source:=TextBox22.Text, Destination:=adres
Name adres & cr.GetBaseName(TextBox22.Text) & "." & cr.GetExtensionName(TextBox22.Text) As adres & ad & "." & cr.GetExtensionName(TextBox22.Text)
End If
If TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then
ad = Replace(cr.GetBaseName(TextBox21.Text) & "_" & Replace(Now, " ", "_"), ":", ".")
yeniad1 = Replace(TextBox21.Text, cr.GetBaseName(TextBox21.Text), ad)
Name TextBox21.Text As yeniad1
cr.moveFile Source:=yeniad1, Destination:=adres
End If
MsgBox cr.GetBaseName(TextBox22.Text) & " Dosyası Dosyanızın yanındaki KLASOR e YEDEKLENDİ" & vbCrLf & _
cr.GetBaseName(TextBox21.Text) & " Dosyası Dosyanızın yanındaki KLASOR e TAŞINDI"
Else
If Dir(TextBox21, vbDirectory) <> "" Then Kill TextBox21.Text
End If
End Sub

cr.moveFile Source:=yeniad1, Destination:=adres bu satırda hata veriyor.

ve dosyaları tarih_saat_txtsicili_Toplu ismi ile sabitler sayfasının b3 hücresindeki adrese kaydetmesini istiyorum . Size bendeki userformu gönderiyorum. En sağlıklısı sizin form üzerinde kodları denemeniz. Başka türlü dosyadan çıkamayacağım ben.

Mail Gönderme Userformu

 

[PLİNT]

Merhaba
Gönderdiğiniz dosya bendeki ile aynı ama verileri asıl dosyanızla aynı olmadığı için "textbox" lara sağlıklı klasör yolları gelmiyor, onun için ek dosyada;
formdaki "textbox" lara "userform_activate" ile ekledim; dosyadaki gibi (userform açıldığında direkt "send" tuşuna basarak deneyin) veriler ve adresler olduktan sonra hata vermiyor
Dosyadaki ilgili kodlarda yukarıdaki istediğiniz şekle göre değişiklikler var.
("Thisworkbook.path" yerine [b1] ve [b3] ten adresleri alacak ve sadece oluşturulan "toplu ek" dosyasını yedekleyecek)
Sizin dosyanızda hata veriyorsa; userformunuzdaki "textbox" lara veri ekleyen kodlardan olabilir, "textbox" lara gelen klasör ve dosya yollarında yanlışlık olmasın
https://www.dosyaupload.com/bhrV

 

[TURKOLOG]

Sayın @PLİNTçok özür dilerim sizi yine rahatsız ettim ama Windowsu sildim Windows 10 yaptım ofisi sildim ofis 2016 Tr 64 biti yeniden yükledim ama sorunum çözülmedi.



Sizden istirham ediyorum tekrar bakma imkanınız var mı koda bu durumda kodu kullanamıyorum.



rar_hazırla Sub () makrosu Textbox21 e rar hazırlıyor tamam ama bu rar hazırla toplu rar dosyasını Sabitler b1 hücresindeki adrese kaydetmediği sürece textbox21 2de sadece yolda olduğu görünüyor Aç komutuyla açmaya çalışıyorum Dosyayı açmıyor çünkü Sabitler sayfası B1 hücresindeki yola atmıyor Toplu Rar dosyasını . Atmadığı için gönderirken toplu ek yok diye uyarı da veriyor.

• 1. Sizden istirhamım Sabitler sayfası B1 hücresindeki yolda toplu rar dosyası varsa bunu ilkin silsin mutlaka sonra yeniden toplu rar oluştursun / kaydetsin Sabitler sayfası B1 hücresindeki yola.

• 2. Rar hazırla makrosundaki yolu Textbok14_Exıt komutu ile getirebiliyorum Textbox21 e.

• 3. Mail gönder dediğimde textbox21 ve eğer varsa textbox22 deki dosyaları mail attıktan sonra kayıt Sub () makrosu ,ile Sabitler Sayfası B3 deki yola yoksa eğer EKLER isimli klasör açsın EKLER klasörü varsa içine tarih_saat_txtsicili_TOPLU.rar şeklinde ve yine Textbok22 de de dosya olması durumunda tarih_saat_txtsicili_ve dosya adı neyse şeklinde olması durumunda textbox21 ve Textbox22 de olan dosyaları mutlaka kaydetsin.

Kayıt Sub () makrosu bu hali ile sadece Textbox21 deki toplu dosyayı Sabitler Sayfası B3 deki yola KLASÖR dosyasına atıyor TEXtbox22 ye hiç bakmıyor bile

Sub rar_hazırla()

 

Dim yol As String, tx As Variant, a As Long, dosyalar As String

yol = Sheets("SABİTLER").[B1].Text

If Dir(yol & "\TOPLU.rar", vbDirectory) <> "" Then Kill yol & "\TOPLU.rar"  '<----------------<<-'

TextBox21 = ""

tx = Array("8", "10", "12")

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

Call UserForm_Initialize

End Sub

kayıt makrosu da bu

Sub kayıt()

sor = MsgBox("Toplu Ek dosyası yedeklensinmi?", vbYesNo)

If sor = vbYes Then

Dim ad As String, yeniad1 As String, yeniad2 As String, adres As String, cr As Object

adres = Sheets("SABİTLER").[B3].Text & "\"

If Dir(adres, vbDirectory) = "" Then

MkDir adres

adres = adres & "\"

Application.Wait (Now + TimeValue("0:00:02"))

End If

Set cr = CreateObject("scripting.filesystemobject")

If TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then

ad = Replace(Replace(Now, " ", "_"), ":", ".") & "_" & txtSicili.Text

yeniad1 = Replace(TextBox21.Text, cr.GetBaseName(TextBox21.Text), ad)

Name TextBox21.Text As yeniad1

cr.moveFile Source:=yeniad1, Destination:=adres

End If

MsgBox "Toplu Ek Adlı Rar dosyası" & vbCrLf & ad & vbCrLf & Sheets("SABİTLER").[B3].Text & " Adresine TAŞINDI"

Else

If Dir(TextBox21, vbDirectory) <> "" Then Kill TextBox21.Text

End If

Call UserForm_Initialize

End Sub

 

[PLİNT]

Merhaba
Ek dosyada "Gönder_Click","kayıt" ve "rar_hazırla" makrolarında klasör kontrolü için ek yapıldı
tx = Array("8", "9", "10", "11", "12", "13") satırında "Textbox" noları; kullandığınız dosyadakilerle değişik ise değiştirmelisiniz
(Ad verildi ise kodlarda değişiklik gerekir)
https://www.dosyaupload.com/75up

 

[TURKOLOG]

Merhaba
Ek dosyada "Gönder_Click","kayıt" ve "rar_hazırla" makrolarında klasör kontrolü için ek yapıldı
tx = Array("8", "9", "10", "11", "12", "13") satırında "Textbox" noları; kullandığınız dosyadakilerle değişik ise değiştirmelisiniz
(Ad verildi ise kodlarda değişiklik gerekir)
https://www.dosyaupload.com/75up

textbox isimleri
Textbox8, Textbox9 Textbox10 Textbox11 Textbox12 Textbox13 şeklinde
Ayrıca sabitler B3 de belirtilen yolDa klasor yok diye mailden sonra dosyalari atmıyor.

https://www.dosyaupload.com/ftNT resim


https://www.dosyaupload.com/75w0 video

 

[TURKOLOG]

Sayın @PLİNTrar hazırla makrosu rar yapıp sabitler B1 konumuna kaybetmediği müddetçe txtbox21 de sanal görüntü oluşuyor. Bakin txtbox22 de evrak var gidiyor geliyor burdaki sorun ise gönderdikten sonra kayıt makrosu düzgün çalışmıyor. Sabitler B3 deki konuma klasör isimli klasörü kendim açtım da yine textbox22 deki dosyayı kopyalayıp almadi

 

[PLİNT]

Şöyle;
_Örneğin "sabitler B3" te şöyle yazmalı ve "Documents" adlı bir klasör olmalı ki içine "Ekler" klasörünü oluşturup arşivlesin (onu kontrol edin)
_Hazırlanacak "rar" dosyasının yolunu "Sheets("SABİTLER").[B1]" den alsın dediğinizi sanıyordum

Sub kayıt()
Dim ad As String, yeniad1 As String, yeniad2 As String, adres As String, cr As Object
Set cr = CreateObject("scripting.filesystemobject")
sor = MsgBox("Toplu Ek dosyası yedeklensinmi?", vbYesNo)
If sor = vbYes Then
adres = Sheets("SABİTLER").[B3].Text
If adres = "" Then MsgBox "SABİTLER [B3] boş": Exit Sub
If cr.FolderExists(adres & "\EKLER") = False And Right(adres, 5) <> "EKLER" Then
MkDir adres & "\EKLER"
Application.Wait (Now + TimeValue("0:00:02"))
End If
adres = adres & "\EKLER"
If Right(adres, 1) <> "\" Then adres = adres & "\"
If TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then
ad = Replace(Replace(Now, " ", "_"), ":", ".") & "_" & txtSicili.Text
yeniad1 = Replace(TextBox21.Text, cr.GetBaseName(TextBox21.Text), ad)
Name TextBox21.Text As yeniad1
cr.moveFile Source:=yeniad1, Destination:=adres
End If
If TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then
ad = Replace(Replace(Now, " ", "_"), ":", ".") & "_" & txtSicili.Text
sm = Dir(TextBox22.Text)
cr.copyFile Source:=TextBox22.Text, Destination:=adres
yeniad1 = Replace(adres & "\" & sm, cr.GetBaseName(adres & "\" & sm), ad)
Name adres & "\" & sm As yeniad1
End If

MsgBox sm & vbCrLf & "ve " & vbCrLf & "Toplu Ek Adlı Rar dosyası" & vbCrLf & ad & vbCrLf & adres & " Adresine TAŞINDI"
Else
If Dir(TextBox21, vbDirectory) <> "" Then Kill TextBox21.Text
End If
End Sub

Sub rar_hazırla()
Dim yol As String, tx As Variant, a As Long, dosyalar As String, c
Set c = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path
Sheets("SABİTLER").[B1].Value = yol
'If c.FolderExists(yol) = False Then MsgBox "SABİTLER [B1] boş veya Hatalı": Exit Sub
If c.FileExists(yol & "\TOPLU.rar") = True Then Kill yol & "\TOPLU.rar": MsgBox "Eski Toplu RAR silindi"
TextBox21 = ""
tx = Array("8", "9", "10", "11", "12", "13")
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And c.FileExists(Me.Controls("TextBox" & tx(a))) = True 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

 

[TURKOLOG]

Şöyle;
_Örneğin "sabitler B3" te şöyle yazmalı ve "Documents" adlı bir klasör olmalı ki içine "Ekler" klasörünü oluşturup arşivlesin (onu kontrol edin)
_Hazırlanacak "rar" dosyasının yolunu "Sheets("SABİTLER").[B1]" den alsın dediğinizi sanıyordum

Sub kayıt()
Dim ad As String, yeniad1 As String, yeniad2 As String, adres As String, cr As Object
Set cr = CreateObject("scripting.filesystemobject")
sor = MsgBox("Toplu Ek dosyası yedeklensinmi?", vbYesNo)
If sor = vbYes Then
adres = Sheets("SABİTLER").[B3].Text
If adres = "" Then MsgBox "SABİTLER [B3] boş": Exit Sub
If cr.FolderExists(adres & "\EKLER") = False And Right(adres, 5) <> "EKLER" Then
MkDir adres & "\EKLER"
Application.Wait (Now + TimeValue("0:00:02"))
End If
adres = adres & "\EKLER"
If Right(adres, 1) <> "\" Then adres = adres & "\"
If TextBox21.Text <> "" And Dir(TextBox21, vbDirectory) <> "" Then
ad = Replace(Replace(Now, " ", "_"), ":", ".") & "_" & txtSicili.Text
yeniad1 = Replace(TextBox21.Text, cr.GetBaseName(TextBox21.Text), ad)
Name TextBox21.Text As yeniad1
cr.moveFile Source:=yeniad1, Destination:=adres
End If
If TextBox22.Text <> "" And Dir(TextBox22, vbDirectory) <> "" Then
ad = Replace(Replace(Now, " ", "_"), ":", ".") & "_" & txtSicili.Text
sm = Dir(TextBox22.Text)
cr.copyFile Source:=TextBox22.Text, Destination:=adres
yeniad1 = Replace(adres & "\" & sm, cr.GetBaseName(adres & "\" & sm), ad)
Name adres & "\" & sm As yeniad1
End If

MsgBox sm & vbCrLf & "ve " & vbCrLf & "Toplu Ek Adlı Rar dosyası" & vbCrLf & ad & vbCrLf & adres & " Adresine TAŞINDI"
Else
If Dir(TextBox21, vbDirectory) <> "" Then Kill TextBox21.Text
End If
End Sub

Sub rar_hazırla()
Dim yol As String, tx As Variant, a As Long, dosyalar As String, c
Set c = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path
Sheets("SABİTLER").[B1].Value = yol
'If c.FolderExists(yol) = False Then MsgBox "SABİTLER [B1] boş veya Hatalı": Exit Sub
If c.FileExists(yol & "\TOPLU.rar") = True Then Kill yol & "\TOPLU.rar": MsgBox "Eski Toplu RAR silindi"
TextBox21 = ""
tx = Array("8", "9", "10", "11", "12", "13")
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And c.FileExists(Me.Controls("TextBox" & tx(a))) = True 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

Sayın @PLİNT dosya ekte ve çalışmıyor. Benim değdigim gibi rar hazırla makrosu çalışır calismaz b1 deki yere kaydetse ilkin çünkü olmuyor bakın. Dosya ekte. Textbox21 de açılmadığı müddetçe olmayacak
Mail Gönderme

 

[TURKOLOG]

Sayın @PLİNT
Sub rar_hazirla ()
Bu makro da sorun var şimdi bir kez daha inceledim .
Rar hazırla makrosu çalışır çalışmaz 3.işlem yapmalı
1. işlem sabitler b1 yolunda toplu dosya varsa eger ilkin sabitler b1 yolundaki toplu.rar dosyasını mutlaka silsin.
2. işlem textbox8-9-10-11-12-13 deki (tamaminda dosya varsa eğer yoksa hata vermeden olanları ) dosyalari sabitler b1 de ki yola kaydecek. Bu kaydetme şart. Bildiğimiz kaydetsin.
Bakin textbox22 ye aç diyince ek açılıyor textbox21 e aç diyince açılmıyor.

3. işlem textbox8-9-10-11-12-13 deki (tamaminda dosya varsa eğer yoksa hata vermeden olanları ) dosyalari toplu.rar adı ile textbox21 e getirsin.

YAPACAĞİ BU 3 IŞLEM


Sub kayıt () makorusu ise

1. işlem Mail gönderdikten sonra sorsa ki soruyor
Kaydet denildiğinde textbox21 deki ve varsa eğer textbox22 deki yolda bulunan dosyaları tarih_saat_txtsicili_dosyaAdi şeklinde sabitler b3 deki yola kopyalasın. Yanı sabitler b1 yolundan kesip felan almasın direkt kopyalasın

 

[TURKOLOG]

Sub rar_hazırla()
Dim yol As String, tx As Variant, a As Long, dosyalar As String, c
Set c = CreateObject("scripting.filesystemobject")
yol = Sheets("SABİTLER").[B1].Value
If Right(yol, 1) = "\" Then yol = Left(yol, Len(yol) - 1)
If c.FolderExists(yol) = False Then MsgBox "SABİTLER [B1] boş veya Hatalı": Exit Sub
yol = yol & "\"
yol = Replace(yol, "\\", "\")
If c.FileExists(yol & "TOPLU.rar") = True Then Kill yol & "TOPLU.rar": MsgBox "Eski Toplu RAR silindi"
TextBox21 = ""
tx = Array("8", "9", "10", "11", "12", "13")
For a = 0 To UBound(tx)
If Me.Controls("TextBox" & tx(a)) <> "" And c.FileExists(Me.Controls("TextBox" & tx(a))) = True Then
If dosyalar <> "" Then m = " "
dosyalar = dosyalar & m & Me.Controls("TextBox" & tx(a))
End If
Next
ChDir yol
If dosyalar <> "" Then
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a -ep " & yol & "TOPLU.rar" & " " & dosyalar, vbHide
TextBox21 = yol & "TOPLU.rar"
Else
MsgBox "Dosya bulunamadı"
End If
End Subx

Sayın @PLİNT
ChDir yol
If dosyalar <> "" Then
VBA.Shell "C:\PROGRAM FILES\WINRAR\rar.exe a -ep " & yol & "TOPLU.rar" & " " & dosyalar, vbHide

Kodu çalıştırır çalıştırmaz ChDiryol kısmı hata verdi. Çalışmadı o yüzden Chdir kısmında eksiklik olabilir mi

 

[PLİNT]

Dosya oluşturmak için yönetici izni istiyor sanırım
(B1 hücresindeki adres"C:\Users\347530\Desktop\taslak\")
C:\Users (kullanıcılar) klasörüne erişim izniniz olmadığından dosya oluşmuyordur
https://www.dosyaupload.com/bhL9 bu dosyayı deneyin dosyadaki kodlar yeni bir excel kitabı oluşturup
"c:\users" klasörüne atacak eğer hata verirse dediğim gibidir.
O zaman "kullanıcılar" klasörünü "özellikler\ güvenlik\gelişmiş" sekmesinden ayarlamak gereklidir veya "D:" diskini kullanılabilir