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

ما دامت ورقة العمل محمية فلا يمكن دمج الخلايا إلا باستعمال كود VBA وأن يبدأ الكود بسطر لفك الحماية ثم أي كود تريده كدمج نطاق معين أو دمج الخلايا المحددة ثم آخر سطر لإعادة حماية الشيت مرة أخرى ActiveSheet.Unprotect "password" Range("C3:E3").Merge 'Selection.Merge ActiveSheet.Protect "password" وأنصح ألا يحتاج المستخدم لدمج خلايا جديدة بعد حماية ورقة العمل فالأولى دمج الخلايا قبل الحماية بالتوفيق

عليكم السلام وبالاذن ربما Book111_1.xlsm

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

برنامج شئون الطلبة 2024 اهم مميزات البرنامج: استيراد(نسخ) البيانات من النسخة السابقة من البرنامج بضغطة واحدة ترحيل البيانات للعام الدراسي الجديد بضغطة واحدة بدون نسخ من صف ولصق في الصف الاخر صفحة البيانات لكل صف بها ايقونات للترتيب ابجدي او البنات اولا او البنين اولا او حسب القيد قوائم الفصول حسب العدد في كل صف كلما زاد العدد اتسعت القائمة ملفات التقييم لكل صف ( اعمال السنة ) ملفات تقييم الانشطة التقييم الخاص بالنشاط الرياضي كشوف توزيع الكتب كشوف الصحة للتطعيمات دمج جميع الصفوف الدراسية في صفحة واحدة لسجل القيد والمصروفات وملفات الانجاز ايقونة لمسح جميع البيانات للبرنامج في واجهة البرنامج وايقونة مسح لكل صف دفتر 5 سلوك فورم للبحث عن بيانات اي تلميذ بمجرد كتابة اول حرف من الاسم سجل لتسليم الكتب المدرسية بكل المواد سجل لكشوف وزارة الصحة الخاص بتطعيمات التلاميذ سجل للغياب الاسبوعي لتسجيل الغياب الالكتروني انضم لقناة التليجرام لمتابعة كل ما هو جديد https://t.me/edartelmadrsa البرنامج كبير لم استطع وضعه بالمرفقات رابط التحميل https://mega4upload.com/eplkzxb1byhy اسم المستخدم : ابواليسر كلمة المرور . : 55555 ابواليسر لشئون الطلبة 2024.rar

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

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

يمكنك إضافة شكل شفاف بدون إطار وعند تحديده تكتب في شريط المعادلة =J5 ليعرض النص المختار من القائمة ويمكن تحريك هذا الشكل إذا تغير حجم الصورة بالتوفيق

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

تم معرفة سبب هذه المشكلة

بارك الله فيك استاذنا

وعليكم السلام ورحمة الله وبركاته.. فعلا أنا استمتعت بقراءة السؤال 😄 مثال ونموذج يحتذى به في طريقة عرض الطلب 👍🏼🙂 وربما ترتيبك لخطوات التحقق في السؤال سيسهل التطبيق للإخوة إن شاء الله ..

بارك الله فيكم جميعا على الردود المفيدة والطيبة.

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

بارك الله فيك أخي @أبوأحـمـد

اذا اردت بالكود وجب عليك ارفاق ملف xlsm بناء على مرفقك وقلة التفاصيل لا تتوقع احد ان يجيبك . حتى تجد تفاعل اكثر ضع النتائج المتوقعة في الشيتات المستهدفة . عندما تكون الاكواد ضعيفة مع حجم بيانات كبيرة على الرغم من ان بياناتك قليلة جدا عندها استخدم الفلترة هذا مجرد تخمين واذاكان هناك شيء نسيته او شرحته بطريقة خاطئة وجب عليك تطويع الكود بنفسك . Sub CopyData() Application.ScreenUpdating = False Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = ThisWorkbook.Sheets("بيانات") Set ws2 = ThisWorkbook.Sheets("سجل قيد") Set ws3 = ThisWorkbook.Sheets("سجل حالات") With ws1 .Range("A1").AutoFilter 10, "" .AutoFilter.Range.Copy With ws2 .Range("A1").PasteSpecial xlPasteValues End With .Range("A1").AutoFilter End With With ws1 .Range("A1").AutoFilter 10, "<>" .AutoFilter.Range.Copy With ws3 .Range("A1").PasteSpecial xlPasteValues End With .Range("A1").AutoFilter End With Application.ScreenUpdating = True End Sub Book1.xlsm

ما شاء الله ايه الحاجات الجديده والجميله دى زادك الله سبحانه وتعالي من علمه

بارك الله فيك وزادك الله من فضله -جمعة مباركة ان شاء الله

ما شاء الله إبداع وفقك الله أخي الفاضل ابو أحمد

السلام عليكم أخي الكريم جرب الكود التالي في حدث المصنف ThisWorkbook Private Sub Workbook_NewSheet(ByVal Sh As Object) Dim R As Integer, G As Integer, B As Integer Randomize R = Int(Rnd() * 256) G = Int(Rnd() * 256) B = Int(Rnd() * 256) Sh.Tab.Color = RGB(R, G, B) End Sub سيعمل الكود فقط عند إضافة ورقة عمل جديدة

تفضل جرب هذا التعديل جعل اسم مربع النص 11 وليس 12 وعمل بعض التعديلات في نوع المتغيرات التي تساعد في عملية البحث بالتوفيق متابعة8.xlsm

أخي الكريم مطلوبك سهل بإذن الله لكن يوجد بعض الخطوات قبل تنفيذه وهي: إعادة حفظ الملفات باسم (ولو بنفس الاسم) حيث أنها تظهر خطأ عند فتحها ضبط مكان الارقام في العمود K حيث أنها في معظم الملفات في العمود K بعدها اصنع ملفا وضع به هذا الكود Sub GetDataFromFiles() Dim oFSO As Object, oFolder As Object, oFile As Object Dim lr As Long, iCnt As Long, iTotalRows As Long Dim src As Workbook, dst As Workbook Set dst = ActiveWorkbook Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFolder = oFSO.GetFolder(ActiveWorkbook.Path) Application.ScreenUpdating = False For Each oFile In oFolder.Files If oFile.Name <> ActiveWorkbook.Name And Left(oFile.Name, 1) <> "~" Then Set src = Workbooks.Open(oFile.Path, True, True) iTotalRows = src.Worksheets(1).Cells(Rows.Count, "K").End(xlUp).Row For iCnt = 1 To iTotalRows lr = dst.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row dst.Sheets(1).Range("A" & lr + 1).Value = src.Sheets(1).Range("K" & iCnt).Value Next iCnt src.Close False End If Next oFile Set oFSO = Nothing: Set oFolder = Nothing: Set oFile = Nothing Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub ثم قم بتنفيذ هذا الإجراء سيتم جلب بيانات العمود K من الملفات في العمود A في الملف الجديد الذي به الكود بالتوفيق

تفضل Private Sub CommandButton7_Click() Call Addimg(CommandButton7.Caption) End Sub Private Sub CommandButton8_Click() Call Addimg(CommandButton8.Caption) End Sub Private Sub CommandButton9_Click() Call Addimg(CommandButton9.Caption) End Sub Private Sub CommandButton10_Click() Call Addimg(CommandButton10.Caption) End Sub Private Sub CommandButton11_Click() Call Addimg(CommandButton11.Caption) End Sub 'توحيد الإجراء Function Addimg(CommandC As String) Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim sh As Worksheet: Set sh = Sheets("الفلتر") sh.Range("a4:j150") = "" sh.[f1].Value = CommandC k = 4 lr = ws.Range("c" & Rows.Count).End(xlUp).Row For R = 5 To lr If ws.Range("c" & R) = sh.Range("f1") Then For j = 1 To 10 sh.Cells(k, j) = ws.Cells(R, j) Next k = k + 1 End If Next X = sh.Range("d999").End(xlUp).Row For i = 1 To X Controls("Label" & i).Caption = sh.Cells(i + 3, 4) Next End Function

أشكرك أخي عمر على كلامك الطيب بنظرة سريعة على الكود من الأفضل توحيد الإجراء حتى لا يتكرر مع كل صورة واستدعاء الإجراء فقط ليكون بهذا الشكل ما عليك إلا وضع هذا السطر عند ضغط الصور Call AddItemL(Label2.Caption) فقط غير رقم الليبل Private Sub Image1_Click() Call AddItemL(Label1.Caption) End Sub Private Sub Image2_Click() 'استدعاء الاجراء ووضع اليبل المناسب لكل صورة Call AddItemL(Label2.Caption) End Sub 'توحيد الإجراء Function AddItemL(LabelC As String) X = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.List(i, 0) = LabelC Then X = 1 Exit For End If Next i TextBox1 = WorksheetFunction.VLookup(LabelC, Range("d4:h99"), 5, 0) If X = 1 Then 'Me.ListBox1.AddItem Me.ListBox1.List(i, 1) = Me.ListBox1.List(i, 1) + 1 Me.ListBox1.List(i, 2) = Me.ListBox1.List(i, 1) * TextBox1 Else Me.ListBox1.AddItem Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = LabelC Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = 1 Me.ListBox1.List(i, 2) = TextBox1 End If End Function

وعليكم السلام احذف 'Me.ListBox1.AddItem عند تحقق الشرط ليصبح الكود بهذا الشكل Private Sub Image1_Click() X = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.List(i, 0) = Label1.Caption Then X = 1 Exit For End If Next i TextBox1 = WorksheetFunction.VLookup(Label1, Range("d4:h99"), 5, 0) If X = 1 Then 'Me.ListBox1.AddItem Me.ListBox1.List(i, 1) = Me.ListBox1.List(i, 1) + 1 Me.ListBox1.List(i, 2) = Me.ListBox1.List(i, 1) * TextBox1 Else Me.ListBox1.AddItem Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = Label1.Caption Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = 1 Me.ListBox1.List(i, 2) = TextBox1 End If End Sub Private Sub Image2_Click() X = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.List(i, 0) = Label2.Caption Then X = 1 Exit For End If Next i TextBox1 = WorksheetFunction.VLookup(Label2, Range("d4:h99"), 5, 0) If X = 1 Then 'Me.ListBox1.AddItem Me.ListBox1.List(i, 1) = Me.ListBox1.List(i, 1) + 1 Me.ListBox1.List(i, 2) = Me.ListBox1.List(i, 1) * TextBox1 Else Me.ListBox1.AddItem Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = Label2.Caption Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = 1 Me.ListBox1.List(i, 2) = TextBox1 End If End Sub

وعليكم السلام يمكنك استبدال الكود لتصبح النتائج كما تريد مرفق ربطاً الملف أما إن كانت لا تزال هناك مشكلة في ظهور اللغة فأنت بحاجة إلى تعديل الإعدادات من لوحة التحكم خيارات اللغة كما أن الكود السابق الموجود لديك يعمل بشكل صحيح وقد رأيت أنك استخدمته كمعادلة الصفيف بضغط Ctrl+shift+enter >>> جرب كتابة المعادلة ثانية بالضغط فقط على Enter وستحل المشكلة لديك بإذن الله تقبل تحياتي. المصنف1.xlsm

استبدل الكود الاتى Private Declare Function ShellExecute _ Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hWnd As Long, _ ByVal Operation As String, _ ByVal Filename As String, _ Optional ByVal Parameters As String, _ Optional ByVal Directory As String, _ Optional ByVal WindowStyle As Long = vbMinimizedFocus _ ) As Long بهذا الكود Private Declare PtrSafe Function ShellExecute _ Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hWnd As Long, _ ByVal Operation As String, _ ByVal Filename As String, _ Optional ByVal Parameters As String, _ Optional ByVal Directory As String, _ Optional ByVal WindowStyle As Long = vbMinimizedFocus _ ) As Long وسوف يفتح ان شاء الله

بسم الله الرحمن الرحيم أساتذتى بالمنتدى و ألاخوة الزملاء كل عام وانتم بخير بمناسبة العام الجديد مما لا شك فيه أن الأهداء يقدم الى أغلى شخص لدى الانسان وبما انه اغلى شخص فلابد من تقديم أغلى هدية يملكها فسمحو لى ان اقدم أغلى ما املك واعز ما أملك وهو برنامج EMA الى أغلى منتدى . منتدى أوفيسنا هذا الصرح العظيم الذى شرفت بالانضمام اليه أهداء برنامج EMA برنامج EMA تم تصميمة بعمل متواصل على مدار 300 يوم بمعدل لا يقل عن 5 ساعات يوميا معظمها كان البحث والتفكير وكيفية التنفيذ فأن أحسنت فمن الله وما توفيقى الا بالله وأن أخطأت فمن نفسى والشيطان والحمد لله الذى بنعمته علينا تتم الصالحات تم رفع البرنامج بتاريخ 29-9-2014م وهذا كان الاصدار الاول من الجزء الاول للبرنامج وبعد التواصل مع الاعضاء ومشاركتى لأرائهم طلب منى بعض الاضافات الاخرى والحمد لله تم ذالك أقدم لكم الاصدار الثانى من الجزء الاول أتمنى أن يحوز اعجابكم ورضاكم البرنامج به أمكانيات وخيارات كبيرة جدا تم تصميمه على اعلى مستوى من الرقابه والتحكم فى المدخلات أنا الحمد لله عملت على برامج كبرى وهذا البرنامج عصارة خبرة محاسبية وأنتظرو منى قريباً الجزء الثانى للبرنامج (المخازن والمبيعات والمشتريات) فى نفس الملف وأخيرا وليس أخراً البرنامج بين أيديكم لا يتم فتج البرنامج الا فى الساعه 12ص أى بالليل 2015/1/1م لأنه نسخة عام 2015م ملحوظه مهمه جدا 1-يفضل تشغيل البرنامج على 2007 2-لا يتم تغيير اسم البرنامج نهائيا لانه لا يفتح عند تغيير- الاسم (EMA)فقط فى بعض الاحيان عند التنزيل يكون EMA 1 فى هذه الحالة يحذف 1 أن شاء الله نرفق لكم شرح لكيفية العمل على البرنامج اسم المستخدم / الدعم الفنى الباسورد / 123 EMA.zip

السلام عليكم ورحمة الله وبركاته ****************** نويت بإذن الله تعالى - والله الموفق - أن أقوم بالبدء في هذا المشروع الكبير الذي أطلقت عليه اسم (مكتبة الصرح .. زاخرة بالشرح) بحثت عن ملف الأستاذ الكبير عبد الله باقشير (محفظة الأكواد) للعمل عليه .. ** رجاء من الأخ عبد الله .. إضافة للفورم في هذا الملف أن تكون عملية البحث غير مقتصرة على عناوين الأكواد فقط ، بل تشمل عمليه البحث الـ ListBox الذي يحوي الأكواد نفسها ، وكذلك صفحة التعليمات ، حتى يسهل فيما بعد على الباحث أن يصل لمراده بسهولة .. الأمر مختلف قليلاً عما قدم من قبل ، إذ أن الأكواد ستكون مصحوبة بالشرح (على قدر استطاعتي ) ولمن أراد أن يزيد على الشرح فليفعل ولا يتردد.. من هنا بإذن الله ستكون الإنطلاقة الكبرى نحو المشروع الكبير .. وسأحاول جاهداً أن أبدأ عملية بناء المكتبة بشكل منظم يسهل على الباحث فيما بعد الوصول للكود الذي يرغبه ، ويعرف كيف يقوم بتطبيق الكود بنفسه دون الحاجة لغيره .. يعني مبدأ الاعتماد على النفس في تطبيق الأكواد.. وإليكم الملف المرفق به 5 أكواد فقط مدعومة بالشرح منها 3 اكواد بسيطة ، وكود صعب قليلا ، ودالة معرفة UDF كنقطة بداية .. ملحوظة الأكواد مدعومة بالشرح في صفحة التعليمات . أرجو أن ينال رضاكم ... ولا تنسوا التصحيح والتنقيح إخواني أولاً بأول ، حتى يخرج العمل في النهاية بشكل لائق يليق بمنتدانا .. يليق بالصرح العملاق ولذا أسميت المشروع (مكتبة الصرح والصرح المقصود به منتدانا الغالي .. وإن شاء الله تكون المكتبة زاخرة وممتلئة بالشرح بعون الله وتوفيقه ثم بجهودكم ومساندتكم للمشروع) Codes Library.rar

السلام عليك اليك الحل لعله المطلوب تغيير كلمة المرور.rar

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

ربما يفيد هذا الملف بدون VBA True_vlookup.rar

يمكن استخدام الجملة Select Case .. سأرفق لك ملف حاول الاستفادة منه وتطبيق الشروط ومرفق صورة جزء من حلقات افتح الباب لشرح استخدامها Select Case Tutorial ListenData.rar

شاشة الدخول تاخد بيانتها من صفحة الصلاحيات لو محتاج تغير شاشة الدخول وممكن مسح كل ما بداخل الملف ووضع شيتاتك مع الحفاظ على صفحة الصلاحيات اما اذا كنت تريد الطريقة اليك الشرح داخل السلسلة للفيجوال بيسك http://www.officena.net/ib/topic/65629-سلسلة-دروس-الفيجوال-بيسك-6-والاكسيل-من-علي-مصطبة-ياسر-العربي/ اما اذا كان الموضوع شاق عليك ممكن اعملك الشاشة بالشكل اللي تحتاجه وكلمة المرور للملف التي تحتاجها حتى تحميه من الفتح مستقل انظر اولا للموضوع لتعرف الفكرة وبعدها قرر تقبل تحياتي

حسب ما فهمت من الموضوع 1- نقوم بترتيب الطلبة وفقا لمعدلهم و بالطبع من الاكبر الى الاصغر 2- في حالة تساوي معدلات الطلاب نقوم بالتفريق بينهم على اساس السن و الاولية للاصغر سنا 3- في حالة تساوي السن تكون المفاضلة حسب الترتيب الابجدي للاسماء.......... ..... المعادلة التي طرحتها تقوم بترتيب الطلبة وفقا لمعدلاتهم ... و لكن لا تحقق النقطة 2 و 3 .... لذا يجب تحسين المعادلة New WinRAR archive.rar

1 – عمل ملف اكسل (كتابة كود الماكرو) 2- انشاء ملف VBScript لتشغيل الماكرو 3 – كتابة ملف دفعي او باتش batch لفحص الوقت 4 – انشاء ملف تنصيب خدمة الويندوز Windows Service ___________________________________________ بسم الله الرحمن الرحيم على الله نتوكل وبه نستعين ملاحظة ===== اذا لم تفرأ الخطوات السابقة بعد فأني اشد على يدك ان تقرأها اولا قبل الاستمرار. سنفترض التالي: 1 - جميع الملفات في المسار التالي (بالطبع يمكنك وضعهم في اي مجلد من اختيارك) C:\work\2015 2 - الخدمة ستعمل تحت حساب النظام المحلي Local System Account 3 - الخدمة ستحتاج الى وسيط وهو اسم ملف الباتش RunSummaryMacro.cmd لتشغيله 4 - الخدمة ستعمل اوتوماتيكيا كل مرة يشتغل فيها الجهاز. 5 - اسم الخدمة هو AbuTorab (يمكنك تسميتها ما تشاء) انشاء خدمة ويندوز هى من اكثر الخطوات تشويقا و اثارة..و لهذا سنبدأ على عكس ما بدأناه في الخطوات السابقة....سنبدأ من النهايــــــــــــة. 1 - انقر بالزر الايمن و اختر Run as Administrator 2 - اخل حرف Y للموافقة على تنصيب الخدمة 3 - تم تنصيب الخدمة بنجاح...لاحظ ان رقم العملية PID للخدمة على جهازي هى 5144 4 - هنا قد انتهينا من تنصب الخدمة الا انه استكمالا للشرح لنرى الخدمة وهى تعمل في الخلفية. اضغط شعار ويندوز + R واكتب Services.msc من هنا يمكنك ايقاف و تشغيل الخدمة 5 - لنرى الخدمة من شريط المهام اضغط Ctrl + Shift + Esc .. اختر التبويب Services ومن ثم التبويب Details ماذا ترى!!! 6 - الاسم في التبويب Services هو كما توقعناه AbuTorab ولكن الاسم في التبويب Details مختلف!!! السبب هو ملف الباتش لا يستطيع من تلقاء نفسه التخاطب مع مركز خدمات الويندوز و لهذا نحتاج الى تغليفه wrap باداة صغير لديها القدرة على التخاطب مع النظام و في نفس الوقت القدرة على تشغيل ملف الباتش و الاداة هى Srvany.exe. توجد ادوات اخرى ولكن استخدمت هذه و يمكنك استخدام ما تريد يمكنك تحميل مجموعة الادوات من موقع شركة ميكروسوفت او يمكنك تحميلها من المرفق ستطلب هذه الاداة ان تعمل لها ثلاث قيم في سجل النظام ... وهذه القيم هى: AppDirectory : مسار المجلد الذي يحتوي على ملف الباتش Application : ملف الباتش مع المسار AppParameters: وسائط ملف الباتش..في مثالنا سيكن ملف الاسكربت ملاحظة: ===== عند انشاء الخدمة سيتم اضافتها الى سجل النظام في المسار التالي: HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\AbuTorab اذا اردت ان ترها بنفسك فأضغط شعار ويندوز + R و اكتب RegEdit للتوضيح راجع الصورة التالية: لنتحدث قليل على اوامر انشاء الخدمة Windows Service ================================ 1- لانشاء الخدمة يمكننا عن طريق الامر sc في محرر الاوامر (هذا الامر يحتاج الى صلاحيات مدير النظام لينفذ) SC create AbuTorab binpath="C:\work\2015\srvany.exe" 2- لجعل الخدمة تعمل اوتوماتيكيا عن تشغيل/إعادة تشغيل النظام ننفذ الامر التالي: SC config AbuTorab start=auto 3- لتشغيل الخدمة sc start AbuTorab 4- لحذف الخدمة SC delete AbuTorab 5 - لتحديث قيم سجل النظام ننفذ الاوامر التالية reg add "HKLM\SYSTEM\CurrentControlSet\Services\AbuTorab\Parameters" /v AppDirectory /t REG_SZ /d "C:\Work\2015" reg add "HKLM\SYSTEM\CurrentControlSet\Services\AbuTorab\Parameters" /v Application /t REG_SZ /d "C:\Work\2015\RunSummaryMacro.cmd" reg add "HKLM\SYSTEM\CurrentControlSet\Services\AbuTorab\Parameters" /v AppParameters /t REG_SZ /d "C:\Work\2015\RunSummaryMacro.vbs" ملاحظة مهمة و اخيرة اذا نفذت الاوامر السابقة فان الخدمة ستعمل و ملف الباتش سيعمل و ملف الاسكربت سينفذ و لكن لن ينفذ الماكرو برامج الاوفس هى برامج تفاعلية interactive تتفاعل مع حساب المستخدم الذي سجل الدخول وهو ليس حساب تشغيل الخدمة الا وهو System و لهذا فان الماكرو لن ينفذا...لتحقيق هذا التفاعل نحتاج لوجود مجلد باسم Desktop على المسار التالي: في نسخة الويندوز 64 بت: c:\windows\SysWOW64\config\systemprofile\Desktop في نسخة الويندوز 32 بت: c:\windows\System32\config\systemprofile\Desktop كود ملف تنصيب الخدمة @ECHO OFF SET ServiceName=AbuTorab ECHO A new Windows service called "%ServiceName%" will be installed ECHO. CHOICE /C YNC /M "Press Y for Yes, N for No or C for Cancel." IF %ERRORLEVEL% neq 1 (EXIT) mkdir %windir%\SysWOW64\config\systemprofile\Desktop mkdir %windir%\System32\config\systemprofile\Desktop CLS SET CurrentDir=%~dp0 sc create %ServiceName% binpath="%CurrentDir%srvany.exe" reg add "HKLM\SYSTEM\CurrentControlSet\Services\%ServiceName%\Parameters" /v AppDirectory /t REG_SZ /d %CurrentDir% reg add "HKLM\SYSTEM\CurrentControlSet\Services\%ServiceName%\Parameters" /v Application /t REG_SZ /d "%CurrentDir%RunSummaryMacro.cmd" reg add "HKLM\SYSTEM\CurrentControlSet\Services\%ServiceName%\Parameters" /v AppParameters /t REG_SZ /d "%CurrentDir%RunSummaryMacro.vbs" sc config %ServiceName% start=auto sc start %ServiceName% ECHO. ECHO ========================================================= ECHO The %ServiceName% has been installed and run successfully ECHO ========================================================= SET CurrentDir= SET ServiceName= pause @ECHO ON مخرجات الخطوة الاخيرة ================= اسم ملف التنصيب : Installِ_AbuTorab_Service.bat اسم ملف الاداة : srvany.exe جميع الملفات تجدها على المرفق و يمكنك البدء تم بحمد الله الذي بنعمه تتم الصالحات 2015.zip

1 – عمل ملف اكسل (كتابة كود الماكرو) 2- انشاء ملف VBScript لتشغيل الماكرو 3 – كتابة ملف دفعي او باتش batch لفحص الوقت 4 – انشاء ملف تنصيب خدمة الويندوز Windows Service _____________________________________________________________________ بالنسبة للخطوة الاولى و هى كتابة كود الماكرو سنفترض التالي: 1- لدينا شيت اسمها Data وهى تحمل مبيعات اليوم 2- شيت اخرى اطلقنا عليها Summary و تحمل اجمالي المبيعات لجميع الايام. 3- ينفذ الماكرو Summary في وقت معين وذلك لتحديث الشيت Summary بإجمالي المبيعات على حسب المعادلة التالي: '/حدث مبيعات السنة Sheets(SHEET_SUMMARY).Range("A2") = Val(Sheets(SHEET_SUMMARY).Range("A2")) + Val(Sheets(SHEET_DATA).Range("A2")) 4 - يفضل متابعة سجل تنفيد الماكرو لهذا تم عمل شيت ثالثة باسم Log لمتابعة اوقات تنفيد الماكرو. كود الماكرو ======= Option Explicit Public Const SHEET_DATA As String = "Data" Public Const SHEET_SUMMARY As String = "Summary" Public Const SHEET_LOG As String = "log" Public Sub Summary() Dim Row As Long '/حدث مبيعات السنة Sheets(SHEET_SUMMARY).Range("A2") = Val(Sheets(SHEET_SUMMARY).Range("A2")) + Val(Sheets(SHEET_DATA).Range("A2")) '/حدث اوقات تنفيد الماكرو Sheets(SHEET_LOG).Range("B3") = Sheets("Log").Range("B3") + 1 Sheets(SHEET_LOG).Range("C3") = Date Sheets(SHEET_LOG).Range("D3") = Time Row = Sheets(SHEET_LOG).Range("B3") + 5 Sheets(SHEET_LOG).Range("A" & Row) = Row - 5 Sheets(SHEET_LOG).Range("B" & Row) = Date Sheets(SHEET_LOG).Range("C" & Row) = Time Sheets(SHEET_LOG).Range("D" & Row) = Environ("UserName") Sheets(SHEET_LOG).Range("E" & Row) = Application.UserName End Sub مخرجات الخطوة الاولى ================= اسم ملف الاكسل : Summary2015.xlsm اسم الماكرو : Summary تحياتي Summary2015.zip