تحديد الفترة التجريبية لملف اكسل ( طريقة حديثة ومبتكرة )

[مختار حسين محمود]

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

أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل .

فكرة الكود :  عند فتح الملف  يتم انشاء ملف نصى دون شعور المستخدم 

يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود

بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى :

1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه

2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج  وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل

الكود وعليه الشرح :

Option Explicit

Private Sub Workbook_Open()

      Dim StartTime#, CurrentTime#
      '----------------------------------------------------------
      ' اعداد الفترة التجريبية كالتالى
      ' Integers 1, 2, 3,30 ,365 ...etc = number of days use
      ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use
       Const TrialPeriod# = 30     ' 30 days trial
      '----------------------------------------------------------
      
      'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية
       Const ObscurePath = "C:\"
       Const ObscureFile = "Test File Log.Log"
      
      'اذا كان الملف ذو المسار والاسم المحدد فارغا فان
      If Dir(ObscurePath & ObscureFile) = Empty Then
            ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص
            StartTime = Format(Now, "#0.#########0")
            'جواب الشرط : افتح الملف ذو المسار والاسم المحدد
            Open ObscurePath & ObscureFile For Output As #1
            'تابع جواب الشرط : اكتب فى الملف  بداية الوقت
            Print #1, StartTime
      
      Else ' فى حالة عدم تحقق الشرط فان
            'افتح الملف ذو المسار والاسم للتحقق من وقت البداية
            Open ObscurePath & ObscureFile For Input As #1
            Input #1, StartTime
            
            ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص
            CurrentTime = Format(Now, "#0.#########0")
            
            'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية
            If CurrentTime < StartTime + TrialPeriod Then
                  Close #1 ' غلق الملف المبهم قيد الاستعمال
                  Exit Sub              ' الخروج من الاجراء
            
            Else ' فى حالة عدم تحقق الشرط
                  
                  If [A1] <> "Expired" Then  ' اذا كانت الخلية لا تساوى النص  "Expired" فان
                        
                        ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف  للاستعمال
                        MsgBox "Sorry, your trial period has expired " & vbLf & _
                        "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _
                        "This workbook will then be made unusable."
                        
                        Close #1 ' غلق الملف المبهم قيد الاستعمال
                        
                        SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم
                        
                        [A1] = "Expired"
                        ActiveWorkbook.Save                     ' حفظ الملف
                        Application.Quit                 ' اغلاق اكسل نهائيا
                  
                  ElseIf [A1] = "Expired" Then   ' اذا كانت الخلية تساوى النص  "Expired" فان
                         Close #1                            ' غلق الملف المبهم قيد الاستعمال
                        Application.Quit                                  ' اغلاق اكسل نهائيا
                  End If
            End If
      End If
      Close #1
End Sub

Sub SaveShtsAsBook()
      ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل
      
      Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer
      
      MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
                   
      With Application
            .ScreenUpdating = False                    ' ايقاف تحديث الشاشة
            .DisplayAlerts = False                        ' ايقاف التنبيهات
             On Error Resume Next                    ' فى حالة الخطأ تجاهله
             MkDir MyFilePath                  ' انشاء مجلد فارغ باسم الملف
            
             For N = 1 To Sheets.Count      ' حلقة تكرارية بعدد أوراق الملف
                  Sheets(N).Activate                          ' تنشيط الشيت
                  SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت
                  Cells.Copy                               ' نسخ كامل الشيت
                  Workbooks.Add (xlWBATWorksheet)     ' انشاء ملف اكسل جديد
                  
                  With ActiveWorkbook                      ' مع الملف النشط
                        With .ActiveSheet                  ' مع الشيت النشط
                              .Paste                     ' لصق البيانات فيه
                              .Name = SheetName    ' تسمية الشيت النشط
                              [A1].Select                    ' تنشيط الخلية
                        End With
                        ' حفظ الملف النشط فى المجلد باسم الشيت النشط
                        .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls"
                        ' غلق الملف النشط مع حفظ البيانات
                        .Close SaveChanges:=True
                  End With
              .CutCopyMode = False ' تفريغ الذاكرة العشوائية
              Next ' الشيت التالى
      End With
            
      ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد
      Open MyFilePath & "\Read Me.log" For Output As #1
      ' كتابة الأسطر التالية فى الملف النصى
      Print #1, "Thank you for trying out this product."
      Print #1, "If it meets your Requirements, visit :"
      Print #1, "http://www.officena.com  "
      Print #1, "to purchase the full  version..."
      Print #1, ""
      Print #1, " --------- Regards -------------"
      Print #1, "Mokhtar Hussien officena team"
      Close #1  ' غلق الملف النصى
      
End Sub

الكود يوضع فى حدث   Workbook   بامكانك تعديل مسار الملف النصى 

وبامكانك تعديل الفترة التجريبية  الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود 

لتجربة الكود : اذهب الى الملف النصى  ستجد رقما زى كده :  42298.7085185185    ده هو وقت تشغيل الملف 

نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح  42298.  يعنى نخلية 42250  مثلا ونحفظ الملف النصى على كدة

روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش 

مرفق للتجربة :

Trial Version Ended 30 days.rar

[ياسر خليل أبو البراء]

أخي الحبيب محتار

موضوعاتك مميزة للغاية وهامة للغاية .. والغاية تبرر الوسيلة (أي كلام وبهزر معاك)

بارك الله فيك وجزاك الله كل خير على كل ما تقدمه من علم نافع ومفيد لإخوانك

تقبل وافر تقديري واحترامي

[مختار حسين محمود]

أستاذى العزيز الغالى  ياسر خليل

هذا بعض ما عندكم  أستاذى الكبير لا حرمنا الله منك ولا من ابداعاتك المستمرة    تحياتى وتقديرى الدائمين لشخصكم الكريم

 

[عبد العزيز البسكري]

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

بارك الله فيك أستاذنا القدير مختار حسين محمود على هداياك المميّزة .. جزاك الله خيرًا و زادها بميزان حسناتك

                                                             إحتراماتي

 

 

[مختار حسين محمود]

أخى الحبيب الغالى زيزو   بارك الله فيكم وجازاكم خيرا ونفع بكم  كل التحية والقدير لكل أهل الجزائر وخاصة البسكرية

[وائل الاسيوطي]

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

أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل .

فكرة الكود :  عند فتح الملف  يتم انشاء ملف نصى دون شعور المستخدم 

يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود

بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى :

1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه

2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج  وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل

الكود وعليه الشرح :

Option Explicit

Private Sub Workbook_Open()

      Dim StartTime#, CurrentTime#
      '----------------------------------------------------------
      ' اعداد الفترة التجريبية كالتالى
      ' Integers 1, 2, 3,30 ,365 ...etc = number of days use
      ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use
       Const TrialPeriod# = 30     ' 30 days trial
      '----------------------------------------------------------
      
      'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية
       Const ObscurePath = "C:\"
       Const ObscureFile = "Test File Log.Log"
      
      'اذا كان الملف ذو المسار والاسم المحدد فارغا فان
      If Dir(ObscurePath & ObscureFile) = Empty Then
            ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص
            StartTime = Format(Now, "#0.#########0")
            'جواب الشرط : افتح الملف ذو المسار والاسم المحدد
            Open ObscurePath & ObscureFile For Output As #1
            'تابع جواب الشرط : اكتب فى الملف  بداية الوقت
            Print #1, StartTime
      
      Else ' فى حالة عدم تحقق الشرط فان
            'افتح الملف ذو المسار والاسم للتحقق من وقت البداية
            Open ObscurePath & ObscureFile For Input As #1
            Input #1, StartTime
            
            ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص
            CurrentTime = Format(Now, "#0.#########0")
            
            'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية
            If CurrentTime < StartTime + TrialPeriod Then
                  Close #1 ' غلق الملف المبهم قيد الاستعمال
                  Exit Sub              ' الخروج من الاجراء
            
            Else ' فى حالة عدم تحقق الشرط
                  
                  If [A1] <> "Expired" Then  ' اذا كانت الخلية لا تساوى النص  "Expired" فان
                        
                        ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف  للاستعمال
                        MsgBox "Sorry, your trial period has expired " & vbLf & _
                        "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _
                        "This workbook will then be made unusable."
                        
                        Close #1 ' غلق الملف المبهم قيد الاستعمال
                        
                        SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم
                        
                        [A1] = "Expired"
                        ActiveWorkbook.Save                     ' حفظ الملف
                        Application.Quit                 ' اغلاق اكسل نهائيا
                  
                  ElseIf [A1] = "Expired" Then   ' اذا كانت الخلية تساوى النص  "Expired" فان
                         Close #1                            ' غلق الملف المبهم قيد الاستعمال
                        Application.Quit                                  ' اغلاق اكسل نهائيا
                  End If
            End If
      End If
      Close #1
End Sub

Sub SaveShtsAsBook()
      ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل
      
      Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer
      
      MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
                   
      With Application
            .ScreenUpdating = False                    ' ايقاف تحديث الشاشة
            .DisplayAlerts = False                        ' ايقاف التنبيهات
             On Error Resume Next                    ' فى حالة الخطأ تجاهله
             MkDir MyFilePath                  ' انشاء مجلد فارغ باسم الملف
            
             For N = 1 To Sheets.Count      ' حلقة تكرارية بعدد أوراق الملف
                  Sheets(N).Activate                          ' تنشيط الشيت
                  SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت
                  Cells.Copy                               ' نسخ كامل الشيت
                  Workbooks.Add (xlWBATWorksheet)     ' انشاء ملف اكسل جديد
                  
                  With ActiveWorkbook                      ' مع الملف النشط
                        With .ActiveSheet                  ' مع الشيت النشط
                              .Paste                     ' لصق البيانات فيه
                              .Name = SheetName    ' تسمية الشيت النشط
                              [A1].Select                    ' تنشيط الخلية
                        End With
                        ' حفظ الملف النشط فى المجلد باسم الشيت النشط
                        .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls"
                        ' غلق الملف النشط مع حفظ البيانات
                        .Close SaveChanges:=True
                  End With
              .CutCopyMode = False ' تفريغ الذاكرة العشوائية
              Next ' الشيت التالى
      End With
            
      ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد
      Open MyFilePath & "\Read Me.log" For Output As #1
      ' كتابة الأسطر التالية فى الملف النصى
      Print #1, "Thank you for trying out this product."
      Print #1, "If it meets your Requirements, visit :"
      Print #1, "http://www.officena.com  "
      Print #1, "to purchase the full  version..."
      Print #1, ""
      Print #1, " --------- Regards -------------"
      Print #1, "Mokhtar Hussien officena team"
      Close #1  ' غلق الملف النصى
      
End Sub

الكود يوضع فى حدث   Workbook   بامكانك تعديل مسار الملف النصى 

وبامكانك تعديل الفترة التجريبية  الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود 

لتجربة الكود : اذهب الى الملف النصى  ستجد رقما زى كده :  42298.7085185185    ده هو وقت تشغيل الملف 

نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح  42298.  يعنى نخلية 42250  مثلا ونحفظ الملف النصى على كدة

روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش 

مرفق للتجربة :

Trial Version Ended 30 days.rar

سلمت يداك اخي الاسيوطي 

عمل رائع يضاف لقائمه اعملك 

بس ياتري عندك فكره جديده لتجديد الفتره بعد انتهاء الفتره

[مختار حسين محمود]

سلمت من كل شر أستاذ وائل

كأنك تقرأ ما دار ببالى فى الفترة الماضية يا اسيوطى

أنت تعرف أن الموضوع ده كان هيبقى اسمه تحديد وتجديد الفترة التجريبية لملف اكسل

فقد حاولت التعديل على الكود بالبحث عن طريقة غير مألوفة لتجديد الفترة التجريبية

لن تكن النتائج كما ينبغى والآن ليس أمامنا الا البحث أو اللجوء الى  الطرق التقليدية المألوفة فى اعادة الفترة التجريبية

[۩◊۩ أبو حنين ۩◊۩]

اخى الحبيب / مختار

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

 

الا عند تشغيلة تظهر الرساله التاليه 

 Open ObscurePath & ObscureFile For Output As #1

اين الخطاء

 

 

تم تعديل أكتوبر 23, 2015 بواسطه ۩◊۩ أبو حنين ۩◊۩

[ياسر خليل أبو البراء]

أخي الحبيب أبو حنين

غير المسار إلى البارتشن D أو أي بارتشن آخر

Const ObscurePath = "C:\"

 

[مختار حسين محمود]

الأخ أبا حنين

أعتقد أنه  أثناء تجربتك للملف قد حدث خطأ ما فى ملف الاكسل   قد يكون أن الملف النصى لم يتم انشاؤه أو أنك غيرت اسمه أو فى الداتا التى به والله أعلم

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

تم تعديل أكتوبر 23, 2015 بواسطه مختار حسين محمود

[وائل الاسيوطي]

سلمت من كل شر أستاذ وائل

كأنك تقرأ ما دار ببالى فى الفترة الماضية يا اسيوطى

أنت تعرف أن الموضوع ده كان هيبقى اسمه تحديد وتجديد الفترة التجريبية لملف اكسل

فقد حاولت التعديل على الكود بالبحث عن طريقة غير مألوفة لتجديد الفترة التجريبية

لن تكن النتائج كما ينبغى والآن ليس أمامنا الا البحث أو اللجوء الى  الطرق التقليدية المألوفة فى اعادة الفترة التجريبية

ههههههه الاسايطه دايما علي قلب رجل واحد 

كنت اود منك ان تطبق ماتفضله من تلك الطرق التقليديه  لتجديد الفتره علي هذا الملف لحين نزول الالهام بحل مثالي ان شاءالله 

[مختار حسين محمود]

ههههههههههههههههى  لو كنت أفضل واحدة لطبقتها كلها فيها ثغرات للدخول الى الملف

[وائل الاسيوطي]

ههههههههههههههههى  لو كنت أفضل واحدة لطبقتها كلها فيها ثغرات للدخول الى الملف

القي نظر علي ملف اخي ياسر العربي وقولي رأيك ولنجعله بدايه للالهام

http://www.officena.net/ib/topic/64153-تغيير-تاريخ-صلاحيه-ملف/

[مختار حسين محمود]

أخى الحبيب وائل

اطلعت على الرابط  وما تفضل به أخينا ياسر العربى عمل جيد ومشكور عليه 

لكن أخى الكريم  كما قلت لك أغلب الطرق المعروفة لاعادة  الفترة التجريبية  للملف بها ثغرات للدخول

اذ أن حماية ملفات الاكسل قد تبدو أمام أصحاب الخبرة القليلة بالاكسل جيدة لكن أمام متوسطى الخبرة و ما سواهم  قاصرة  سهلة  الكسر .

لا أقول لك انتظر الالهام  فأنا لست بملهم وانما مجتهد قدر الامكان ان صحّ التعبير . وسأحاول  وعلى الله التوفيق .   تحياتى