Soru X işaretini devre dışı bırakma

[serif_007]

Arkadaşlar merhaba.

Bir excel tablom var. Bu tablodan her çıkışta belirlediğim klasöre örnek veriyorum D:\Yedek\Aydın\Haziran yoluna yedeklemesini istiyorum. Bunu makro kullanarak yapıyorum fakat X işareti ile çıkınca bu yedeklemeyi yapmıyor. Diğer kullanıcıları bu buton üzerinden kapatmaya zorlamak için "X" işaretini devre dışı bırakmam gerekiyor bunu nasıl yapabilirim?

yedeklemede kullandığım kodlar bu şekilde

Sub Auto_close()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yer = "D:\MANEVRA KAYIT YEDEK\AYDIN\" & Format(Date, "mmmm") & "\"
For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya = Mid(ThisWorkbook.Name, 1, i - 1)
uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next
ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
Kayıt_Yeri = yer & Yedek_Dosya_Adı
On Error Resume Next
If Dir(yer) = "" Then MkDir yer
On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
ActiveWorkbook.Password = ""
Application.DisplayAlerts = True
Application.Quit
End Sub

 

[BAZGİRET]

Private Sub Workbook_BeforeClose(Cancel As Boolean)
MsgBox "Kapatma İşlemini Buradan Yapamazsınız", vbCritical, "KAPATMA"
Cancel = True
End Sub

Bu kodu kullanabilirsiniz.

 

[serif_007]

denedim ama yine X işaretinden çıkış yapabiliyorum

 

[serif_007]

Kodları Sayfa 1 kısmına değilde Bu çalışma kitabı kısmına yapıştırınca sorun kalmadı. Teşekkür ederim

 

[Seceren]

"X" İptal etmeden bu kodları, (BuÇalışmaKitabı) kod sayfasına ekleyip dener misiniz?

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yer = "D:\MANEVRA KAYIT YEDEK\AYDIN\" & Format(Date, "mmmm") & "\"
For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya = Mid(ThisWorkbook.Name, 1, i - 1)
uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next
ActiveWorkbook.Save
Application.DisplayAlerts = False
Yedek_Dosya_Adı = Dosya & Format(Now, " dd_mm_yyyy_hh_mm") & uzanti
Kayıt_Yeri = yer & Yedek_Dosya_Adı
On Error Resume Next
If Dir(yer) = "" Then MkDir yer
On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
ActiveWorkbook.Password = ""
Application.DisplayAlerts = True
Application.Quit
End Sub