Tüm Klasörde Sayfa Koruma

[melrock]

Merhabalar,
Aslında makrolara yabancı sayılırım. Ancak şöyle bir ihtiyacım mevcut.
Excel uygulamasında "Gözden Geçir" (Review) sekmesindeki "Sayfayı Koru" işlemi ile sayfa koruma işlevini gerçekleştirebiliyoruz. Ancak içerisinde çok fazla dosya olan klasörlerim mevcut. Bu klasörlerin içerisindeki tüm Excel dosyalarında ve bu dosyaların tüm sayfalarında bu fonksiyonu çalıştırmak çok zor oluyor. Bunu bir makro yardımıyla yapabilir miyiz acaba?
Özetle bir makro yardımı ile istenilen klasörü göstererek o klasörün içindeki tüm Excel dosyalarının tüm sayfalarında "Sayfayı Koru" işlemini uygulatabilir miyiz?

 

[bmutlu966]

Sanırım böyle bir şey istiyorsunuz.

 

[melrock]

Merhabalar, geç dönüşüm için kusura bakmayın lütfen. dosya koymuşsunuz. çok teşekkürler. lakin dosyayı açamıyorum. sanırım altın üye olmak gerekiyormuş koyduğunuz yerden görebilmek için.

 

[bmutlu966]

Yukarıdaki resimdeki gibi 2 tuş oluşturun ve 2 makroyu bu tuşlara atayın. Size sorulan ve belirlediğiniz şifreyi unutmamanız için şifreniz B5 hücresine yazılır ve bu şifre ile klasördeki tüm dosyaların sayfalarını şifreleyebilirsiniz. Şifreleri aynı şekilde diğer makro ile kaldırabilirsiniz.

Sub sifreleri_Kaldir()
On Error Resume Next

Sifre = InputBox("Lütfen sifreli dosyalari acacak sifrenizi girin")
[B5] = Sifre

Dosyalarin_bulundugu_klasoru_sec

Application.ScreenUpdating = False

If [BM1] = "" Then End

Dim t, dosyasay As Integer
Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder([BM1]).Files

dosyasay = 0

ThisWorkbook.Activate
ThisWorkbook.Sheets("Sifrele").Select


For Each fls In f
    If fso.GetExtensionName(fls) = "xls" Or fso.GetExtensionName(fls) = "xlsx" Or fso.GetExtensionName(fls) = "xlsm" Then
        If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
        For Each sh In Workbooks(fls.Name).Worksheets
For t = 1 To Sheets.Count
Sheets(t).Activate
ActiveSheet.Unprotect Sifre

Next

  ActiveWorkbook.Save
                
        Next sh
        dosyasay = dosyasay + 1
        Workbooks(fls.Name).Close False
    End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sifrele").Select



Application.ScreenUpdating = True
MsgBox dosyasay & " adet sifreli dosyanin sifreleri acildi.", , "BMutlu"


End Sub

Sub sifrele()

On Error Resume Next
Sifre = InputBox("Lütfen sifre belirleyin")
[B5] = Sifre


Dosyalarin_bulundugu_klasoru_sec

Application.ScreenUpdating = False

If [BM1] = "" Then End

Dim t, dosyasay As Integer
Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder([BM1]).Files

dosyasay = 0

ThisWorkbook.Activate
ThisWorkbook.Sheets("Sifrele").Select


For Each fls In f
        If fso.GetExtensionName(fls) = "xls" Or fso.GetExtensionName(fls) = "xlsx" Or fso.GetExtensionName(fls) = "xlsm" Then
        If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
        For Each sh In Workbooks(fls.Name).Worksheets
For t = 1 To Sheets.Count
Sheets(t).Activate
ActiveSheet.Protect Sifre

Next

  ActiveWorkbook.Save
                
        Next sh
        dosyasay = dosyasay + 1
        Workbooks(fls.Name).Close False
    End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sifrele").Select



Application.ScreenUpdating = True
MsgBox dosyasay & " adet dosya sayfalari sifrelendi.", , "BMutlu"


End Sub

Sub Dosyalarin_bulundugu_klasoru_sec()
Dim kaynak As String
[BM1].Clear
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Sifreleyeceginiz Dosyalarinin bulundugu Klasoru Secin", 50, &H0)
If Not Klasor Is Nothing Then
kaynak = Klasor.SELF.Path
[BM1] = kaynak

End If
End Sub

 

[TURKOLOG]

Sayın @bmutlu966 hazırlamış olduğunuz excel dosyasını yüklemeniz mümkün müdür.

 

[bmutlu966]

Sayın @bmutlu966 hazırlamış olduğunuz excel dosyasını yüklemeniz mümkün müdür.

Siz Altın üyesiniz 2 nolu mesajda dosya yüklü zaten.

 

[TURKOLOG]

Çok teşekkür ederim Sayın @bmutlu966
Elinize emeğinize sağlık.

 

[bmutlu966]

https://www.dosya.tc/server27/80ph6n/Dosyalari_Sifrele.xlsm.html

 

[melrock]

Sayın @bmutlu966 yardımınız ve emeğiniz için çok teşekkür ederim. Dosya tam da istediğim şeyi yapıyor. çok sağolun.