:agla: İyi Geceler
VBAProject e şifrelediğim zaman
Run-Time error 50289 Can't perform since the project is protected
hatası veriyor kodlar Aşağıda
Modul 1 deki kod :
Sub HDDSeriNo()
Dim FSO As Object, Surucu As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Surucu = FSO.GetDrive("C:")
Seri = Surucu.SerialNumber
MsgBox Surucu & "22222222" & Seri
Set Surucu = Nothing
Set FSO = Nothing
End Sub
Sub a()
MsgBox "_ _--Programa Hoşgeldiniz...", , "Güvenlik Kontrolu...."
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Surucu = FSO.GetDrive("C:")
If Surucu.SerialNumber = 442307598 Or Surucu.SerialNumber = 22222222 Or Surucu.SerialNumber = 33333333 Then
MsgBox " Güvenli Giriş Onaylandı...."
Application.Run "Sayfa_ac"
Exit Sub
Else
Application.Run "Sayfa_gizle"
ThisWorkbook.Save
Application.Quit
End If
End Sub
Sub Auto_Close()
Application.Run "Sayfa_gizle"
ThisWorkbook.Save
End Sub
Sub Sayfa_ac()
For i = 1 To Sheets.Count
Sheets(i).Visible = True
Next i
End Sub
Sub Sayfa_gizle()
For i = 2 To Sheets.Count
Sheets(i).Visible = False
Next i
End Sub
Sub kapa()
EnableControl 21, False ' cut
EnableControl 19, False ' copy
EnableControl 22, False ' paste
EnableControl 755, False ' pastespecial
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "+{DEL}", ""
Application.OnKey "+{INSERT}", ""
Application.CellDragAndDrop = False
End Sub
Sub AC()
EnableControl 21, True ' cut
EnableControl 19, True ' copy
EnableControl 22, True ' paste
EnableControl 755, True ' pastespecial
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "+{DEL}"
Application.OnKey "+{INSERT}"
Application.CellDragAndDrop = True
End Sub
Modül 2 deki kod:
Public MyUser As String
Public MyPass As String
'
Sub c()
Dim UserArr
UserArr = Array("Huseyin", "Turker", "RedKid")
Select Case Format(Date, "w")
Case 1 To 3
MyPassword = "sifre1"
Case 4 To 7
MyPassword = "sifre2"
End Select
ThisWorkbook.IsAddin = True
MyPasswBox
If MyPass <> "" And MyUser <> "" Then
For i = LBound(UserArr) To UBound(UserArr)
If MyUser = UserArr(i) And MyPass = MyPassword Then
ThisWorkbook.IsAddin = False
MsgBox UserArr(i) & ", girişiniz onaylandı !", _
vbInformation, "Bilgi..."
Exit Sub
End If
Next
MsgBox "Kullanıcı adı ve şifrenizi kontrol edin !", vbCritical, "Dikkat !"
End If
End Sub
'
Sub MyPasswBox()
Dim PassWForm
Set PassWForm = ThisWorkbook.VBProject.VBComponents.Add(3)
PassWForm.Properties("Width") = 200
PassWForm.Properties("Height") = 120
PassWForm.Properties("Caption") = "Ãifre girişi !"
Set NewLabel = PassWForm.Designer.Controls.Add("forms.Label.1")
With NewLabel
.Width = 50
.Height = 18
.Left = 8
.Top = 22
.Caption = " Kullanıcı Adı :"
End With
Set NewLabel = PassWForm.Designer.Controls.Add("forms.Label.1")
With NewLabel
.Width = 50
.Height = 18
.Left = 8
.Top = 44
.Caption = " Ãifre :"
End With
Set NewTextBox = PassWForm.Designer.Controls.Add("forms.TextBox.1")
With NewTextBox
.Width = 120
.Height = 18
.Left = 60
.Top = 20
.PasswordChar = "*"
.ForeColor = vbRed
End With
Set NewTextBox = PassWForm.Designer.Controls.Add("forms.TextBox.1")
With NewTextBox
.Width = 120
.Height = 18
.Left = 60
.Top = 42
.PasswordChar = "*"
.ForeColor = vbRed
End With
Set NewCommandButton1 = PassWForm.Designer.Controls.Add("forms.CommandButton.1")
With NewCommandButton1
.Caption = "Vazgeç"
.Height = 18
.Width = 50
.Left = 70
.Top = 72
End With
Set NewCommandButton2 = PassWForm.Designer.Controls.Add("forms.CommandButton.1")
With NewCommandButton2
.Caption = "Tamam"
.Height = 18
.Width = 50
.Left = 130
.Top = 72
End With
With PassWForm.CodeModule
X = .CountOfLines
.InsertLines X + 1, "Sub CommandButton1_Click()"
.InsertLines X + 2, "Unload Me"
.InsertLines X + 3, "End Sub"
.InsertLines X + 4, "Sub CommandButton2_Click()"
.InsertLines X + 5, "MyUser = TextBox1"
.InsertLines X + 6, "MyPass = TextBox2"
.InsertLines X + 7, "Unload Me"
.InsertLines X + 8, "End Sub"
.InsertLines X + 9, "Sub UserForm_Activate()"
.InsertLines X + 10, "Me.SpecialEffect=3"
.InsertLines X + 11, "End Sub"
End With
VBA.UserForms.Add(PassWForm.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=PassWForm
End Sub
Modul 3 teki kod:
Sub Autpen()
a
c
End Sub
VBAProject e şifrelediğim zaman
Run-Time error 50289 Can't perform since the project is protected
hatası veriyor kodlar Aşağıda
Modul 1 deki kod :
Sub HDDSeriNo()
Dim FSO As Object, Surucu As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Surucu = FSO.GetDrive("C:")
Seri = Surucu.SerialNumber
MsgBox Surucu & "22222222" & Seri
Set Surucu = Nothing
Set FSO = Nothing
End Sub
Sub a()
MsgBox "_ _--Programa Hoşgeldiniz...", , "Güvenlik Kontrolu...."
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Surucu = FSO.GetDrive("C:")
If Surucu.SerialNumber = 442307598 Or Surucu.SerialNumber = 22222222 Or Surucu.SerialNumber = 33333333 Then
MsgBox " Güvenli Giriş Onaylandı...."
Application.Run "Sayfa_ac"
Exit Sub
Else
Application.Run "Sayfa_gizle"
ThisWorkbook.Save
Application.Quit
End If
End Sub
Sub Auto_Close()
Application.Run "Sayfa_gizle"
ThisWorkbook.Save
End Sub
Sub Sayfa_ac()
For i = 1 To Sheets.Count
Sheets(i).Visible = True
Next i
End Sub
Sub Sayfa_gizle()
For i = 2 To Sheets.Count
Sheets(i).Visible = False
Next i
End Sub
Sub kapa()
EnableControl 21, False ' cut
EnableControl 19, False ' copy
EnableControl 22, False ' paste
EnableControl 755, False ' pastespecial
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "+{DEL}", ""
Application.OnKey "+{INSERT}", ""
Application.CellDragAndDrop = False
End Sub
Sub AC()
EnableControl 21, True ' cut
EnableControl 19, True ' copy
EnableControl 22, True ' paste
EnableControl 755, True ' pastespecial
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "+{DEL}"
Application.OnKey "+{INSERT}"
Application.CellDragAndDrop = True
End Sub
Modül 2 deki kod:
Public MyUser As String
Public MyPass As String
'
Sub c()
Dim UserArr
UserArr = Array("Huseyin", "Turker", "RedKid")
Select Case Format(Date, "w")
Case 1 To 3
MyPassword = "sifre1"
Case 4 To 7
MyPassword = "sifre2"
End Select
ThisWorkbook.IsAddin = True
MyPasswBox
If MyPass <> "" And MyUser <> "" Then
For i = LBound(UserArr) To UBound(UserArr)
If MyUser = UserArr(i) And MyPass = MyPassword Then
ThisWorkbook.IsAddin = False
MsgBox UserArr(i) & ", girişiniz onaylandı !", _
vbInformation, "Bilgi..."
Exit Sub
End If
Next
MsgBox "Kullanıcı adı ve şifrenizi kontrol edin !", vbCritical, "Dikkat !"
End If
End Sub
'
Sub MyPasswBox()
Dim PassWForm
Set PassWForm = ThisWorkbook.VBProject.VBComponents.Add(3)
PassWForm.Properties("Width") = 200
PassWForm.Properties("Height") = 120
PassWForm.Properties("Caption") = "Ãifre girişi !"
Set NewLabel = PassWForm.Designer.Controls.Add("forms.Label.1")
With NewLabel
.Width = 50
.Height = 18
.Left = 8
.Top = 22
.Caption = " Kullanıcı Adı :"
End With
Set NewLabel = PassWForm.Designer.Controls.Add("forms.Label.1")
With NewLabel
.Width = 50
.Height = 18
.Left = 8
.Top = 44
.Caption = " Ãifre :"
End With
Set NewTextBox = PassWForm.Designer.Controls.Add("forms.TextBox.1")
With NewTextBox
.Width = 120
.Height = 18
.Left = 60
.Top = 20
.PasswordChar = "*"
.ForeColor = vbRed
End With
Set NewTextBox = PassWForm.Designer.Controls.Add("forms.TextBox.1")
With NewTextBox
.Width = 120
.Height = 18
.Left = 60
.Top = 42
.PasswordChar = "*"
.ForeColor = vbRed
End With
Set NewCommandButton1 = PassWForm.Designer.Controls.Add("forms.CommandButton.1")
With NewCommandButton1
.Caption = "Vazgeç"
.Height = 18
.Width = 50
.Left = 70
.Top = 72
End With
Set NewCommandButton2 = PassWForm.Designer.Controls.Add("forms.CommandButton.1")
With NewCommandButton2
.Caption = "Tamam"
.Height = 18
.Width = 50
.Left = 130
.Top = 72
End With
With PassWForm.CodeModule
X = .CountOfLines
.InsertLines X + 1, "Sub CommandButton1_Click()"
.InsertLines X + 2, "Unload Me"
.InsertLines X + 3, "End Sub"
.InsertLines X + 4, "Sub CommandButton2_Click()"
.InsertLines X + 5, "MyUser = TextBox1"
.InsertLines X + 6, "MyPass = TextBox2"
.InsertLines X + 7, "Unload Me"
.InsertLines X + 8, "End Sub"
.InsertLines X + 9, "Sub UserForm_Activate()"
.InsertLines X + 10, "Me.SpecialEffect=3"
.InsertLines X + 11, "End Sub"
End With
VBA.UserForms.Add(PassWForm.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=PassWForm
End Sub
Modul 3 teki kod:
Sub Autpen()
a
c
End Sub