• Merhaba Ziyaretçi,
    Bayrama Özel VIP Paket %50 İndirim Fırsatından yararlanın. (bir kere öde, ömür boyu kullan)

  • Sn. Ziyaretçi,
    PEAKUP E-Book & Makale & Videoları yayınlandı.

Örnek Kod Sayfa Korumasını Kaldırma

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
62
En iyi yanıt
0
Puanları
18
Yaş
32
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Excel'de Alt+F11'e basarak yada "Geliştirici" sekmesinden Visual Basic' e tıklayarak Excel için Visual Basic kodları yazabildiğimiz pencereyi açıyoruz. Açılan pencerede menüden Insert->Module tıklıyoruz. Aşağıdaki kodları açılan pencereye yapıştırıp çalıştır butonuna tıklıyoruz. Çalıştırdıktan sonra küçük bir pencere açılacak ve içinde şifre yazıyor olacak. Açılan pencerede tamam butonuna tıkladığınız zaman o anda açık olan Excel sayfasının koruması kalmış olacak. Eğer birden fazla sayfanız varsa açılan pencerede çıkan şifreyle diğer sayfalarında korumasını kaldırabilirsiniz. Her ne kadar bu şifre orijinal şifreyle aynı olmasa da işe yaradığını göreceksiniz. Biraz daha anlaşılır olması için ekran görüntülerini inceleyebilirsiniz.

Kod:
Sub SifreAc()
Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
For i = 65 To 66
For j = 65 To 66
For k = 65 To 66
For l = 65 To 66
For m = 65 To 66
For i1 = 65 To 66
For i2 = 65 To 66
For i3 = 65 To 66
For i4 = 65 To 66
For i5 = 65 To 66
For i6 = 65 To 66
For n = 32 To 126
ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) _
& Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If ActiveSheet.ProtectContents = False Then
MsgBox "İşlem Tamam Şifre: " & Chr(i) & Chr(j) _
& Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) _
& Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Exit Sub
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
End Sub
1.png2.png3.png
 

anemis

Yeni Üye
Katılım
13 Haz 2018
Mesajlar
22
En iyi yanıt
0
Puanları
3
Yaş
36
Konum
ANKARA
Web sitesi
www.vartamuhendislik.com.tr
Ad Soyad
Tarık VAROL
Uzun süredir kullandığım bir yöntem.
Bazı excel datalarında makroyu çalıştırınca pc kilitleniyor. Galiba çözüm çok uzun sürüyor o sırada da tüm gücü kendi kullanıyor.
 

samtrat

Yeni Üye
Katılım
24 Haz 2018
Mesajlar
2
En iyi yanıt
0
Puanları
3
Yaş
29
Konum
samsun
bi tavsiye de benden. excelin uzantısını winrar yapın rar la açın içinde. bin uzantısını dışarı çıkartın hex editörle açın içinde dpb kelimesi arayın dpx olarak değiştirin tekrar rar dosyasına koyun excele çevirin tamamdır açılmayan excel bile açılıyor. mesela iskoçyalı excelini bilenler bilir her şey şifreli ama tertemiz düz excel oluyor
 

anemis

Yeni Üye
Katılım
13 Haz 2018
Mesajlar
22
En iyi yanıt
0
Puanları
3
Yaş
36
Konum
ANKARA
Web sitesi
www.vartamuhendislik.com.tr
Ad Soyad
Tarık VAROL
bi tavsiye de benden. excelin uzantısını winrar yapın rar la açın içinde. bin uzantısını dışarı çıkartın hex editörle açın içinde dpb kelimesi arayın dpx olarak değiştirin tekrar rar dosyasına koyun excele çevirin tamamdır açılmayan excel bile açılıyor. mesela iskoçyalı excelini bilenler bilir her şey şifreli ama tertemiz düz excel oluyor
Süper. (y)
 

muzos80

Yeni Üye
Katılım
6 Şub 2019
Mesajlar
18
En iyi yanıt
0
Puanları
1
Yaş
47
Konum
Kartal
Ad Soyad
Mustafa Boğa
Merhaba bende işe yaramıyor bekliyorum ama açmıyor daha önce açıyordu 2013 excel kullanıyorum onunla alası olurmu yada açabilecek başka kot varmı
 

syenibagci

Yeni Üye
Katılım
19 Mar 2020
Mesajlar
3
En iyi yanıt
0
Puanları
1
Yaş
32
Konum
ankara
Ad Soyad
necati badem bekdemir
bi tavsiye de benden. excelin uzantısını winrar yapın rar la açın içinde. bin uzantısını dışarı çıkartın hex editörle açın içinde dpb kelimesi arayın dpx olarak değiştirin tekrar rar dosyasına koyun excele çevirin tamamdır açılmayan excel bile açılıyor. mesela iskoçyalı excelini bilenler bilir her şey şifreli ama tertemiz düz excel oluyor
hex editör şifre kırıyor ancak sayfa korumasını kaldırmıyor maalesef :(
 

samtrat

Yeni Üye
Katılım
24 Haz 2018
Mesajlar
2
En iyi yanıt
0
Puanları
3
Yaş
29
Konum
samsun
Şifreyi kırıyor koruma kalkıyor ben hep o işlemi kullanıyorum
 

muzos80

Yeni Üye
Katılım
6 Şub 2019
Mesajlar
18
En iyi yanıt
0
Puanları
1
Yaş
47
Konum
Kartal
Ad Soyad
Mustafa Boğa
Makro daha önceden yapıyordu bu işi ama şimdi olmuyor, anladım arkadaşlar teşekkür ederim
 

muzos80

Yeni Üye
Katılım
6 Şub 2019
Mesajlar
18
En iyi yanıt
0
Puanları
1
Yaş
47
Konum
Kartal
Ad Soyad
Mustafa Boğa
Yabancı sitelerde bu makroyu buldum ama bende hata veriyor anlamadığım için çözüm üretemiyorum bir inceleyebilirmisiniz

PHP:
Sub RemoveProtection()







Dim dialogBox As FileDialog



Dim sourceFullName As String



Dim sourceFilePath As String



Dim sourceFileName As String



Dim sourceFileType As String



Dim newFileName As Variant



Dim tempFileName As String



Dim zipFilePath As Variant



Dim oApp As Object



Dim FSO As Object



Dim xmlSheetFile As String



Dim xmlFile As Integer



Dim xmlFileContent As String



Dim xmlStartProtectionCode As Double



Dim xmlEndProtectionCode As Double



Dim xmlProtectionString As String







'Open dialog box to select a file



Set dialogBox = Application.FileDialog(msoFileDialogFilePicker)



dialogBox.AllowMultiSelect = False



dialogBox.Title = "Select file to remove protection from"







If dialogBox.Show = -1 Then



    sourceFullName = dialogBox.SelectedItems(1)



Else



    Exit Sub



End If







'Get folder path, file type and file name from the sourceFullName



sourceFilePath = Left(sourceFullName, InStrRev(sourceFullName, "\"))



sourceFileType = Mid(sourceFullName, InStrRev(sourceFullName, ".") + 1)



sourceFileName = Mid(sourceFullName, Len(sourceFilePath) + 1)



sourceFileName = Left(sourceFileName, InStrRev(sourceFileName, ".") - 1)







'Use the date and time to create a unique file name



tempFileName = "Temp" & Format(Now, " dd-mmm-yy h-mm-ss")







'Copy and rename original file to a zip file with a unique name



newFileName = sourceFilePath & tempFileName & ".zip"



On Error Resume Next



FileCopy sourceFullName, newFileName







If Err.Number <> 0 Then



    MsgBox "Unable to copy " & sourceFullName & vbNewLine _



        & "Check the file is closed and try again"



    Exit Sub



End If



On Error GoTo 0







'Create folder to unzip to



zipFilePath = sourceFilePath & tempFileName & "\"



MkDir zipFilePath







'Extract the files into the newly created folder



Set oApp = CreateObject("Shell.Application")



oApp.Namespace(zipFilePath).CopyHere oApp.Namespace(newFileName).items







'loop through each file in the \xl\worksheets folder of the unzipped file



xmlSheetFile = Dir(zipFilePath & "\xl\worksheets\*.xml*")



Do While xmlSheetFile <> ""







    'Read text of the file to a variable



    xmlFile = FreeFile



    Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Input As xmlFile



    xmlFileContent = Input(LOF(xmlFile), xmlFile)



    Close xmlFile







    'Manipulate the text in the file



    xmlStartProtectionCode = 0



    xmlStartProtectionCode = InStr(1, xmlFileContent, "<sheetProtection")







    If xmlStartProtectionCode > 0 Then







        xmlEndProtectionCode = InStr(xmlStartProtectionCode, _



            xmlFileContent, "/>") + 2 '"/>" is 2 characters long



        xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _



            xmlEndProtectionCode - xmlStartProtectionCode)



        xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")







    End If







    'Output the text of the variable to the file



    xmlFile = FreeFile



    Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Output As xmlFile



    Print #xmlFile, xmlFileContent



    Close xmlFile







    'Loop to next xmlFile in directory



    xmlSheetFile = Dir







Loop







'Read text of the xl\workbook.xml file to a variable



xmlFile = FreeFile



Open zipFilePath & "xl\workbook.xml" For Input As xmlFile



xmlFileContent = Input(LOF(xmlFile), xmlFile)



Close xmlFile







'Manipulate the text in the file to remove the workbook protection



xmlStartProtectionCode = 0



xmlStartProtectionCode = InStr(1, xmlFileContent, "<workbookProtection")



If xmlStartProtectionCode > 0 Then







    xmlEndProtectionCode = InStr(xmlStartProtectionCode, _



        xmlFileContent, "/>") + 2 ''"/>" is 2 characters long



    xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _



        xmlEndProtectionCode - xmlStartProtectionCode)



    xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")







End If







'Manipulate the text in the file to remove the modify password



xmlStartProtectionCode = 0



xmlStartProtectionCode = InStr(1, xmlFileContent, "<fileSharing")



If xmlStartProtectionCode > 0 Then







    xmlEndProtectionCode = InStr(xmlStartProtectionCode, xmlFileContent, _



        "/>") + 2 ''"/>" is 2 characters long



    xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _



        xmlEndProtectionCode - xmlStartProtectionCode)



    xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")







End If







'Output the text of the variable to the file



xmlFile = FreeFile



Open zipFilePath & "xl\workbook.xml" & xmlSheetFile For Output As xmlFile



Print #xmlFile, xmlFileContent



Close xmlFile







'Create empty Zip File



Open sourceFilePath & tempFileName & ".zip" For Output As #1



Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)



Close #1







'Move files into the zip file



oApp.Namespace(sourceFilePath & tempFileName & ".zip").CopyHere _



oApp.Namespace(zipFilePath).items



'Keep script waiting until Compressing is done



On Error Resume Next



Do Until oApp.Namespace(sourceFilePath & tempFileName & ".zip").items.Count = _



    oApp.Namespace(zipFilePath).items.Count



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



Loop



On Error GoTo 0







'Delete the files & folders created during the sub



Set FSO = CreateObject("scripting.filesystemobject")



FSO.deletefolder sourceFilePath & tempFileName







'Rename the final file back to an xlsx file



Name sourceFilePath & tempFileName & ".zip" As sourceFilePath & sourceFileName _



& "_" & Format(Now, "dd-mmm-yy h-mm-ss") & "." & sourceFileType







'Show message box



MsgBox "Çalışma Kitabındaki Parolalar Başarı ile Kaldırıldı.", _



vbInformation + vbOKOnly, Title:="Password protection"







End Sub
 
Moderatör tarafında düzenlendi:

muzos80

Yeni Üye
Katılım
6 Şub 2019
Mesajlar
18
En iyi yanıt
0
Puanları
1
Yaş
47
Konum
Kartal
Ad Soyad
Mustafa Boğa
aldığım hata da bu şekildedirMakro hata.JPG
 
Üst Alt