دالة او كود يمنع استخدام ملف لغير الجهاز المعني

[ابن الجنوب]

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

من فضلكم كرما لا امرا

انا اريد دالة او كود او طريقة بحيث

1- لا يعمل الملف الا في الجهاز الذي نزلت الملف فيه يعني لا يمكن نسخة وتداوله.

2- وعند حلول تاريخ معين يتوقف الملف عن العمل ويصبح عديم الفايدة ولا يمكن ان يعمل مجدد الا بتدخلي انا وحدي فقط.

ساعدوني جزاكم الله خير 

ورحم الله والديكم

[عبدالله الصاري]

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

المنتدى به الكثير حول هذا الموضوع مثلا

https://www.officena.net/ib/topic/69448-انتحار-ملف-بمجرد-نسخة-أو-نقله-أو-حفظه-بإسم/?tab=comments#comment-451959

https://www.officena.net/ib/topic/54897-تعديل-كود-انتحار-ملف-اكسل/?tab=comments#comment-346960

وغيره الكثير استخدم خاصية البخث

https://www.officena.net/ib/topic/86855-شرح-كيفية-حماية-القاعدة-البيانات-بواسطة-رقم-هارد-مع-المعالج-و-اختيار-مدة-التفعيل/

https://www.officena.net/ib/topic/79857-حماية-قاعدة-البيانات-من-الاستعمال-على-اكثر-من-جهاز/

 

 

 

 

تم تعديل يونيو 18, 2019 بواسطه عبدالله الصاري
اظافة رابط

[Ali Mohamed Ali]

بعد اذن الأستاذ عبدالله وهذا رابط اخر من داخل المنتدى -يمنع فتح الملف اذا تم نقاه وتغيير مكان الحفظ او تغيير اسمه

https://www.officena.net/ib/topic/38637-موضوع-مميز-تمت-الاجابةأريد-كود-يمنع-الملف-من-الفتح-عندما-يستبدل-جهاز-الكمبيوتر-نقله/?tab=comments#comment-261437

وهذا موضوع اخر يخص طلبك وهو ربط بين ملف اكسيل واسم جهاز الكمبيوتر

http://excel-egy.com/forum/t3183

وهذا ايضا موضوع اخر لملف يعمل على جهازين فقط

https://www.officena.net/ib/topic/64356-ملف-يعمل-على-جهازين-فقط/

واخيرا اذا كنت حابب ان تمنع الملف ان يفتح ويعمل على اى جهاز يمكنك تتبع الأتى:

اولا:-عليك بفتح مديول جديد ووضع هذا الكود به

Sub CommitSuicide()
'http://www.cpearson.com/excel/workbooktimebomb.aspx
With ThisWorkbook
    Application.DisplayAlerts = False
    If .Path <> vbNullString Then
        .ChangeFileAccess xlReadOnly
        Kill .FullName
    End If
    .Close SaveChanges:=False
End With
End Sub


Sub Locked(ByVal bEnabled As Boolean)
Dim sh As Worksheet
Dim iHome As Integer
Dim iOthers As Integer


If bEnabled = True Then
    iHome = -1  'visible
    iOthers = 2 'very hidden
Else
    iHome = 2
    iOthers = -1
End If
With ThisWorkbook
    On Error Resume Next
    Application.ScreenUpdating = False
    .Sheets("Welcome").Visible = iHome
    For Each sh In .Sheets
        If Not sh.Name = "Welcome" Then
            sh.Visible = iOthers
        End If
    Next sh
    .Sheets("Welcome").Visible = iHome
    Application.ScreenUpdating = True
    On Error GoTo 0
End With
End Sub

ثانيا :- وضع كود اخر فى حدث This Workbook

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Locked True
End Sub


Private Sub Workbook_Open()
Select Case Environ("COMPUTERNAME")
    Case "LPPC28"   'approved computers
        Locked False
    Case Else
        CommitSuicide
End Select
End Sub

واخيرا عليك بتسمية احد صفحات الملف ب Welcome Sheet ووضع هذا الكود فى حدث هذه الصفحة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Locked False
End Sub

بارك الله فيك

[ابن الجنوب]

الاخ عبدالله الصاري الموقر

والاخ علي محمد علي الموقر

جزاكم الله خيرا ورحم الله والديكم