اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر (معدل)

السلام عليكم

هذه الأكواد انسخها الى حدث ThisWorkbook

لنفترض أنا الورقتين المراد عدم حذفها اساميهم "ورقة1" , "ورقة2"


Private Sub Workbook_Open()

Dim S$

With ActiveSheet

S = .Name

If S = "ورقة1" Or S = "ورقة2" Then

   Alidroos_Control_F

    Else

   Alidroos_Control_T

End If

End With

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

If Sh.Name = "ورقة1" Or Sh.Name = "ورقة2" Then

  Alidroos_Control_F

Else

  Alidroos_Control_T

End If

End Sub

Private Sub Alidroos_Control_F()

If Not Application.CommandBars Is Nothing Then

  With Application.CommandBars

   .FindControl(ID:=847).Enabled = False

   .FindControl(ID:=848).Enabled = False

  End With

End If

End Sub

Private Sub Alidroos_Control_T()

If Not Application.CommandBars Is Nothing Then

  With Application.CommandBars

   .FindControl(ID:=847).Enabled = True

   .FindControl(ID:=848).Enabled = True

  End With

End If

End Sub

تم تعديل بواسطه عباد
قام بنشر (معدل)

السلام عليكم ورحمة الله وبركاته

أستاذي وسيدي الفاضل أبا نصار حفظكم الله

جزاكم الله كل خير.

هل ممكن التعديل في الكود حتى يكون المنع من الحذف والنسخ غير ممكن من القوائم أيضاً (أقصد يمكن الحذف والنسخ من قائمة تحريرتحايلاً على الكود).

كما أرجو أضافة كود أستعادة الخاصيتين للعمل عند أقفال الملف (كون بعد أققال الملف نجد أنهما غير مفعلتين في كل مستندات الأكسيل).

أبو أنس

تم تعديل بواسطه أبو أنس حاجب
قام بنشر (معدل)

ولمعرفة الكثير حول أرقام ID لدالة FindControl


Public Sub Com_All()

Dim R&, Ro%, E%

On Error Resume Next

With Application

    .ScreenUpdating = False

    .EnableEvents = False

Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).ClearContents

Range("A1:C1") = Array("تسلسل الرقم", "ايدي الامر", "نوعه المسمى")

R = 2

For Ro = 1 To 12500

Cells(R, 1) = Application.CommandBars.FindControl(ID:=Ro).Type

Cells(R, 2) = Application.CommandBars.FindControl(ID:=Ro).ID '***

Cells(R, 3) = Application.CommandBars.FindControl(ID:=Ro).Caption

R = R + 1

Next

E = Range("A20000").End(xlUp).Row

With Range("C2:C" & E)

   .VerticalAlignment = xlRight

   .HorizontalAlignment = xlRight

End With

For I = E To 2 Step -1

If Range("A" & I).Value = "" Then Range("A" & I).EntireRow.Delete

Next

   .EnableEvents = True

   .ScreenUpdating = True

End With

End Sub

تم تعديل بواسطه عباد
قام بنشر (معدل)

الاخ عباد مشكورا على الرد

ولكن لا اعرف من اين ياتى الخطأ

عندما اقف على الورقه ثم اقوم بعم حزف يتم فعلا حزف الورقه1

وكذلك مع الورقه2

مع العلم باننى اريد عن محاولة الحذف يقوم الكود بعدم تمكينى من ذلك

تم تعديل بواسطه دغيدى
قام بنشر

السلام عليكم

الاخ الفاضل الجزيره

هذا الكود في حدث Thisworkbook

يمنع ادراج ورقة جديدة

بالامكان استخدامه


Private Sub Workbook_NewSheet(ByVal SH As Object)

    MsgBox "لقد تمت عملية إدراج الورقة بنجاح.    ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

    Application.DisplayAlerts = False

    MsgBox "ولكن، لا يمكنك إدراج أي ورقة جديدة بهذا البرنامج.    ", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading

    ActiveSheet.Delete

    MsgBox "وقد تمت عملية حذف الورقة بنجاح أيضاً.    ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

    Application.DisplayAlerts = True

End Sub

  • Like 1
قام بنشر (معدل)

السلام عليكم

الاخ الفاضل الجزيره

هذا الكود في حدث Thisworkbook

يمنع ادراج ورقة جديدة

بالامكان استخدامه


Private Sub Workbook_NewSheet(ByVal SH As Object)

MsgBox "لقد تمت عملية إدراج الورقة بنجاح. ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

Application.DisplayAlerts = False

MsgBox "ولكن، لا يمكنك إدراج أي ورقة جديدة بهذا البرنامج. ", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading

ActiveSheet.Delete

MsgBox "وقد تمت عملية حذف الورقة بنجاح أيضاً. ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

Application.DisplayAlerts = True

End Sub

الاخ عباد تحيه طيبه وبعد

كود رائع

ولكن يمكن التحايل عليه عن طريق الوقوف على اى ورقه وعمل كوبى تو

تم تعديل بواسطه إبراهيم ابوليله
قام بنشر

الكود يلغي النقل او النسخ

ولاكن ملاحظة استاذي عبدالله باقشير بمحلها

عند تحديد اكثر من ورقة

انا بحاول اتوصل الى حل

ان شاء الله

  • 2 years later...
قام بنشر

اريد مساعدت في تعديل على الكود .........

اريد ان اضيف شيت زيادي عليه  

هذا هو الكود ....

Private Sub Workbook_Open()
Dim S$
With ActiveSheet
S = .Name
If S = "SALES" Or S = "RETURN" Then
   Alidroos_Control_F
        Else
   Alidroos_Control_T
End If
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Alidroos_Control_T
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "SALES" Or Sh.Name = "RETURN" Then
  Alidroos_Control_F
Else
  Alidroos_Control_T
End If
End Sub
Private Sub Alidroos_Control_F()
If Not Application.CommandBars Is Nothing Then
  With Application.CommandBars
   .FindControl(ID:=847).Enabled = False
   .FindControl(ID:=848).Enabled = False
  End With
End If
End Sub
Private Sub Alidroos_Control_T()
If Not Application.CommandBars Is Nothing Then
  With Application.CommandBars
   .FindControl(ID:=847).Enabled = True
   .FindControl(ID:=848).Enabled = True
  End With
End If
End Sub

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • اضف...

Important Information