[Çözüldü] Şifreleme ve kayıt şifresi hakkında

[drummers]

Ekli dosyama istinaden mümkünse şunları istemekteyim

1- Dosya açılışında şifre soracak fakat bu şifreyi "Düzen" sekmesindeki "IV:1" satırından okuyacak o satırdaki şifre bizim açılış şifremiz olacak.

2- Userform1 üzerindeki "Dosyayı Kaydet" ve excelin kendi kaydet butonuna basıldığında şifre soracak bu sifreyide "Düzen" sekmesindeki "IU:1" satırından okuyacak ve bu bizim kaydetme şifremiz olacak. Eğer şifre 3 sefer yanlış girilirse dosyayı kaydetmeden kapatacak doğru girilise kaydedecek.

İlgileneceklere teşekkürler.

[Hüseyin Çoban]

2- Userform1 üzerindeki "Dosyayı Kaydet" ve excelin kendi kaydet butonuna basıldığında şifre soracak bu sifreyide "Düzen" sekmesindeki "IU:1" satırından okuyacak ve bu bizim kaydetme şifremiz olacak. Eğer şifre 3 sefer yanlış girilirse dosyayı kaydetmeden kapatacak doğru girilise kaydedecek.

Merhaba, arşivimdeki örnek dosyalarda istediğinize benzer bir işlem vardı.
Kodları ThisWorkbook' a yapıştırarak deneyin.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
sifre = InputBox("Dosyayı Kaydet", _
"Yetkili Kişi", "Kaydetmek İçin Şifre girin")
If sifre = Sheets("düzen").Range("ıu1").Text Then
MsgBox "Kayıt işlemi tamamlandı", vbInformation, _
"KAYIT BAŞARILI"
Else
MsgBox "Yanlış şifre girdiniz." & Chr(13) & _
"Dosya kaydedilemedi", vbCritical, "HATALI ŞİFRE"
Cancel = True
End If
End Sub

[Hüseyin Çoban]

1- Dosya açılışında şifre soracak fakat bu şifreyi "Düzen" sekmesindeki "IV:1" satırından okuyacak o satırdaki şifre bizim açılış şifremiz olacak.

Merhaba,
ThisWorkbook daki Private Sub Workbook_Open kodlarını silip aşağıdaki kodları yapıştırarak deneyin.

Private Sub Workbook_Open()
Application.GoTo Reference:=Worksheets("data").Range("A5"), Scroll:=True
Dim SatProgismi, Progismi
' SatProgismi ni küçük harfle yaz
SatProgismi = "drmkayıt v2.xls"
Progismi = ActiveWorkbook.Name
Progismi = Format(Progismi, "<")
If Progismi <> SatProgismi Then
MsgBox "Lütfen Programın İsmini < drmkayıt v2 > haricinde Değiştirmeyiniz .", vbCritical, "Program İsmi Hatalı !"
Application.Quit
Application.DisplayAlerts = False
Else
ActiveWindow.WindowState = xlMaximized
' Kitap ve Sayfa koruması yap
End If

Static sayac As Integer
Do
If sayac = 2 Then
ThisWorkbook.Close False
Else
If InputBox("Şifreyi girin") = Sheets("düzen").Range("ıv1").Text Then
GoTo devam
Else
sayac = sayac + 1
End If
End If
Loop
devam:

End Sub

[drummers]

teşekkürler.