Soru Silme Engelleme

FERAZ · 16 Mart 2019

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

FERAZ · 16 Mart 2019

Gogle Drive link.
https://drive.google.com/open?id=1jaJHXljKeC9Dk0YZPZ9l9bxkbkFdYJwr

FERAZ · 16 Mart 2019

Çözüm yok mu?

FERAZ · 23 Mart 2019

Acaba başka dosya yükleme sitelerinemi yüklesem dosyayı.Verdiğim linklerden dısya inmiyormu yoksa çözüm yokmu buna.

ÖmerBey · 23 Mart 2019

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

FERAZ · 23 Mart 2019

Merhaba.Resimdeki gibi hata mesajı çıkyor.

FERAZ · 23 Mart 2019

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

ÖmerBey · 23 Mart 2019

Dosyayı genel erişime açmamışsınız galiba.

FERAZ · 23 Mart 2019

ÖmerBey' Alıntı:
Dosyayı genel erişime açmamışsınız galiba.

Driveri fazla kullanmıyordum fırsat bulunca bir bakayım paylaşım açmaya.Sadece link kopyalamıştım.

FERAZ · 23 Mart 2019

Linki güncelledim.

FERAZ · 23 Mart 2019

İş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

FERAZ · 23 Mart 2019

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 · 23 Mart 2019

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.

FERAZ · 23 Mart 2019

Teşekkür ederim Ömer hocam,elinize sağlık.

FERAZ · 23 Mart 2019

Acaba birde sağ tuşa basınca içerik temizle var ona tıklayınca siliniyor silinmeme olayını bunada uyarlayabilir miyiz?

ÖmerBey · 23 Mart 2019

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.

FERAZ · 23 Mart 2019

ÖmerBey' Alıntı:
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 · 24 Mart 2019

FERAZ' Alıntı:
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 = ""

FERAZ · 24 Mart 2019

Sadece Excel açılışında silme engelleme devreye girmiyor.Dosyanın son hali.

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

FERAZ · 24 Mart 2019

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

Soru Silme Engelleme

FERAZ

FERAZ

FERAZ

FERAZ

ÖmerBey

Destek Ekibi

FERAZ

FERAZ

ÖmerBey

Destek Ekibi

FERAZ

FERAZ

FERAZ

FERAZ

ÖmerBey

Destek Ekibi

FERAZ

FERAZ

ÖmerBey

Destek Ekibi

FERAZ

ÖmerBey

Destek Ekibi

FERAZ

FERAZ