نجوم المشاركات

السلام عليكم هذا البرنامج عملته في زمن مضى برنامج لتسجيل الأسر : الأجداد والآباء والأبناء والأحفاد بكل يسر وسهولة باستخدام جداول عدة مترابطة و يتم عرضهها في تقرير خاص ايضا استخدمت شجرة الحسابات كمستكشف لعرض الأصول والفروع بطريقة شيقة ولمسات خاصة وبالألوان ولمسات اخرى تجدونها عند تجربة البرنامج ارجوا ممن يستفيد منه الا ينساني من دعوة في ظهر الغيب . Osrah.rar

حسب فهمنا للسؤال .... لأنك لم توضح لماذا تغيير الاسماء ؟؟؟؟؟ يمكن تعديل اسماء هذه الصفحات من خلال الجدول في المرفق اسماء الصفحات.rar

اليكم رابط برنامج عواصم العالم والدول كاملا اصدار رقم 1 https://top4top.io/downloadf-1654wznys1-rar.html ارجو ان ينال اعجابكم وهو يعتبر متكامل لجميع دول العالم وعواصمها واعلامها والقارة التى تقع فيها كل دولة ومستعد لتلقى اى ملاحظات للتعديل فى الاصدار الثانى واحب هنا ان اشكر مشرفين الموقع والاستاذ محمد طاهر للتشجيع المستمر وانا لم اتعلم شيئ الا من هذا الموقع الرائع وهذا رابط اخر علــى الميديا فاير اطلس العالم 1

جرب هذا الملف Ziad.xlsx

هل تم نسخ ملف الباركود في نفس المسار المذكور ؟؟؟ اقصد المسار السابق في الرد C:\Windows\SysWOW64

استعمل هذا الكود C:\Windows\SysWOW64\barcodex.ocx

هل طبقت كما اشرنا لك ممكن مثال مصغر للتطبيق عليه بارك الله فيك

بارك الله فيك الان فهمت ... بالتوفيق.

اخي الكريم انت تريد اظهار التقرير في حال كان النموذج منبثق . صحيح ....

وعليكم السلام ورحمة الله وبركاته نفذ الأتي : عند فتح التقرير في حدث عند نقر زر الأمر ضع هذا الكود DoCmd.OpenReport "اسم التقرير", acViewPreview Me.Visible = False وفي حدث عند الإغلاق في التقرير ضع هذا الكود Forms![اسم النموذج المنبثق].Visible = True

تفضل ...... 33333 (1).rar

هل الويندوز لديك 64 bit

السلام عليكم هذا البرنامج عملته من سنين ، حين كنت اعمل في مكتبة المدرسة برنامج مكتبة مدرسية شامل 1- تسجيل الكتب وتوصيفها 2- تسجيل الطلاب 3- شاشة احترافية لإعارة الكتب واسترجاعها باستخدام قارىء الباركود ، أو باستخدام ادخال رقم الكتاب ورقم الطالب 4 - تقارير متنوعة شاملة 5- محاولة لتفعيل جهاز البصمة للزوار لم تكتمل بعد وميزات اخرى تجدونها عند تجربة البرنامج ارجوا ممن يستفيد منه الا ينساني من دعوة في ظهر الغيب . mktbah.rar

غير الى هذا الكود Dim OutApp As Object Dim OutMail As Object Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row With OutMail .To = Range("A" & i).Value .CC = Range("B" & i).Value .Subject = Range("C" & i).Value .HTMLBody = Range("D" & i).Value .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing MsgBox Range("A" & i).Value Next i إيميللات.xlsm

مرفق ، وبالتوفيق لاحظ أن المعادلة هي: =INDIRECT(ADDRESS(3;COLUMN()-2;;;$D3)) والرقم -2 جاء من فرق مكان الخلايا في الشيتات عن مكانها في الشيت الرئيسي المبيعات.xlsx

السلام عليكم برنامج لإدارة حمامات السباحة والتدريبات والفترات الحرة .. شامل حسابات مرتبات العاملين مدربين إداريين محاسبين عمال .. وكثير من المزايا للتواصل 00201018156170 يدعم الواتساب او علي الايميل التالي soft.sample2014@gmail.com

في مثالك قيم مكررة في الكمبوبكس ... بالتوفيق اخي الكريم @ahmed_ali71470@yahoo.com

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

اعرض الملف كود لقلب وضعية بلوكات كاملة طلب مني زميل حل لعكس ترتيب مجموعة من بلوكات البيانات من الوضعية الافقية الي الوضع الرأسي و ذلك دون تغيير وضعية البيانات داخل البلوك الواحد ، كما هو مبين فى الضورة يمتاز الكود بعدم مجدودية عدد البلوكات (يتم الاختيار طبقا للتظليل) و يمكن تعديله بسهولة ليناسب اعداد الاعمدة المختلفة داخل البلوك و ذلك يتعديل قيمة متغير واحد فى الكود. و لكي تستخدم هذا الكود قم اولا بتحديد عدد الأعمدة داخل كل بلوك عن طريق المتغير CC فى الكود و فى المثال هنا عدد أعمدة كل بلوك هو 3 ـ و يمكنك تغييره كما تشاء ثم قم بتظليل كافة البيانات المراد تغيير وضعها على أن تكون عدد الاعمدة المختارة من مضاعفات الرقم المختار لأعمدة كل بلوك ثم شغل الكود Sub PivotBlocks_arafa() Dim r, c, b As Integer Dim g As String cc = 3 ' قم بتعديل هذا الرقم لتغيير عدد الاعمدة الافتراضي فى البلوك الوحد r = Selection.Rows.Count c = Selection.Columns.Count b = c / cc g = ActiveCell.Address For x = 1 To b - 1 Range(ActiveCell.Offset(0, cc * x), ActiveCell.Offset(r - 1, cc * x + cc - 1)).Cut ActiveCell.Offset(r * x - 1 + 1, 0).Activate ActiveSheet.Paste Range(g).Activate Next x End Sub صاحب الملف محمد طاهر تمت الاضافه 07 يول, 2020 الاقسام قسم الإكسيل  

السلام عليكم مرفق برنامج بسيط للعمل الذي طلبته نحتاج الى بعض المعلومات لغرض تطوير البرنامج تحياتي test-1.accdb

برجاء الاطلاع ع هذا الموضوع بالتوفيق

بالرغم من انك لم ترفع بيانات في ملف (امر مخالف لقوانين المنتدى) اليك هذا النموذج Abou_yousef.xlsm

مبدع دائما استاذ منير الى الأمام تمنياتى بالنجاح والتفوق دائماً

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

وعليكم السلام -تفضل ملف قيم لما تريد List All files from Folder and Sub-folders in Excel Workbook File_Manager.xlsm وهذا ملف اخر Open Excel files in a folder [VBA] List-all-files-in-a-folder.xlsm وهذا الرابط من داخل المنتدى أيضاً سيفيدك للأستاذ محمد صالح شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba

السلام عليكم ورحمة الله بورك فيك اخى الكريم محمد جعل الله لك من دعاءك لى نصيبا و زيادة ان شاء الله

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

المطلوب ليس له حل مثالي، لأن التوزيع مبنى على قيم غير متوافقة (اللغات/ المبالغ) لكن من حسن الحظ أن عدد العملاء كبير في مقابل عدد الموظفين قليل، والتفاوت في المبالغ محدود وليس كبير وهذا جعل عملية التوزيع العشوائي تعمل بشكل جيد ولتأكيد ذلك: قمنا بتوزيع العملاء بالترتيب على الموظفين بالتناوب فظهرت المبالغ التالية: وهذه نسب متقاربة جدا جدا فأول نقطة تجاوزناها: الموظفين يوزعون بالتسلسل وهذا سيحقق الغرض بقي نقطة توزيع العملاء على شيتات الموظفين، تم عمل شيت لكل موظف، ويمكن التحديث بزر التحديث في أعلى يمين الصفحة توزيع العملاء -3.xlsm وبالتوفيق

مشكور جدا وبارك الله فيك. اعذرني على التاخير في الرد الكهرباء اليوم تجاوز 14الساعة وانت اعلم

السلام عليكم ورحمة الله اجعل الكود هكذا Private Sub CommandButton1_Click() UserForm1.TextBox1 = "" Dim ChekCapn As String, Data As String Dim ChekBx As Control, FData As String For Each ChekBx In Me.Controls If TypeName(ChekBx) = "CheckBox" Then ChekCapn = ChekBx.Caption If ChekBx.Value = True Then Data = Data & "," & ChekCapn FData = Mid(Data, 2, Len(Data) - 1) End If End If Next UserForm1.TextBox1.Value = FData Unload Me End Sub

تفضل .... 33333 (1).rar

اللهم ارحم ميتنا رحمة واسعة. اللهم اجعل ذريتها ستراً بينها وبين نار جهنم. تركناها في ذمة الله فصبر جميل، ودعاء بمغفرة، وصلاة الله على سيدنا محمد وعلى آله وصحبه وسلم. اللهم اسقها من حوض نبيك محمد صلى الله عليه وسلم شربة هنيئة مريئة لا تظمأ بعدها أبداً. اللهم أظلها تحت عرشك يوم لا ظل إلا ظلك ولا باقي إلا وجهك. اللهم بيض وجهها يوم تبيض وجوه وتسود وجوه، اللهم يمن كتابها. اللهم ثبت قدمها يوم تزل فيها الأقدام. اللهم اكتبها عندك من الصالحين والصديقين والشهداء والأخيار والأبرار.

السلام عليكم عذرا للتاخير انقطاع الكهرباء وصل لارقام قياسية جرب الملف وبه كود للعلامة عبدالله باقشير طبقته على ملفك ينقص الكود تكملة اسماء الاعمدة المراد ترحيلها فقد قمت بكتابة مادتين فقط وعليك اكمال الباقي ''' أسماء الأعمدة المطلوب نسخها Range("A" & R).Range("b1:c1,g1,i1:k1,s1:u1").Copy طبعا القائمة المنسدلة لم تعد ضرورية تحياتي الترحيل بشرط القسم (1).xlsb

بالتوفيق ...

عمل رائع شكرا لك

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

الله يرحمها ويغفر لها ويدخلها فسيح جناته

انا لله وانا اليه راجعون غفر الله لها ورزقكم الله الصبر لفراقها

ان لله وانا اليه راجعون البقاء لله ... اللهم اغفر لها وارحمها وأدخلها جنات الفردوس الأعلى , وألهم اهلها الصبر والسلوان

لله مااعطى ولله ما اخذ انا لله وإنا اليه راجعون خالص العزاء

حاول ادراج الاداة ضمن المكتبات الموجودة لديك ... انظر ......

الرسالة تفيد بنجاح العملية .... ربما المشكلة في ملف الاكسس

بسم الله الرحمن الرحيم اخواني الاكارم ما يقلق المبرمج عادة عند انتهاء مشروع من مشاريعه الا الملفات التشغيلية المصاحبة للبرنامج والحصول على المساعدة اللازمة لتركيبها ثم تشغيلها والتركيب والتسجيل اليدوي مزعج حتى للمبرمج فكيف بالمستخدم العادي لذا فجعل البرنامج عند التنصيب هو الذي يقوم بالمهمة مطلب ضروري ، وهو ما سنتطرق له في هذا الموضوع علما انه يوجد من تطرق لهذا الموضوع في هذا المنتدى وغيره ولكن لكل موضوع خصوصيته وطريقته فأتمنى ان تجدوا اضافة ومعلومة جديدة في هذا الموضوع وبالله التوفيق يتبع ...

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

أضم صوتي إلى صوت الأخ هل يمكن إرسال رسالة مخصصة لكل شخص (ربما فيها اسمه ونتيجته) وهل يمكن إرسال صورة

وهذا التطبيق لمن يريد اضافة المكتبات وتسجيلها فقط ملحوظة : يجب ان تكون ملفات المكتبات بجانب البرنامج في مجلد واحد tsjeel2.rar

وهذه هي الصيغة النهائية للعمل : Dim objWShell, objReead ' On Error Resume Next Set objWShell = CreateObject("WScript.Shell") objReead = objWShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA") If objReead = "0" And Me.tmp = "0" Then Call tsjeelMktbat Set objWShell = Nothing MsgBox "تم التنصيب واضافة ملفات النظام بنجاح" Exit Sub ElseIf objReead = "1" And Me.tmp = "0" Then objWShell.RegWrite "HKLM\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD" Me.tmp = "1" objWShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce\tsj", "D:\tsjeel.mdb", "REG_SZ" objWShell.Run "shutdown /r /t 10 /f /d P:4:2" 'visit: http://pcsupport.about.com/od/commandlinereference/p/shutdown-command.htm Set objWShell = Nothing Exit Sub Else Call tsjeelMktbat objWShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", "1", "REG_DWORD" MsgBox "تم التنصيب واضافة ملفات النظام بنجاح" 'If MsgBox("سيتم إعادة تشغيل النظام" & vbCrLf & _ ' " هل تريد المتابعة؟", _ ' vbQuestion + vbYesNo, _ ' "اعادة تشغيل النظام") = vbNo Then ' Exit Sub 'Else 'objWShell.Run "shutdown /r /t 10 /f /d P:4:2" Set objWShell = Nothing 'End If End If وهذا هو التطبيق tsjeel.rar

وإياك أخي أبا عمر .. سعدت بمرورك تابع الاجراءات : نحن بحاجة الى كود يجعل النظام يقلع من برنامجنا عند اعادة التشغيل ’ بشرط الا يعمل الا مرة واحدة ويوجد طريقة برمجية يستخدمها البعض وهي نسخ اختصار للبرنامج ولصقه في مجلد بدء التشغيل ثم حذفه عند نهاية التنصيب ولكن يوجد طريقة أسهل من ذلك وهي موجودة ومهيأة في النظام وبالتحديد في التسجيل (الريجستري) فيمكن اعطاء امر وتسجيله ليقوم النظام بتنفيذه مرة واحدة عند بداية التشغيل وهذا هو المكان الذي سنضع فيه الأمر "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce ليصبح بعد اعداده والكتابة فيه هكذا : objWShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce\tsj", "D:\tsjeel.mdb", "REG_SZ" باعتبار برنامجنا سيتم تنصيبه على D باسم tsjeel يتبع ...

شكرا ابا آدم على المتابعة والمساندة وهو تسجيل بعض النتائج المهمة في الحدث . ويهمنا هنا درجة الامان ، فلا بد من شاهد او دليل على درجة الامان الابتدائية فحين يغلق النظام تذهب جميع البيانات العالقة في الذاكرة ، وهذه لا بد من اخذ حسابها من اجل ضبط العملية لذا سيكون من ضمن الكائنات المساعدة حقل في جدول نودع فيه درجة الامان قبل اغلاق النظام لذا سننشء جدولا باسم tblTemp به حقل رقمي باسم tmp دعونا الآن نعرض الاجراءات الاخرى التي سنستخدمها في العملية غير ما تم ذكره اعلاه 1- وحدة نمطية عامة وهي المسؤولة عن تسجيل المكتبات : Option Compare Database Option Explicit Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long Private Declare Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As Long, ByVal lStartAddress As Long, ByVal larameter As Long, ByVal lCreationFlags As Long, lThreadID As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long Private Declare Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long) 'Purpose : This function registers and Unregisters OLE components 'Inputs : sFilePath The path to the DLL/OCX or ActiveX EXE ' bRegister If True Registers the control, else unregisters control 'Outputs : Returns True if successful 'Author : Andrewb 'Date : 04/09/2000 'Notes : This is the API equivalent of RegSvr32.exe. 'Example : ' If RegisterComponent("C:\MyPath\MyFile.dll") = True Then ' Msgbox "Component Successfully Registered" ' Else ' Msgbox "Failed to Registered Component" ' End If 'Revisions : 1/Jan/2002. Updated to include code for registering ActiveX Exes. Function RegisterComponent(ByVal sFilePath As String, Optional bRegister As Boolean = True) As Boolean Dim lLibAddress As Long, lProcAddress As Long, lThreadID As Long, lSuccess As Long, lExitCode As Long, lThread As Long Dim sRegister As String Const clMaxTimeWait As Long = 20000 'Wait 20 secs for register to complete On Error GoTo ErrFailed If Len(sFilePath) > 0 And Len(Dir(sFilePath)) > 0 Then 'File exists If UCase$(Right$(sFilePath, 3)) = "EXE" Then 'Register/Unregister ActiveX EXE If bRegister Then 'Register EXE Shell sFilePath & " /REGSERVER", vbHide Else 'Unregister ActiveX EXE Shell sFilePath & " /UNREGSERVER", vbHide End If RegisterComponent = True Else 'Register/Unregister DLL If bRegister Then sRegister = "DllRegisterServer" Else sRegister = "DllUnRegisterServer" End If 'Load library into current process lLibAddress = LoadLibraryA(sFilePath) If lLibAddress Then 'Get address of the DLL function lProcAddress = GetProcAddress(lLibAddress, sRegister) If lProcAddress Then lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread) If lThread Then 'Created thread and wait for it to terminate lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0) If Not lSuccess Then 'Failed to register, close thread Call GetExitCodeThread(lThread, lExitCode) Call ExitThread(lExitCode) RegisterComponent = False Else 'Successfully registered component RegisterComponent = True Call CloseHandle(lThread) End If End If Call FreeLibrary(lLibAddress) Else 'Object doesn't expose OLE interface Call FreeLibrary(lLibAddress) End If End If End If End If Exit Function ErrFailed: Debug.Print Err.Description Debug.Assert False On Error GoTo 0 End Function 2- وحدة نمطية لقراءة نوع النظام 32بت أو 64بت Public Function IsWin32OrWin64() As String Dim proc_query As String Dim proc_results As Object Dim info As Object proc_query = "SELECT * FROM Win32_Processor" Set proc_results = GetObject("Winmgmts:").ExecQuery(proc_query) For Each info In proc_results IsWin32OrWin64 = info.AddressWidth & "-bit" Next info End Function 3- وحدة نمطية للتأكد من وجود الملف قبل النسخ واللصق : Public Function DoesFileExist(vPathAndFile As String) As Boolean If Len(Dir$(vPathAndFile)) > 0 Then DoesFileExist = True Else DoesFileExist = False End Function 4- وحدة نمطية تقوم بنسخ الملفات من برنامجنا الى المكان الذي نحدده Function CopyFile(vPathSource As String, vPathDestination As String) As Boolean FileCopy vPathSource, vPathDestination CopyFile = True End Function 5- عملية النسخ والتسجيل وتم وضعها في وحدة نمطية عامة : Public Function tsjeelMktbat() Dim sjel As Variant sjel = IsWin32OrWin64() If sjel = "32-bit" Then If Not DoesFileExist("C:\Windows\System32\Barcodex.ocx") Then 'للتأكد من عدم وجود الملف CopyFile CurrentProject.Path & "\Barcodex.ocx", "C:\Windows\System32\Barcodex.ocx" 'نسخ الملف في المكان المحدد RegisterComponent ("C:\Windows\System32\Barcodex.ocx") 'تسجيل الملف Else RegisterComponent ("C:\Windows\System32\Barcodex.ocx") ' وان كان الملف موجود سجله End If 'يمكن اضافة اكثر من ملف اعلاه ElseIf sjel = "64-bit" Then If Not DoesFileExist("C:\Windows\SysWOW64\Barcodex.ocx") Then CopyFile CurrentProject.Path & "\Barcodex.ocx", "C:\Windows\SysWOW64\Barcodex.ocx" RegisterComponent ("C:\Windows\SysWOW64\Barcodex.ocx") Else RegisterComponent ("C:\Windows\SysWOW64\Barcodex.ocx") End If End If End Function يتبع ...

أولا : المعوقات درجة أمان windows حيث لا يمكننا إضافة أو تسجيل ملفات حين تكون درجة امان حساب المستخدم مرتفعة وحتى لو قمنا بتركيبها يدويا فلن يتسنى لنا ذلك الا بعد تخفيض الأمان الى الحد الأدنى ثم اعادة تشغيل النظام وهنا يتبادر سؤال : ماذا لو كان الامان على الحد الأدنى ؟ كيف نعلم ذلك ؟ وهل سيختلف الاجراء ؟ إذا : يجب اولا التأكد من درجة الامان فإن كان منخفضا حينها تتم خطوات التنصيب والا سيقوم البرنامج بتخفيض الامان ثم يعيد تشغيل النظام وهنا يتبادر تساؤل ايضا : هل سيبقى الامان منخفضا ؟ وهل يجب علينا اخبار المستخدم بالوضع الحالي ؟ أم انه يلزمنا اعادة الامان الى وضعه السابق ؟ كل هذه الامور تجعلنا _ وبالاصح تجعلني_ أفضل ان يقوم المستخدم بالعملية بنفسه حيث انها لا تأخذ من المستخدم سوى نقرتين فقط واحدة على زر ابدأ والثانية على صورة المستخدم ليجد أمامه اعدادات التحكم في حسابه . والآن الى الخطوات : 7 windows قراءة حساب المستخدم ودرجة الأمان : Dim objWShell, objReead Set objWShell = CreateObject("WScript.Shell") objReead = objWShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA") اذا كانت درجة الامان مرتفعه نقوم بتخفيضها وإلا نخرج من الحدث : If objReead = "1" Then objWShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD" Else Exit Sub End If ويمكن عكس الوضع : اذا كانت درجة الامان مرتفعه نقوم بتخفيضها وإلا نرفعها If objReead = "1" Then objWShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD" Else objWShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 1, "REG_DWORD" End If يأتي الآن دور تثبيت التغيير ويتحقق بإعادة تشغيل النظام ويمكن تخيير المستخدم بين التنفيذ من عدمه : If MsgBox("سيتم إعادة تشغيل النظام" & vbCrLf & _ " هل تريد المتابعة؟", _ vbQuestion + vbYesNo, _ "اعادة تشغيل النظام") = vbNo Then Exit Sub Set objWShell = Nothing Else objWShell.Run "shutdown /r /t 10 /f /d P:4:2" Set objWShell = Nothing End If انتهينا يتبع ...