Soru Silme Engelleme

Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
https://www.dropbox.com/s/6pnraxo8g1ivvj2/Silme Aktif ve Pasif.zip?dl=0

Merhaba.

Alttaki kodu çalıştıramadım.Sayfada ToggleButton1 var seçime göre silme engelleme mesajı çıkmalı.

Application.OnKey "{del}", "mesaj(sayfa)" burdaki mesaj(sayfa) işi karıştırıyor.
Çalışan ve çalışmayan dosyaları Rar içinde paylaştım linkte.

Amacım sadece istediğim sayfalara uygulmak kodu.

PHP:
Sub mesaj(sayfamsgbox As String)

ThisWorkbook.Sheets(sayfamsgbox).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
sahip = CreateObject("WScript.Network").UserName
MsgBox " Sayfada silme islemi " & sahip & " tarafından engellenmistir.Silmek icin 'Silme Aktif' dügmesine bas."

End Sub

Sub sil(sayfamsgbox As String)
        On Error Resume Next
    ThisWorkbook.Sheets(sayfamsgbox).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, AllowFiltering:=False
    Selection.Cells.ClearContents
End Sub


Private Sub ToggleButton1_Click() 'Togglebutton

Const sayfa As String = "Sayfa1"

With Me.ToggleButton1
    If .Value = True Then
        .BackColor = vbGreen
        .Caption = "Silme Aktif"
        .ForeColor = vbBlack
        On Error Resume Next
         Application.ScreenUpdating = False
         Application.OnKey "{del}", "mesaj(sayfa)"
         Application.OnKey "{backspace}", "mesaj(sayfa)"
         Application.ScreenUpdating = True
    
    Else
    
        .BackColor = vbRed
        .Caption = "Silme Pasif"
        .ForeColor = vbWhite
        
        On Error Resume Next
        Application.ScreenUpdating = False
        Application.OnKey "{del}", "sil(sayfa)"
        Application.OnKey "{backspace}", "sil(sayfa)"
        Application.ScreenUpdating = True
    End If
End With

End Sub
Alttaki kod çalışıyor,üstekini buna göre yapamadım.

PHP:
Sub mesaj()

ThisWorkbook.ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
sahip = CreateObject("WScript.Network").UserName
MsgBox " Sayfada silme islemi " & sahip & " tarafından engellenmistir.Silmek icin 'Silme Aktif' dügmesine bas."

End Sub

Sub sil()
        On Error Resume Next
    ThisWorkbook.ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, AllowFiltering:=False
    Selection.Cells.ClearContents
End Sub


Private Sub ToggleButton1_Click() 'Togglebutton

With Me.ToggleButton1
    If .Value = True Then
        .BackColor = vbGreen
        .Caption = "Silme Aktif"
        .ForeColor = vbBlack
        On Error Resume Next
         Application.ScreenUpdating = False
         Application.OnKey "{del}", "mesaj"
         Application.OnKey "{backspace}", "mesaj"
         Application.ScreenUpdating = True
   
    Else
   
        .BackColor = vbRed
        .Caption = "Silme Pasif"
        .ForeColor = vbWhite
       
        On Error Resume Next
        Application.ScreenUpdating = False
        Application.OnKey "{del}", "sil"
        Application.OnKey "{backspace}", "sil"
        Application.ScreenUpdating = True
    End If
End With

End Sub
 
Son düzenleme:
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Çözüm yok mu?
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Acaba başka dosya yükleme sitelerinemi yüklesem dosyayı.Verdiğim linklerden dısya inmiyormu yoksa çözüm yokmu buna.
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,091
Excel Vers. ve Dili
2007 Türkçe
Merhaba,
Kod:
Application.OnKey "{del}", "calistir"

Private Sub calistir()
mesaj (sayfa)
End Sub
şeklinde 2. bir koddan faydalanabilirsiniz.
Ya da silme kodunuzun başına şu şeklide bir şart ilavesiyle ile belirli bir sayfada çalışmasını sağlarsınız.
Kod:
If ActiveSheet.Name = "Sayfa1" Then
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Merhaba.Resimdeki gibi hata mesajı çıkyor.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Gerçi biraz ayar yapıp ve modül içine alınca kdouve public const olarak tanımlayınca çalıştı fakat extra bir sayfa daha ekleyince kod ordada çalışıor sadece örneğe göre sayfa1 de çalışmalı.Alttaki dosyadaki kodu sayfa1 de çalıştırısanız sayfa2 dede çalıştığını göreceksiniz normalde sadece sayfa1 de çalışmalı.

https://drive.google.com/file/d/1y6PohN0IBcSbfSJUmTDp-sAGfOWf8pbP/view?usp=sharing
 
Son düzenleme:

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,091
Excel Vers. ve Dili
2007 Türkçe
Dosyayı genel erişime açmamışsınız galiba.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
İşk eklediğim dosyadaki parametre kodunu alttaki gibi yapınca halloldu.
Şimdi sadece Sayfa1 de kodu çalıştırmakta.

PHP:
Private Sub ToggleButton1_Click() 'Togglebutton

Const sayfa As String = "Sayfa1"

With Me.ToggleButton1
    If .Value = True Then
        .BackColor = vbGreen
        .Caption = "Silme Aktif"
        .ForeColor = vbBlack
        On Error Resume Next
         Application.ScreenUpdating = False
         Application.OnKey "{del}", "'mesaj """ & sayfa & """'"
         Application.OnKey "{backspace}", "'mesaj """ & sayfa & """'"
         Application.ScreenUpdating = True
    
    Else

        .BackColor = vbRed
        .Caption = "Silme Pasif"
        .ForeColor = vbWhite
        
        On Error Resume Next
        Application.ScreenUpdating = False
        Application.OnKey "{del}", "'sil """ & sayfa & """'"
        Application.OnKey "{backspace}", "'sil """ & sayfa & """'"
        Application.ScreenUpdating = True
    End If
End With

End Sub
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Dosyanın son hali ekte.Kodu alttaki gibi yapınca istediğim oldu sadece sayfa korumasını kaldırınca mesaj çıkmıyor onuda bir şekilde halledince paylaşırım lazım olabilir diye ülkem insanına.

https://drive.google.com/file/d/1y6PohN0IBcSbfSJUmTDp-sAGfOWf8pbP/view?usp=sharing

PHP:
Sub mesaj(sayfamsgbox As String)


ThisWorkbook.Sheets(sayfamsgbox).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
sahip = CreateObject("WScript.Network").UserName
MsgBox " Sayfada silme islemi " & sahip & " tarafýndan engellenmistir.Silmek icin 'Silme Aktif' dügmesine bas."

Dim syf As Worksheet

For Each syf In ThisWorkbook.Sheets
    If syf.Name <> sayfamsgbox Then
        Application.OnKey "{del}"
        Application.OnKey "{backspace}"
        
    End If
Next

Set syf = Nothing
End Sub
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,091
Excel Vers. ve Dili
2007 Türkçe
Merhaba,
Kodlarınızı biraz düzenledim.
Sayfa1 toggle button kodu
PHP:
Private Sub ToggleButton1_Click()
With Me.ToggleButton1
    If .Value = True Then
        .BackColor = vbGreen
        .Caption = "Silme Aktif"
        .ForeColor = vbBlack
      
        For Each syf In syflr
            ThisWorkbook.Sheets(syf).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
        Next
      
        Application.OnKey "{del}", "mesaj"
        Application.OnKey "{backspace}", "mesaj"
    Else
        .BackColor = vbRed
        .Caption = "Silme Pasif"
        .ForeColor = vbWhite
      
        For Each syf In syflr
            ThisWorkbook.Sheets(syf).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, AllowFiltering:=False
        Next
      
        Application.OnKey "{del}"
        Application.OnKey "{backspace}"
    End If
End With
End Sub


Modül kodu
PHP:
Public syflr()
Private Sub Auto_open()
syflr = Array("Sayfa1")
End Sub
Private Sub mesaj()
For Each syf In syflr
    If ActiveSheet.Name = syf Then
        sahip = CreateObject("WScript.Network").UserName
        MsgBox " Sayfada silme islemi " & sahip & " tarafından engellenmistir.Silmek icin 'Silme Aktif' dügmesine bas."
        Exit Sub
    End If
Next
Selection.ClearContents
End Sub
Birden fazla sayfada kodu kullanmak isterseniz syflr = Array("Sayfa1","Sayfa2") şeklinde ekleme yapabilirsiniz. Dosyanızı kaydedip kapatıp yeniden açtığınızda sayfalar dahil olacaktır.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Teşekkür ederim Ömer hocam,elinize sağlık.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Acaba birde sağ tuşa basınca içerik temizle var ona tıklayınca siliniyor silinmeme olayını bunada uyarlayabilir miyiz?
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,091
Excel Vers. ve Dili
2007 Türkçe
Merhaba,
Şu kodu bir deneyiniz: Application.CommandBars("Cell").FindControl(ID:=3125).Enabled=False
True yaptığınızda da aktif edersiniz.
Yalnız şunu da belirtmek isterim ki; bu gibi işlemler sadece yanlışlıkla silinmesini engellemek için yapılır. Aksi takdirde dosyadaki verileri silmeyi kafasına koyan kişi her türlü siler. Amacınız bu ise; acizane tavsiyem "yorulmayın" olacaktır.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Merhaba,
Şu kodu bir deneyiniz: Application.CommandBars("Cell").FindControl(ID:=3125).Enabled=False
True yaptığınızda da aktif edersiniz.
Yalnız şunu da belirtmek isterim ki; bu gibi işlemler sadece yanlışlıkla silinmesini engellemek için yapılır. Aksi takdirde dosyadaki verileri silmeyi kafasına koyan kişi her türlü siler. Amacınız bu ise; acizane tavsiyem "yorulmayın" olacaktır.
Aslında içerik sil olayına tıklayıncada aynı kod mantığı çalışmasıydı.Fakat böylede güzel olmuş pasif yapma olayı.
Dosya sadece bana ait olduğu için başkası kullanmayacak sadece yanlışlıkla silmeyeyim diye önlem amaçlı kod :)
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,091
Excel Vers. ve Dili
2007 Türkçe
Aslında içerik sil olayına tıklayıncada aynı kod mantığı çalışmasıydı.
Aşağıdaki şekilde uygularsanız aynı mantık olabilir.
Kod:
Application.CommandBars("Cell").FindControl(ID:=3125).OnAction = "mesaj"

Application.CommandBars("Cell").FindControl(ID:=3125).OnAction = ""
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Toogle Butonunu kaldırdım çok gıcık bişeymiş :)
Son halini ekledim tam istediğim gibi oldu başka bir excel açıkkende hatalı oluyordu yani onuda etkiliyordu oda halloldu.
Tekrar sağolun Ömer hocam destek için.

https://drive.google.com/file/d/186_IhZK2XEr6zkkKuL9ni5uRvjX4VEen/view?usp=sharing

Sayfa kodlar.

PHP:
Private Sub CommandButton1_Click() 'Silme engelleme
   Call SLmeAktfetme
End Sub

Private Sub CommandButton2_Click() 'Silmeyi aktifleme
   Call SLmeengelleme
End Sub
Modül Kodlar

PHP:
Public syflr()

Sub sayfalarrArray()
    syflr = Array("Sayfa1", "Sayfa2")
End Sub

Private Sub Auto_open()
    Call mesaj
End Sub
Sub auto_Close()
    Call onkeylerpasfetme
    Erase syflr: sayac = Empty
End Sub


Private Sub mesaj()

If ThisWorkbook.Name <> ActiveWorkbook.Name Then Exit Sub
Static sayac As Integer
sayac = sayac + 1
Call sayfalarrArray


For Each syf In syflr
    If ActiveSheet.Name = syf Then
        ThisWorkbook.Sheets(syf).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
        Call onkeyler
        If sayac > 1 Then
            MsgBox " Sayfada silme islemi " & CreateObject("WScript.Network").UserName & _
            " tarafindan engellenmistir.Silmek icin 'Silme Aktif' dügmesine bas."
        End If
        Exit Sub
    End If
Next
Selection.ClearContents

End Sub

Sub onkeyler()
        Application.CommandBars("Cell").FindControl(ID:=3125).OnAction = "mesaj"
        Application.OnKey "{del}", "mesaj"
        Application.OnKey "{backspace}", "mesaj"
End Sub

Sub onkeylerpasfetme()
  ' Application.CommandBars("Cell").FindControl(ID:=3125).Enabled = True'Sag klik icerik temizleme
    Application.CommandBars("Cell").FindControl(ID:=3125).OnAction = ""
    Application.OnKey "{del}"
    Application.OnKey "{backspace}"

End Sub


Sub SLmeAktfetme()
    Call sayfalarrArray
    For Each syf In syflr
        ThisWorkbook.Sheets(syf).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, AllowFiltering:=False
    Next
    Call onkeylerpasfetme
End Sub

Sub SLmeengelleme()
    Call sayfalarrArray
    For Each syf In syflr
      ThisWorkbook.Sheets(syf).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    Next
    '      Application.CommandBars("Cell").FindControl(ID:=3125).Enabled = False
    Call onkeyler
End Sub
 
Üst