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

برنامج شئون الموظفين مع ارشفةصور المستندات وملفات pdf الباسوورد : 2545 https://youtu.be/A0u_-nowx1s وهذا هو البرنامج برنامج_الموظفين.accdb

الاستاذ احمد قصده : اذا اردت ان تنشر فيديو برنامجك ، فعليك بنشره في الرابط الذي وضعه الاخ احمد ، اما اذا اردت ان يستفيد منه الاعضاء ، ويعطوك تجاربهم ، فأنت في المكان الصحيح هنا 🙂 جعفر

اليك طريقتين لكن في البداية القي نظرتا الى خصائص كومبوبوكس قي هذه الصورة اذا تريد ان يكتب فيه ولا يقبل شيء احد غير اللي في مصدره استخدم هذا الكود معه Private Sub green_NotInList(NewData As String, Response As Integer) Response = Cancel End Sub لكن اذا تريد ان لا يكتب فيه حرف واحد فقط يجوز ان تختار استخدم هذا الكود معه Private Sub Combo3_KeyDown(KeyCode As Integer, Shift As Integer) KeyCode = 0 End Sub واليك المرفق بها كلا من طريقتين db1.mdb

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

السلام عليكم مؤخراً قمت بعمل مشروعٍ لمعالجة بيانات جهاز البصمة الإلكترونية Fingerprint Scanner ، ومن ضمن مراحل العمل احتساب الإجازات الساعية شهرياً وذلك بتحويلها إلى يوم إجازة، ونظراً لكون المشروع يتعلق بخصوصية المكان المنفذ لأجله مع التعقيدات القانونية المتعلقة بذلك، فقد اختصرت العمل لما يبين هذه الجزئية فقط، بعد أن وجدت من يسأل عنها؛ عسى أن يكون في هذا العمل ما ينفع، مع بعض الأكواد البسيطة التي قد يُحتاج إليها. أللهم صلِ على سيدنا محمد وعلى آله وصحبه وسلم. ميديا فاير- رابط المثال

السلام عليكم ورحمة الله وبركاته.. اليوم سأشرح لكم الدالة StrConv ولأي الامور تستخدم. الدالة حصرا تتعامل مع النصوص ( String ) ووضيفتها التحويل بين الاحرف الانجليزية ( كبير , صغير ) الدالة تأخذ 3 براميترات: البراميتر القيمة الوصف vbUpperCase 1 تحويل جميع الحروف الى حروف كبيرة vbLowerCase 2 تحويل جميع الحروف الى حروف صغيرة vbProperCase 3 تحويل الحرف الاول من كل كلمة الى كبير وباقي حروف الكلمة الى حروف صغيرة vbUnicode 64 تحويل النص الى سلسلة الـ UNICODE vbFromUnicode 128 تحويل النص من سلسلة UNICODE الى تنسيقات اخرى مثال: StrConv ("officena semo pa3x", 1) Result: "OFFICENA SEMO PA3X" StrConv ("OFFICENA SEMO PA3X", 2) Result: "officena semo pa3x" StrConv ("OFFICENA SEMO PA3X", 3) Result: "Officena Semo Pa3x" الاستخدام في الاستعلام يكون: الاستخدام في داخل محرر الـ VBA يكون: StrConv([CategoryName],3) تحياتي للجميع.. SEMO.Pa3x

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

اتفضل اليك هذا الكود Public Sub Terminate(Process As String, Optional PID As Long = 0) StrPID = IIf(Not PID = 0, " AND ProcessId=" & PID, "") Set Obj = GetObject("winmgmts:\\.\root\CIMV2") Set ColItems = Obj.ExecQuery("SELECT * FROM Win32_Process WHERE Name='" & Process & "'" & StrPID, , 48) For Each Obj In ColItems Obj.Terminate Next End Sub تقدر ان تغلق كل انواع البرامج بهذه الطريقة فقط عليك ان تكتب اسم البرامج عند تدعيه مثلا هنا نريد ان نغلق ملفات اكسل المفتوحة هكذا سنستدعيه عند الضغط على الزر Private Sub Command28_Click() Call Terminate("Excel.exe") End Sub

،عم استخدم هذا الكود Private Sub AGE_AfterUpdate() If Not IsNull(Me.Age.Value) Then Me.DOB.Value = DateSerial(Year(Me.dDate) - Me.Age.Value, 1, 1) End If End Sub 2020 (1).rar

السلام عليكم يمكن كتابته مباشرة بهذه الطريقة Me.bb.BackColor = RGB(&H0, &HB7, &HEF)

اتفضل القي نظرتا الى هذه الصورة اولا يجب ان تعرف كود اللون بصيغة RGB لكن ستسأل كيف ستعرفه اضغط بكليك على ثلاث نقاط الصغيرة لمربع Back Color سيفتح ذاك النافذة الاعلاه واختر اي لون سيظهر لكن كوده في الاسفل مثلا اللون 00B7EF# اللي حضرتك يريد شوف في الصورة كوده هو ( 0 و 183 و 239 ) وبعدين راح تستخدم ذاك الكود في النموذج هكذا Me.bb.BackColor = RGB(0,183,239)

مجهود ممتاز بارك الله فيك استاذ حاتم

شكرا جزيلا اخوي حاتم 🙂 جعفر

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

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

تفضل لك ما طلبت من أعمال الأستاذ مجدى يونس ...له منا كل المحبة والإحترام ,ورجاءا فى المرات القادمة عند رفع اى مشاركة فلابد من تدعيم هذه المشاركة بملف لوصف طلبك بدقة وكفاءة كل ما عليك فى هذا الملف عند تسجيل البيانات بالفورم فقط كتابة الإسم والرقم القومى وستظهر لك باقى البيانات تلقائياً فورم تاريخ الميلاد والسن والنوع من الرقم القومى2 .xlsm

السلام عليكم مشاركه مع اخوانى واساتذتى جزاهم الله خيرا اخى @سيد رجب ترددت كثيرا مثل استاذ @Shivan Rekany ولكن هذه محاوله منى على فهمى عندك استعلام تحديث لاضافه الاجماليات بالجدول عندك استعلام q للاجمالايات برضه وممكن تحذفه وتعمل استعلام مباشر من الجدول بعد تشغيل استعلام التحديث عندك النموذج اضغط على كل زر وانظر اليه ووافنا بالنتيجه والملاحظات الموظفين (1).accdb

اتفضل القي نظرتا الى الصورة تم تغير اسم الحقل التاريخ من Date الى dDate وايضا تم تغير حقل DOB من الرقمي الى تاريخ شوف قمنا بادخال dDate في 15/04/2015 اي نفترض في ذلك اليوم حضرتك دخلت البيانات وتاريخ الميلاد نفترض 22/12/1988 في حقل Age صار يساوي 27 لان 2015 - 1988 = 27 وفي مربع نصي Current Age صار یساوی ٣٢ لان سنة الحالية 2020 ناقص سنة الميلاد 1988 = 32 واليك المرفق 2020.rar

السلام عليكم و رحمة الله لا تستغرب من العنوان فبالفعل هذا سؤال وضع بأحد مواقع الاعمال الحرة Freelancers و هو كيف يمكن تشغيل ماكرو في وقت معين بدون استخدام Application.OnTime او حتى جدولة المهام Task Scheduler و قد وضع صاحب المشروع ميزانية 100 دولار لمن يجيبه. ليس لدي فكرة اذا تم الاجابة عن هذا السؤال ام لا فلمشروع مغلق الان ... الا انها فرصة لتوضيح كيف يمكن عمل ذلك. الفكرة باختصار هي عمل خدمة ويندوز تشغل الماكرو في وقت محدد. قد يسال احدهم سؤال و ما الفائدة من ذلك...هذا الامر متروك لمدى احتياجك لتشغيل الماكرو اوتوماتيكيا في وقت معين بدون تدخل المستخدم. فمثلا قد يكن من المهم ان تتم عملية الترحيل اوتوماتيكيا في نهاية يوم عمل. ملاحظة ===== استخدمت جهاز لديه ويندوز 8.1 و اوفس 2010 .. الجهاز غير مربوط باي شبكة محلية. خطوات الحل ======= 1 – عمل ملف اكسل (كتابة كود الماكرو) 2- انشاء ملف VBScript لتشغيل الماكرو 3 – كتابة ملف دفعي او باتش batch لفحص الوقت 4 – انشاء ملف تنصيب خدمة الويندوز Windows Service اسال الله التوفيق و السداد

السلام عليكم و رحمة الله تعالى وبركاته نعاني دائما من تصدير البيانات إلى الوورد للتعديل عليها أو لأي غرض آخر و خاصة الجداول أقدم لكم هذا المثال البسيط الذي يقوم بتصدير البيانات لملف وورد معد مسبقا و يقوم بملئها في أماكنها و كلما زاد سجل زاد له سطر في جدول الوورد و هذا هو المثال فيه نسختين 2003 و نسخة 2010 التصدير لملف وورد معد مسبقا.rar

دالة رأيتها في مواضيع الأستاذ جعفر وأعجبتني كثيرا ، وحسب تعليقه في الموضوع أنها من ضمن ملف العون في محرر الـ VBA ولكني لم أستطع العثور عليها. على كل تطوير الدالة في النقاط التالية: 1 - تسهيل إدخال التاريخين دون التفكير أيهما الأصغر أو أيهما الأكبر. 2 - إتاحة زيادة يوم على العمر أو المدة عند الرغبة (اختياري). 3 - إعطاء الناتج على شكل سنة وشهر ويوم منفصلين بقيم رقمية بالإضافة إلى ناتج الدالة النصي. Public Function YMD_Diff(inDate1 As Date, inDate2 As Date, _ Optional outY, Optional outM, Optional outD, _ Optional AddOneDay As Boolean = False) As String 'تطوير لدالة YMDDif Dim inDate3 As Date Dim iYear As Integer Dim iMonth As Integer Dim iDay As Integer Dim dInterim1 As Date If inDate2 < inDate1 Then inDate3 = inDate1 inDate1 = inDate2 inDate2 = inDate3 End If 'AddOneDay عند الرغبة في إضافة يوم في العمر أو المدة inDate1 = inDate1 - Abs(AddOneDay) iMonth = DateDiff("m", inDate1, inDate2) If Day(inDate1) > Day(inDate2) Then iMonth = iMonth - 1 End If dInterim1 = DateAdd("m", iMonth, inDate1) outD = DateDiff("d", dInterim1, inDate2) outM = iMonth Mod 12 outY = iMonth \ 12 YMD_Diff = outY & "y/" & outM & "m/" & outD & "d" End Function 'إجراء لاختبار الدالة Sub Test2() Dim Date1 As Date Dim Date2 As Date Dim Y As Integer, M As Byte, D As Byte Date1 = DateSerial(1970, 3, 1) Date2 = Date Debug.Print YMD_Diff(Date1, Date2) Debug.Print "--------------------" Debug.Print YMD_Diff(Date1, Date2, Y, M, D) Debug.Print Y, M, D Debug.Print "--------------------" Debug.Print YMD_Diff(Date1, Date2, Y, M, D, True) Debug.Print Y, M, D Debug.Print "--------------------" End Sub

تم معالجة الامر MY_search (2).xlsx

بارك الله فيك أخي @Khalf >>>>> جاري التجربة

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

هلا اخي شكرا على الدالة ملاحظة سريعة الدالة تعيد قيمة خطا كما في المثال التالي... فالقيمة المتوقعة 15 يوما بينما عادت 18 يوما ?YMD_Diff(DateSerial(1970, 3, 1),DateSerial(2020, 2, 15),,,,True) 49y/11m/18d عدلت في الكود الى التالي: inDate2 = inDate2 + Abs(AddOneDay) والنتيجة كالتالي: ?YMD_Diff(DateSerial(1970, 3, 1),DateSerial(2020, 2, 15),,,,True) 49y/11m/15d ملاحظة : لم اختبر الدالة بشكل مكثف بالتوفيق

شكرا على التوضيح ورجاء اذا كان الموضوع مخالف لقوانين المنتدى فرجاء من إدارة المنتدي العظيم نقل الموضوع الى القسم المناسب وشكرا استاذ احمد

وعليكم السلام 🙂 اخي ربيع ، لقد حصلت على البرنامج من منتدى الاكسل : فهل هناك شيء آخر تريده من منتدى الاكسس ؟ جعفر

جزاك الله خيرا اخى @hatem fayz تم انشاء قسم جديد بالموقع جزاهم الله خيرا اخوتنا واساتذتنا الافاضل على كل ما يقدمونه فى سبيل التعلم والصالح والهدف منه اذا لم يكن هناك تفاعل مع المواضيع المنشوره وبالاضافه الى ان قواعد البيانات المرفقه مغلقه المصدر فلا يمكن الاستفاده منها تعليميا يمكنك نشر مواضيعك عالرابط التالى https://www.officena.net/ib/forum/212-قنوات-تعليمية-شخصية-و-دورات-تدريبية-مجانية-و-مدفوعة/ تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

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

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

السلام عليكم اخي العزيز ماهو تاريخ انتهاء العطله ؟؟؟ لم توضح ذلك المهم لو افترضنا ان اليوم هو تاريخ انتهاء العطله وان الحقل اسمه vacation عند التحديث سيظهر الحقل بوميض متقطع باللون الاحمر تحياتي تنبيه.rar

السلام عليكم تفضل اخي العزيز اتمنى ان يكون المطلوب تحياتي New Microsoft Access Database.rar

وعليكم السلام اخى @ازهر عبد العزيز اتفضل ان شاء الله يكون ما تريد بالتوفيق ان شاء الله Root15.accdb

اتفضل استاذ اليك هذا الاستعلام SELECT الموظفين.[رقم الموظف], الموظفين.[اسم الموظف], الموظفين.[التشجيعية الاولي], الموظفين.[التشجيعية الثانية], الموظفين.[التشجيعية الثالثة], الموظفين.[التشجيعية الرابعة], الموظفين.[التشجيعية الخامسة], IIf(IsDate([التشجيعية الخامسة]),5,IIf(IsDate([التشجيعية الرابعة]),4,IIf(IsDate([التشجيعية الثالثة]),3,IIf(IsDate([التشجيعية الثانية]),2,IIf(IsDate([التشجيعية الاولي]),1,0))))) AS ededmerat FROM الموظفين; واليك كود التحديث للجدول Private Sub BtnUpdate_Click() DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE الموظفين INNER JOIN q1 ON الموظفين.[رقم الموظف] = q1.[رقم الموظف] SET الموظفين.[عدد المرات التشجيعية] = [q1]![ededmerat];" DoCmd.SetWarnings True MsgBox "تم تحديث" End Sub للعلم تقدر ان تحذف حقل الجدول لان عندنا الحقل المطلوب في الاستعلام اذا تريد ان يكون موجودة يجب ان تعمل تحديثات له واذا تحذفه تقدر ان تراه في الاستعلام وليس فيه مشكلة الموظفين.rar

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

السلام عليكم اخى @صايل عزام جرب الحل الذى عالرابط التالى ان شاء الله يحل لك مشكلتك https://www.access-programmers.co.uk/forums/threads/adding-a-help-chm-file-to-access-application.93267/post-418968 تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

هل تبحث عن استعلام كهذا

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

السلام عليكم و رحمة الله وبركاته تم تنفيذ الكود المطلوب Sub az() ' Dim FS As Worksheet, TS As Worksheet Dim FC, FR, TR, ER, Q1, Q2, Q3, SH Set FS = Sheets("أمور الشغل") ER = FS.UsedRange.Rows.Count For FR = 2 To ER Q1 = FS.Cells(FR, 4).Text ' المعدة Q2 = FS.Cells(FR, 1).Value ' رقم امر التشغيل For SH = 1 To ActiveWorkbook.Sheets.Count If Sheets(SH).Name = Q1 Then Set TS = Sheets(SH) ' ورقة السيارة Q3 = Application.CountIf(TS.Range("A:A"), Q2) If Q3 > 0 Then GoTo 3 TR = Application.CountA(TS.Range("A:A")) 4 If TS.Cells(TR, 1) <> "" Then TR = TR + 1 GoTo 4 End If For FC = 1 To 12 TS.Cells(TR, FC) = FS.Cells(FR, FC) Next FC End If Next SH 3 Next FR End Sub و لكن نصيحة الاسهل هو استخدام الجداول المحورية او استخدام التصفية التلقائية او استخدام التصفية المتقدمة بالكود و هذه الحلول افضل من استخدام الكود الموضح اعلاه تحافظ على حجم الملف صغير و كل تعديل في بيانات الورقة الاولى يظهر فورا ولك حرية الاختيار شيت امور الشغل.xls

@فايز.. تفضل Dim strSearch As String static xn Dim rs As Object Set rs = Me.RecordsetClone If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then MsgBox "رجاء ادخل اسم للبحث عنه", vbOKOnly, "خطأ في البحث" Me![txtSearch].SetFocus Exit Sub End If strSearch = Me![txtSearch] With rs .FindNext "[EmpName] like '*" & strSearch & "*'" If Not .EmpName Like "*" & strSearch & "*" Then MsgBox "لا يوجد سجل بهذا الإسم : " & strSearch, , "غير موجود" Me.txtSearch = "" Me![txtSearch].SetFocus ElseIf .NoMatch Then MsgBox "آخر سجل في البحث عن : " & strSearch, , "آخر سجل" Me.cmdSearch.Caption = "بحث" Me.txtSearch = "" Me![txtSearch].SetFocus Me.cmdSearch.ForeColor = RGB(0, 0, 255) DoCmd.GoToRecord , , acFirst Else xn=xn+1 Me.Bookmark = .Bookmark if xn=1 then MsgBox "تم ايجاد اسم : " & strSearch, , "مبروك" Me.cmdSearch.Caption = "اكمال البحث" Me.cmdSearch.ForeColor = RGB(255, 0, 0) End If End With rs.Close Set rs = Nothing بالتوفيق

السلام علبكم تفصل اخي الكريم بالتوفيق test-Copy2.rar

بعد اذن استادي ابراهيم الحداد هذا المرفق Private Sub Workbook_SheetActivate(ByVal Sh As Object) Dim i i = 1 For Each Sh In Sheets 'يمكنك تغيير اسماء الشيتات التي لا تريد ترقيمها If Sh.Name <> "Sheet1" And Sh.Name <> "Sheet2" And Sh.Name <> "Sheet3" And Sh.Name <> "Sheet4" Then Sh.Range("A1").Value = i i = i + 1 End If Next End Sub test.xlsm

ههههههههه من قال الله أعلم علمه الله ما لا يعلم تذكر ذكر اسم الله أخي ابوآمنة و إن شاء الله سوف أشرح الطريقة أولا لإرسال أي بيانات لمكان معين في صفحة الوورد يجب إضافة إشارة مرجعية لهذا المكان لنستطيع التعامل معها. و هذه صورة إنشاء إشارة مرجعية في الوورد: و هذا كود إرسال البيانات إلى مكان الإشارة المرجعية في ملف الوورد الموجود بجانب البرنامج: Dim wApp As Word.Application 'Object Dim wDoc As Word.Document 'Object Set wApp = CreateObject("Word.Application") Set wDoc = wApp.Documents.Open(CurrentProject.Path & "\recap1.dot") wApp.Visible = True 'False wDoc.Bookmarks("fname5").Range.Text = "Officna" wApp.ActiveDocument.SaveAs (CurrentProject.Path & "\1988_Doc.Docx") wApp.Quit Set wDoc = Nothing Set wApp = Nothing

وعليكم السلام تفضل . هذه الوحدة النمطية الموجودة في Help الاكسس ، مع بعض التعديل Option Compare Database Option Explicit Public Function YMDDif(sDate1, sDate2) 'sdate1 earliest date sdate2 later Dim iYear As Integer Dim iMonth As Integer Dim iDay As Integer Dim dInterim1 As Date Dim D As Integer Dim M As Integer Dim Y As Integer iMonth = DateDiff("m", sDate1, sDate2) If Day(sDate1) > Day(sDate2) Then iMonth = iMonth - 1 End If dInterim1 = DateAdd("m", iMonth, sDate1) iDay = DateDiff("d", dInterim1, sDate2) D = iDay M = iMonth Mod 12 Y = iMonth \ 12 YMDDif = CStr(Y) & " س/" & CStr(M) & " ش/" & CStr(D) & " ي" End Function Public Function YMDDif2(sDate1, sDate2) 'sdate1 earliest date sdate2 later Dim iYear As Integer Dim iMonth As Integer Dim iDay As Integer Dim dInterim1 As Date Dim D As Integer Dim M As Integer Dim Y As Integer iMonth = DateDiff("m", sDate1, sDate2) If Day(sDate1) > Day(sDate2) Then iMonth = iMonth - 1 End If dInterim1 = DateAdd("m", iMonth, sDate1) iDay = DateDiff("d", dInterim1, sDate2) D = iDay M = iMonth Mod 12 Y = iMonth \ 12 YMDDif2 = CStr(M) & " ش" End Function . اما التقرير ، فيأخذ بياناته من هذا الحدث ويعطينا الفرق باليوم ، والشهر ، والسنة (احذف السطر اللي ما تريده) Private Sub PageFooterSection_Format(Cancel As Integer, FormatCount As Integer) Me.txtcount = DLookup("[التاريخ]", "[Query1]", "[Query1]![CountOfالتسلسل]=" & [نص128]) Me.txtcounupgrade = DLookup("[التاريخ]", "[Query1]", "[Query1]![CountOfالتسلسل]=" & [نص130]) Me.Months = YMDDif(Me.txtcount, Me.txtcounupgrade) & vbCrLf & _ "او" & vbCrLf & _ YMDDif2(Me.txtcount, Me.txtcounupgrade) End Sub جعفر 794.حساب عدد الاشهر بين تاريخين.accdb.zip

لا يمكن بطريقة افتراضية يمكن عن طريق الكود هذا الكود يقوم بالارسال مباشرة اذا كان المرسل هو admin@officena.net و بعطيك رسالة تحذير اذا كان الارسال من حساب اخر ، و يمكنك الالغاء Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) If Not LCase(Item.SendUsingAccount) = "admin@officena.net" Then Prompt$ = "You are sending this From " & Item.SendUsingAccount & ". Are you sure you want to send the Mail?" If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then Cancel = True End If End If End Sub و يجب اضافة الكود فى Thisoutlooksession اضغط ALT+F11 ثم انقرنقر مزدوج علي Thisoutlooksession و الصق الكود ، و قم بتغيير البريد المرتبط يالحساب

1 – عمل ملف اكسل (كتابة كود الماكرو) 2- انشاء ملف VBScript لتشغيل الماكرو 3 – كتابة ملف دفعي او باتش batch لفحص الوقت 4 – انشاء ملف تنصيب خدمة الويندوز Windows Service ____________________________________________ الخطوة الثانية هى من اهم الخطوات و ذلك لانها المسؤلة عن تشغيل الماكرو. ملاحظة: --------- الفجول بايسك اسكربت VBScript ليست VBA و ان كانت تتشابة معها في كتابة الكود. ال VBScript بأختصار هى لغة اسكربت تحمل ملفاتها الامتداد vbs و يمكن تشغيلها بالنقر المزدوج. بالنسبة للخطوة الثانية سنفترض التالي: 1 - لا يتم تشغيل الماكرو من قبل الاسكربت الا اذا كان ملف الاكسل مغلقا (اي ليس قيد التشغيل) Call RunMacroOffline(CurrentFolder & ExcelFile) 2- في حالة ان ملف الاكسل قيد التشغيل، يتم وضع الاسكربت في وضع الانتظار و مراقبة الملف الى ان يتم اغلاقه. While FileExistsOrInUse(CurrentFolder & ExcelFile) <> NO_ERRORS WScript.Sleep 5000 WEnd 3 - يمكن لاكثر من نسخة من ملف الاسكربت ان تعمل في نفس الوقت. 4- لا يتقيد ملف الاسكربت بوقت معين لتنفيذ الماكرو (الخطوة رقم ثلاثة هى المسؤلة عن تحديد وقت التنفيذ) ملاحظة ===== بالنسبة لوجود اكثر من نسخة من الاسكربت قيد التشغيل سيخلق لنا مشكلة مشابهة لصورة ادناه: مصدر الصورة تسمى بحالة الاستعصاء او Deadlock و هى و جود اكثر من نسحة من الاسكربت تحاول في نفس الوقت الوصول لملف الاكسل و كل نسخة تنتظر الاخرى لتحرر الملف. و لهذا فان الكود: WScript.Sleep 5000 سيساعد على حل هذه المشكلة وذلك بجعل كل نسخة من الاسكربت الانتظار لمدة خمس ثواني قبل محاول الوصول لملف الاكسل في كل مرة. خطوات أنشاء ملف الاسكربت افتح المذكرة notepad و اكتب الاسكربت و احفظ الملف بامتداد vbs (اسم الملف هنا سكون RunSummaryMacro.vbs ) واليكم كود الاسكربت Option Explicit '-------------------------------------------------------- Const NO_ERRORS = 0 Const FILE_NOT_FOUND = 53 ''هنا نعرف ملف الاكسل و اسم الماكرو Const ExcelFile="Summary2015.xlsm" Const ExcelMacro="Summary" ''نعرف متغييرين الاول يشير لبرنامج الاكسل و الاخر لملف الاكسر Dim ExcelApp Dim Workbook '' متغير يحتفض بمسار المجلد الذي يحتوي على ملف الاسكربت و ملف الاكسل Dim CurrentFolder '-------------------------------------------------------- '/ بداية البرنامج ''احصل على مسار المجلد الحالي للاسكربت CurrentFolder = Left(Wscript.ScriptFullName,(Len(Wscript.ScriptFullName))-(Len(Wscript.ScriptName))) '' اذا كان ملف الاكسل غير موجود الغي تنفيد البرنامج If FileExistsOrInUse(CurrentFolder & ExcelFile) = FILE_NOT_FOUND Then Call Wscript.Quit(FILE_NOT_FOUND) ''في حالة ان ملف الاكسل قيد التشغيل .. انتظر 5 ثواني و عد افحص حالة الملف الى ان يتم اغلاق الملف While FileExistsOrInUse(CurrentFolder & ExcelFile) <> NO_ERRORS WScript.Sleep 5000 WEnd '' عندما يكن ملف الاكسل مغلقا شغل الماكرو Call RunMacroOffline(CurrentFolder & ExcelFile) '-------------------------------------------------------- '/ دالة فحص ملف الاكسل -- فحص وجود الملف على الجهاز و كذلك فحص اذا كان الملف قيد التشغيل Function FileExistsOrInUse(FileName) Const FOR_APPENDING = 8 Const DO_NOT_OVERWRITE=False Dim FileSystem Dim FileRef Dim Result Set FileSystem = CreateObject("Scripting.FileSystemObject") On Error Resume Next Call Err.Clear Set FileRef = FileSystem.OpenTextFile(FileName, FOR_APPENDING, DO_NOT_OVERWRITE) if Err.Number = NO_ERRORS then Result = NO_ERRORS On Error Goto 0 Call FileRef.Close Else Result = Err.Number End If FileExistsOrInUse = Result End Function '-------------------------------------------------------- '/اجراء تشغيل الماكرو Sub RunMacroOffline(FileName) Set ExcelApp = CreateObject("Excel.Application") ''افتح ملف الاكسل Set Workbook = ExcelApp.Workbooks.Open(FileName) ExcelApp.Visible = FALSE ExcelApp.DisplayAlerts = FALSE '' شغل الماكرو Call ExcelApp.Run(ExcelMacro) '' احفظ التغييرات Call ExcelApp.ActiveWorkbook.Save '' اغلق ملف الاكسل Call ExcelApp.ActiveWorkbook.Close ExcelApp.DisplayAlerts = True Call ExcelApp.Quit Set Workbook = Nothing Set ExcelApp = Nothing End Sub مخرجات الخطوة الثانية ================= اسم ملف الاسكربت : RunSummaryMacro.vbs بالتوفيق 2.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