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

وعليكم السلام اتفضل ان شاء الله يكون ما تريد If DateSerial(Year(Date), Month(Date), 10) = Date Then MsgBox "yes" بالتوفيق

تنور مصر ولو ابوجودى معزمكش اعزمك انا 🇪🇬

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

مشاركة مع اساتذة الأكارم جرب هذا المرفق ووافنا بالنتائج SearchInSubandMain mod..accdb

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

اخي الكريم munear جرب المرفق ..ادخل المودييل اولا ثم تاريخ الاستلام تثبيت معادلة.xlsm

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

تفضل ...الملف ...اتمنا من الله ان يكون هو المطلوب !!! تثبيت معادلة (1).xlsm

تفضل الملف تثبيت معادلة.xlsm الكود المستخدم Sub tast() Application.ScreenUpdating = False Range("E10").Select ActiveCell.FormulaR1C1 = _ "=IF(RC[6]>1,VLOOKUP(RC[3],أسعار!C[-3]:C[-2],2,),"""")" Range("E10").Select Selection.AutoFill Destination:=Range("E10:E405") Range("E10:E405").Select Selection.Copy Range("E10").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveSheet.Paste Application.CutCopyMode = False Range("E10").Select Application.ScreenUpdating = True End Sub هل هذا ما تريد ؟

جرب المرفق تثبيت معادلة.xlsm

السلام عليكم تفضل يجب عليك تغير امتداد الملف ليصبح هكذا xlsm. الملف test.xlsm

Option Explicit Sub stabelerFR() Dim lr Dim r lr = Cells(Rows.Count, "e").End(3).Row r = "=VLOOKUP(H10,أسعار!B:C,2,)" Range("e10:e" & lr).Formula = r Range("e10:e" & lr).Value = Range("e10:e" & lr).Value End Sub استعمل هذا الشيء سيفي بالغرض ..ولكن لازم تحفظ الملف بامتداد xlsm

You can change the date in the code Sub Test() Const sReport As String = "Report" Dim ws As Worksheet, myDate As Date, lr As Long, r As Long, c As Long, k As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(Rows.Count, "C").End(xlUp).Row myDate = CLng(DateSerial(2017, 1, 1)) ReDim a(1 To (lr - 2) * 7, 1 To 6) For r = 3 To lr For c = 9 To 27 Step 3 If ws.Cells(r, c + 1).Value2 >= myDate Then k = k + 1 a(k, 1) = ws.Cells(r, 3).Value a(k, 2) = ws.Cells(r, 6).Value a(k, 3) = ws.Cells(r, 7).Value a(k, 4) = ws.Cells(r, c).Value a(k, 5) = ws.Cells(r, c + 1).Value a(k, 6) = ws.Cells(r, c + 2).Value End If Next c Next r If k > 0 Then On Error Resume Next Application.DisplayAlerts = False Worksheets(sReport).Delete Application.DisplayAlerts = True On Error GoTo 0 Sheets.Add(After:=Sheets(Sheets.Count)).Name = sReport With Worksheets(sReport) .DisplayRightToLeft = True .Range("A1").Resize(, 6).Value = Array("Father Name", "Mother Name", "Place", "Child", "Birth Date", "ID") .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a .Columns.AutoFit End With End If Application.ScreenUpdating = True MsgBox "Done...", 64, "LionHeart" End Sub

بعد إذن جميع المشاركين إذا جربنا وضع الرقم 10 كدرجة رئيسية والرقم 90 و 300 كدرجات ثانوية سنتأكد من صحة المعادلتين في هذا الملف المرفق خالص الدعوات بالتوفيق الزاوية الأقرب.xlsx

صارلي زمان مش واكل بطة ع الرز اذا بشمهنس محمد (ابو جودي ) بيعزمني ... حروح على طول لمصر الحبيبة

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

السلام عليكم, في سنة 2017 قمت بكتابة كلاس بسيط لحماية برنامجي ولضمان برنامجي لا يعمل في غير كومبيوترات في حاله بيعه. مميزات الكلاس: 1- قفل قاعدة البيانات على ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) 2- (استحاله) فك النماذج والتقارير في حال عدم تجاوزك لنموذج ( تسجيل الدخول ) ببساطة ستقول يمكنني العثور على باسورد القاعدة داخل الجدول ( الطريقة المعتادة لدينا جميعا في انشاء نموذج تسجيل دخول ). قبل كل شي ليكن لدينا مثلا جدول اسمة ( tbl_Login ) و نموذج اسمه ( frm_Login ) الجدول لتخزين اسم المستخدم وكلمة المرور والنموذج لعمل تسجيل الدخول عند ذهابنا للجدول ( tbl_Login ) ، سوف نحصل على باسورد مشفر من الجدول لو كان الباسورد مثلا ( 313 ) فإنك ستحصل على ( 701D6068 ) 2- عندما نقوم بتسجيل الدخول في النموذج سيقوم البرنامج بأخذ كلمة السر المدخلة ويقوم بتشفيرها ثم يقوم بمطابقتها مع الباسورد الموجود في الجدول اذا كان الباسورد المُدخل يطابق الجدول سيكتب قيمة معينة runtime ويقوم بازالة جميع القيود من النماذج والتقارير. اولا: كلاس الحماية Option Compare Database '----------------------------------------------------- ' Protection Module Coded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- Public SEMO As String Function SEMO_GET() SEMO = SEMO SEMO_GET = SEMO End Function Function PR() As Boolean PR = False 'False=Disabled , True=Enabled End Function Function HWND_ID() HWND_ID = "3C3F4825" 'Your HWID End Function Function HWND_MSG() HWND_MSG = "...ليست لديك صلاحيات كافية لإستخدام هذا الاجراء" End Function Function KEY_ENDE() KEY_ENDE = "PA$X" End Function Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function Function HWND_PROTECTION() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_PROTECTION = disk.volumeserialnumber Exit For End If Next If HWND_ID = HWND_PROTECTION Then HWND_PROTECTION = "True" Else HWND_PROTECTION = "False" End If End Function 'Code contained within module named mdlforencryptionanddecryption Public Function XORDecryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To (Len(DataIn) / 2) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Val("&H" & (Mid(DataIn, (2 * arkdata1) - 1, 2))) 'The second value comes from the code key intXOrValue2 = Asc(Mid(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2) Next arkdata1 XORDecryption = strDataOut End Function Public Function XOREncryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim temp As Integer Dim tempstring As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To Len(DataIn) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Asc(Mid$(DataIn, arkdata1, 1)) 'The second value comes from the code key intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) temp = (intXOrValue1 Xor intXOrValue2) tempstring = Hex(temp) If Len(tempstring) = 1 Then tempstring = "0" & tempstring strDataOut = strDataOut + tempstring Next arkdata1 XOREncryption = strDataOut End Function الاستخدام لكل النماذج والتقارير اكتب في حدث Form_Load Option Compare Database Private Sub Form_Load() On Error Resume Next If HWND_PROTECTION = "False" Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim X As Control Set X = Me.Controls.Item(i) X.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If If Protection.SEMO_GET = "SEMO" = False Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim XS As Control Set XS = Me.Controls.Item(i) XS.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If End Sub الان عندما تريد اعطاء القاعدة لشخص ما قم باعطاءه اولا ملف الـ VBS هذا '----------------------------------------------------- ' ReCoded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- ' Get clipboard text Set objHTML = CreateObject("htmlfile") Set Ws = CreateObject("WScript.Shell") Clipboardtext = objHTML.ParentWindow.ClipboardData.GetData("text") sText = HWND_GET 'Set Clipboard Ws.Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(sText, "\", "\\"), "'", "\'") & "');close();""", 0, True MsgBox "Copied!" Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function وظيفة هذا الملف يقوم باستخراج ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) ثم ينسخه بعدما يشغله سيقوم العميل باعطاءك هذا الرقم لكي تقوم انت بدورك بوضعه داخل الكلاس في المنطقة Function HWND_ID() HWND_ID = "Your HWID" End Function استبدل كلمة ( Your HWID ) بالرقم الذي سيعطيه لك العميل. ثم بعد ذلك قم بحفظ القاعدة بصيغة ( ACCDE ) واتحدا اي شخص يفتحها مرة اخرى: لكي تفتح النماذج والتقارير عليك بتخطي نموذج تسجيل الدخول ارفقت لكم قاعدة محمية وقاعدة بدون حماية مع ملف الـ VBS الذي يستخرج ارقام قطع الجهاز ويقوم بنسخها،، اتمنى لكم الفائدة جميعاً اهداء الموضوع الى مُعلمي الرائع @jjafferr حسنين Login_SEMO_Pa3x.rar

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

اين هذه الاحداث فى فورم ايه ؟ يتم تغييرها بالفورم الذى تتبع له اى بالفورم ثم بالتوفيق

السلام عليكم ورحمة الله لدي مثال في المرفقات وهو نمودج رئيسي به ثلاث حقول ملحق به نمودج فرعي به تلات حقول ايضا . المطلوب عند الضغط على امر " سجل جديد " و بعد تعبئة التلات حقول الاولى في النمودج الرئيسي ينتقل الموشر الى النمود ج الفرعي واجبار الكتابة في الحقل الاول بشرط عدم مغادرته للحقل الا بعد الكتابة به تم الانتقال تلقائيا الى الحقل التاني وتنفيد نفس الاجراء السابق حتى ينتقل للحقل التالت ارجو ان اكون قد احسنت الشرح ولكم جزيل الشكر اخواني والسلام عليكم وكل سنه وانتم طيبين SearchInSubandMain3 (1)1.accdb

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

Private Sub Workbook_Open() Dim ws As Worksheet Sheet"الرئيسية".Visible = xlSheetVisible Sheet"الرئيسية".Select Range("a1").Select For Each ws In ThisWorkbook.Worksheets If Not ws.Name = "الرئيسية" Then ws.Visible = xlSheetVeryHidden Next ws Application.ScreenUpdating = true End Sub

قيمة رقمية.accdb

ربنا يبارك فيك يا غالى

السلام عليكم ,, الاخوة الاعزاء كل عام وانتم بخير . كما نعلم ان الايقونات جزء لا يتجزء من الواجهات الحديثة الجذابة التى تلفت الانظار ومن هذا المنطلق واستكمالاً للموضوع السابق الذى تجده هنا : موضوعنا اليوم عن كيف تصنع ايقوناتك خصيصاً لتتناسب مع تصميم برنامجك بطريقة بسيطة , انظر النتيجة : هناك اختلاف بسيط فى الالوان لأنى عملتهم على عجالة 😅 . فى هذا الموضوع سنستخدم أداة بها آلاف الايقونات القابلة للتخصيص من حيث اللون والحجم اسم الاداة Pichon يمكنك تحميلها من هذا الرابط المباشر : من هنا بعد التحميل والتثبيت ستجد هذه الايقونة افتح البرنامج وابحث عن الايقونة التى تريدها بوصفها مثلاً Facebook , Twitter وهكذا , ستجد ايقونات غير قابلة للتخصيص ولكن يمكن التحكم فى حجمها وستجد ايقونات يمكن تغيير ألوانها ستجدها تحت تصنيف Material وبها تصنيفات فرعية مثلا Outlined للايقونات المفرغة و Filled للايقونات الممتلئة , ابحث ن الايقونة وقم بتلوينها مثل المثال : اضغط كليك يمين ثم Save As واحفظ الايقونة شفافة يمكن وضعها على اى تصميم طيب انا محتاج لون دقيق جدا حتى يكون هناك تناسق تام فى الألوان والتصميم فى هذه الحالة يمكنك سحب اللون بالاداة الموجودة فى الموضوع السابق اتبع المثال لسحب لون الاكسس المحبوب على سبيل المثال : لا حدود لما يمكنك ابداعه , بتطبيق ما تعلمته من الدرسين يمكنك عمل Themes يقوم المستخدم بنحديد المفضل لديه ويتم تغيير الوان الازرار والايقونات وشريط العنوان ليصبح برنامجك شبيهاً ببرامج .Net 😅 المطلوب دعوة بظهر الغيب لصلاح الحال وتيسير الامور , دمتم بخير مرفق المثال الاول لتغيير الوان الحروف والايقونات المستخدمة Icon Color Amr.rar

تم وضعها بالخطة 😅 , من باب الفضول ماهو نوع الاسكانر المستخدم ؟

شاهد المرفق Tq.xlsm

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

السلام عليكم بعد اذن استاذنا حسين مامون ..جرب هذا الكود Sub tast() Application.ScreenUpdating = False Range("E10:E405").Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(R10C8:R[395]C[3],أسعار!C[-3]:C[-2],2,),"""")" Range("E10").Select Selection.AutoFill Destination:=Range("E10:E5000") Range("E10:E5000").Select Selection.Copy Range("E10").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveSheet.Paste Application.CutCopyMode = False Range("E10").Select Application.ScreenUpdating = True End Sub الملف تثبيت معادلة.xlsm

اخي اعمل مثال لما تتوقعة للنيجة الفرز ربما يستطيع احد الاخوة المساعدة

انت عامل كل شي فقط محتاج... Me.Requery

السلام عليكم مشاركه مع اخى واستاذى موسى جزاه الله خيرا اخى @SAROOK اطلع عالتعديلات التى قمت بها ولى عوده مره اخرى بالمساء ان شاء الله بعد ان تقوم بالتجربه والرد هل ده المطلوب ام لا بالتوفيق Search_.accdb

بالنأكيد لا يمكن المساعدة هكضا ونبهنا كثير جداً على هذا الأمر ... فلابد من رفع ملف مدعوم بشرح كافى عن المطلوب , فلا يمكن العمل على التخمين وتجنباً لإهدار وقت الأساتذة !!!

الحمد لله الذي بنعمته تتم الصالحات جزاكم الله خيراً على هذه الكلمات الطيبة

بعد إذن الأساتذة الأفضل إثرائا للموضوع يمكن ذلك من خلال التالي =IF(J4>0;HYPERLINK(CONCATENATE("PDF/";J4;".pdf");"الاطلاع على العقد");"")

شاهد المرفق Tq.xlsm

السلام عليكم ..التعديل هنا Range("B45:H191").Copy تفضل الملف vehicles Cost.xlsm

Delete columns from column A to column G Select column A From Data tab select Text to Columns Select Delimited option and click Next button Check Space option and click Next button In Destination field select $B$1 cell And finally click Finish

اولا- اتقدم بخالص التهاني لخبيرنا واستاذنا @احمد الفلاحجي ابو بسملة جزاه الله خيرا علي الترقية ثانيا- جزاك الله خيرا أستاذنا @Amr Ashraf مبادرة طيبة وعرض مغري حقيقة - ولكني من انصار المثل الصيني - علمني الصيد ولا تعطني سمكة - فيا حبذا لو انتهز حماسكم بتلك المبادرة واطلب منكم انشاء موضوعات ولو صغيرة تشرحون بها ما تعلمتم من اصول ومبادئ تلك اللغة علي شكل مشروعات مصغرة او اي صورة تروق لك حسبما تيسر من الوقت والجهد وجعله الله بموازين حسناتكم - اهو منها مذاكرة ومنها افادة - حتي لو كل يوم درس مش هنتقل عليك - جزاكم الله خيرا واحسن الله اليكم

للعلم هذا اختيار موقف وللعلم ان اردت النقر على هذا الباب ابتعد عن VB.Net هى ليست حديثه بدأت اللغة كما عرفت اولا بـالـ C ثم الـ C++ ثم الـ C# https://ar.wikipedia.org/wiki/سي%2B%2B ثم تم التطوير بعد ذلك https://ar.wikipedia.org/wiki/سي_شارب وذلك لتنافس Java ولغات البرمجة الاخرى

اختيار جيد بس شوفت انت قولت ايه السينتاكس مختلف لكن الاساس كله واحد فالبنسبالى كله واحد لان الاساس البرمجى واحد والاختلاف فالسينتاكس بايثون وجافا تستطيع بهم ايضا صنع البرامج المكتبيه التى تريدها بالنسبالى لا اشغل بالى بالمجتمع العالمى بل اشغل بالى بما يقدمه لى البرنامج الذى اتعلمه وماذا استفيد منه وما استطيع القيام به فابحث عن ذلك وعن جميع المعلومات حول هذه البرامج وهل يلبون طموحاتى ام لا فاللى يلبى طموحاتى اضع كل تركيزى به لاتعلم واتقنه وطالما انت فى الدوت نت حاول تدخل فى wbf c# لكم منى كل الامانى الطيبه وربنا يوفقك ويزيدك من فضله

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

اخترت C# لأن الSyntax مختلف تماماً عن VBA فأحسست فى البداية بالتحدى لتعلم شئ جديد , بالنسبة للVB.Net قريب جدا من VBA لم اشعر بالحماس للتعمق فيه . سؤال جيد , كما تعلم ان لكل فرع منهم المجال الذى يتألق فيه وبما أنى مهتم كثيراً بDesktop Applications فاخترت الدوت نت وهذا أولاً , ثانياً المجتمع العالمى ومدى انتشار اللغة البرمجية عامل مهم فى اختيارى وكان ايضاً سبب قوى انى اخترت الC# فلها قاعدة شعبية عالية جداً وهى لغة حديثة ومازالت تتطور مع الوقت كما انه يمكنك تصميم تطبيقات الاندرويد و مواقع الويب بالاضافة الى برامج الويندوز والماك عن طريقها . بالنسبة للبايثون غير منتشر بالدرجة الكافية حتى الآن ومجال تألقه هو الذكاء الصناعى , بالنسبة لمدى القوة فهى لغة قوية جداً بالفعل ولكن كما قلت شعبية اللغة وكثرة مستخدميها يفيد المبتدئين امثالى من كافة الجهات . بالنسبة للجافا احسها لغة متكاملة تنفع فى أى مكان وتصلح لأى شئ ولكن فضلت تركها بعد تعلم الدوت نت اذا أحيانا الله , وامكانيات الجهاز الحالى لا اعتقد انها ستساعد فى البرمجة بالجافا . سؤالك كان جيد واعتقد انه هيفيد الكثير , تشرفت بمرورك

بعد ادن استادي Ali Mohamed Ali واتراء للموضوع هذه طريق اخرئ 1- حمل الملف وفك الضغط 2 بعد فتح ملف اكسيل حدد اسم ملف بدف واضغط الزر ملاحظة: يجب ان تخزن الملفات ب د ف في نفس الفولدر"oqoud" مع ملف اكسيل و اسمارها ايضا في الصفحة كما في المرفق oqoud.rar

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

وانت في صحة وسلامة طيب انشئ وحدة نمطية وضع هذا فيه ::::::: Private Const TIMEOUT = 99 Public Sub Restart() Dim scriptpath As String scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat" If Dir(scriptpath, vbNormal) <> "" Then If DateAdd("s", TIMEOUT * 1, FileDateTime(scriptpath)) < Date Then Kill scriptpath Else Application.Quit acQuitSaveAll Exit Sub End If End If Dim s As String s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST ""%~f1.%3"" GOTO CHECKLOCKFILE" & vbCrLf s = s & "start "" "" ""%~f1.%2""" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile Dim dbname As String, ext As String, lockext As String Dim idx As Integer For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) If Left(ext, 2) = "ac" Then lockext = "laccdb" Else lockext = "ldb" End If s = """" & scriptpath & """ """ & dbname & """ " & ext & " " & lockext Shell s, vbHide Application.Quit acQuitSaveAll End Sub تحت حدث الزر ضع هذا :::::::: Utilities.Restart

السلام عليكم .. الاخوة الأعزاء موضوعنا اليوم عن القائمة المختصرة مجددا ولكن بتطبيقات اكثر تقدما مثل جعلها متعددة المستويات وتتغير ديناميكياً طبقاً لشروط تضعها بيدك .. نبدأ بسم الله بداية يجب ان يكون هذا الموضوع مرجعك فى اى موضوع يتعلق بالقائمة المختصرة .. هذا الموضوع بقلم أستاذنا المبدع @jjafferr ويمكنك ايضا استعراض هذا الموضوع لتطبيقات مختلفة على القائمة المختصرة نبدأ الموضوع الجديد : بداية لن استفيض فى شرح الكيفية لأن بعد استعراضك للموضوعين السابقين سنفترض انك فهمت كافة التفاصيل المتعلقة بالقائمة المختصرة . التطبيق الاول : كيف يتم ربط القائمة المختصرة بالكائنات Objects الموجودة بقاعدتك ( نماذج - تقارير- استعلامات - ماكروهات ) مثال : الطريقة هنا تعتمد على مجموعة استعلامات تقوم باستخلاص انواع الكائنات من جداول النظام وتقوم الموديول الخاص بالقائمة المختصرة بعرض هذه الكائنات فى القائمة . المثال الخاص بها مرفق بإسم Amr Multi Level Menu-All Objects . عيوب الطريقة : انها ستعرض لك الكثير من الكائنات التى لن تحتاجها فى القاعدة مثل النماذج الفرعية و ماكروهات الالحاق والتحديث والحذف Append,Update,Delete , مما يأخذنا للتطبيق الثاني . التطبيق الثانى : فى هذا التطبيق سنقوم بوضع نوع و اسماء الكائنات المطلوب عرضها فى القائمة المختصرة فى جدول اسميته TblConditions . مثال: المثال الخاص بها مرفق بإسم Amr Multi Level Menu-Some Objects . التطبيق الثالث : يعتمد هذا التطبيق بربط التطبيق الثانى بصلاحيات المستخدمين, افترضت فى المثال ان عندى 3 مجموعات رئيسية للمستخدمين اول مجموعة Admins او المدراء ولهم كافة الصلاحيات , المجموعة الثانية المستخدم العادى ولهم بعض الصلاحيات , المجموعة الثالثة الضيوف ولهم صلاحية واحدة فقط وهو عرض الشاشة الرئيسية او نموذج واحد مثلا , ويتم تحديد المجموعات التى لها صلاحية استعراض الكائنات فى سجل بجانب اسم الكائن ونوعه فى الجدول TblConditions . مثال : ملاحظة : القائمة الأخيرة " صنعت خصيصاً " جعلتها حصراً على الAdmins فقط وبالتالى لن تظهر لباقى المجموعات . ستجد المثال الخاص بهذا التطبيق باسم Amr Multi Level Menu-Some Objects - Users - V2.0 . وبهذا انتهى الموضوع . ملاحظات عامة : استوحيت فكرة القائمة المتعددة المستويات من شخص اجنبى اسمه MaJip وقمت ببناء افكارى عليها . يمكن استدعاء القائمة عند فتح النموذج او عند النقر على الصورة الموجودة فى الامثلة ومرفق الطريقتين استخدم ما يناسبك . القوائم التى تنحدر منها قوائم اخرى لا يمكن تخصيص ايقونة لها ولكن القوائم الفرعية يمكن تخصيص ايقونة لها سواء عن طريق خاصية Face ID او عن طريقة خاصية Picture لارفاق صورة خارجية . فكرة صلاحيات المستخدمين طلبها الأخ @عمر ضاحى وبالتالى صممتها وارفقتها للموضوع . أستاذنا @jjafferr يرجى مراجعة الموضوع وتصحيح ما أخطأت به ان وجد 😅 جزاكم الله خير الأخ العزيز @ابو جودي اعتذر عن استخدام مثالك لأنى كنت قد جهزت الامثلة المستخدمة بالفعل .. جزاك الله خير دمتم بخير Amr Multi Level Menu -All Objects.accdb Amr Multi Level Menu-Some Objects - Users - V2.0.accdb Amr Multi Level Menu-Some Objects.accdb

السلام عليكم .. الاخوة الافاضل الموضوع اليوم بسيط وسريع ويتحدث عن طريقة عمل قوائم مختصرة منبثقة من الازرار مثل الصورة التالية : الفكرة كلها ان عندى نموذج به الكثير من الازرار فبحثت عن طرق لاختصار الاوامر كلها فى زر او اثنين وبالتالى وصلت الى الفكرة التالية. اول خطوة عمل موديول جديد به الكود التالى : Sub MyMenu2() Dim Mnu As CommandBar, Itm As CommandBarControl Set Mnu = CommandBars.Add("", MsoBarPopUp, , True) Set Itm = Mnu.Controls.Add: Itm.Caption = "Export To PDF": Itm.OnAction = "amr3" Set Itm = Mnu.Controls.Add: Itm.Caption = "Export To Excel": Itm.OnAction = "amr4" Mnu.ShowPopup End Sub القائمة السابقة فيها امرين 2 فقط ويمكن زيادتها كما تريد بتكرار السطور وتغيير الاسماء , بالنسبة لAmr1 فى نهاية الجملة هو الامر المطلوب تنفيذه وسيتضح الموضوع من المثال المرفق . الخطوة الثانية : فى النموذج المطلوب تنفيذ الفكرة عليه , خلف زر الامر يتم وضع كود استدعاء للكود السابق كالتالى : Private Sub Command0_Click() MyMenu2 End Sub والنتيجة عند الضغط على الزر تنبثق القائمة كما فى الصورة السابقة . ملاحظات : قمت باضافة خيار آخر لاظهار القائمة وهو عن طريق الضغط على زر الفأرة الايسر مع زر الشفت فى نفس الوقت وستظهر القائمة ايضاً . يمكن تطبيق الطريقة فى التقارير والنماذج مع الاحتفاظ بالقائمة المختصرة الافتراضية الخاصة بزر الفأرة الأيمن وبالتالى سيصبح عند قائمتين مختصرتين اذا اردت الابقاء على الافتراضية . يجب تفعيل المكتبات الموجودة بالصورة حتى لا تواجه مشاكل . اترككم مع المثال لمزيد من التوضيح .. دمتم بخير Amr Magic Button.accdb

السلام عليكم .. اخوانى الكرام ,, بعد التحية موضوعنا اليوم عن النسخ الاحتياطى لمحتويات فولدر محدد فى وقت محدد من اليوم على اساس يومى او اسبوعى او شهرى كما تريد . قمت بتصميم نموذج فى القاعدة المرفقة يتم تحديد فيه الفولدر المطلوب نسخه و مكان حفظ النسخة والوقت الذى يتم فيه النسخ تلقائيا . كود النسخ المستخدم كالتالى : Public Sub Copy_Folder1() Dim FSO As Object Dim FromPath As String Dim ToPath As String FromPath = Forms!Frm!from 'ToPath = "D:\Old\test" '<< Change ToPath = Forms!Frm!To2 & Format(Now, "yyyy-mm-dd h-mm-ss") If Right(FromPath, 1) = "\" Then FromPath = Left(FromPath, Len(FromPath) - 1) End If If Right(ToPath, 1) = "\" Then ToPath = Left(ToPath, Len(ToPath) - 1) End If Set FSO = CreateObject("scripting.filesystemobject") If FSO.FolderExists(FromPath) = False Then MsgBox FromPath & "المسار المطلوب النسخ منه غير موجود" Exit Sub End If FSO.CopyFolder Source:=FromPath, Destination:=ToPath End Sub مميزات الكود : نسخ محتويات الفولدر بالكامل سواء ملفات او فولدرات فرعية . فى حالة عدم وجود المسار المطلوب وضع النسخة الاحتياطية فيه سيقوم بانشاءه تلقائياً. فى حالة وجود المسار وبه ملفات بنفس الاسم سيتم عمل Overwrite للملفات القديمة واستبدالها بالجديدة (وذلك فى حالة انك غيرت الاسم الذى يتم الحفظ به لأن الافتراضى يحفظ الاسم بالتاريخ ووقت الحفظ بالدقائق وبالتالى من الصعب تشابه الاسماء بين النسخ). شكل النموذج عند الضغط على تشغيل يقوم باستدعاء كود النسخ . فى حالة وصول وقت الجهاز الى الوقت المحدد بالنموذج يقوم باستدعاء كود النسخ . يمكنك كتابة المسار او اختياره عن طريق الازرار الموجودة بجوار الحقل النصى. لحد الآن موصلناش لجزئية التلقائى المذكورة فى العنوان 😅, من المعروف ان لازم تكون القاعدة مفتوحة حتى يعمل النسخ الاحتياطى وبالتالى فى حالة انك قمت بعمل استيراد للبرنامج ده داخل قاعدتك الاساسية المفتوحة طوال اليوم فلا مشكلة وعند وصول الوقت المحدد ستعمل بدون مشاكل .. ولكن ماذا لو اردت ان النسخ يتم حتى لو القاعدة مغلقة ؟ سنقوم بالاستفادة بخاصية مهمة موجودة فى الويندوز وبدون استخدام برامج خارجية تابع معى : فى قائمة Start ابحث عن Task Scheduler وهى خاصية تقوم بعمل مجموعة من الاوامر فى اوقات محددة مثل تشغيل برنامج او اغلاقه او ارسال ايميل مثلا الخ... هذه صورة الواجهة اضغط على Create Basic Task وستفتح لك الواجهة التالية : اكتب اسم المهمة المطلوبة ثم Next : هنا تكرار المهمة يوميا - اسبوعيا - شهريا - مرة واحدة - عند بداية التشغيل للجهاز - عندما اسجل دخول المستخدم - عند حدوث حدث معين . اختر ما يناسبك وفى حالتنا اخترت Daily يومياً . اختر تاريخ بداية العمل و الوقت المطلوب تشغيل المهمة فيه .التالى فى هذه الخطوة تختار ماهية المهمة فتح برنامج معين - ارسال ايميل - عرض رسالة محددة .. اختر Start Program فى حالتنا .. التالى فى هذه الخطوة تقوم باختيار مسار البرنامج المطلوب تشغيله وطبعا فى هذه الحالة البرنامج هو ميكروسوفت اكسس يتم تحديد مسار البرنامج من "C:" ثم تحديد القاعدة المطلوب تشغيلها فى Arguments بنفس الصيغة الموجودة بالصورة (بين علامتين تنصيص والمسار كامل بالامتداد ) #Program/Script "C:\Program Files\Microsoft Office\Office16\MSACCESS.EXE" #Arguments "C:\Users\Amr\Access\Backup\Tasker.Accdb" ثم اضغط على Finish. وبهذا قمنا بعمل مهمة للويندوز انه يفتح القاعدة الخاصة بنا فى وقت معين يومياً ,, باقى العمل داخل القاعدة نفسها كالتالى : فى حدث عند الفتح للنموذج ستجد الكود التالى : Private Sub Form_Open(Cancel As Integer) DoCmd.GoToRecord , , acFirst Me.To2 = [to] & "\" & [newnm] & " " Call SixHatHideWindow(SW_SHOWMINIMIZED) 'Call Copy_Folder1 '''' نقوم بتفعيل الخيار بعد تحديد الخيارات فى النموذج اول مرة لتعمل بتلقائية فيما بعد 'DoCmd.Quit '''' نقوم بتفعيل الخيار بعد تحديد الخيارات فى النموذج اول مرة لتعمل بتلقائية فيما بعد End Sub السطرين الغير مفعلين يتم تفعليهم بعد تحديد الخيارات الخاصة بيك من النموذج اول مرة وعند تفعيلهم بمجرد تشغيل القاعدة ستقوم بعملية النسخ وتغلق تلقائياً .. وبالتالى ملخص الفكرة ان القاعدة هتكون مغلقة وهتقوم مهمة الويندوز بتشغيلها وعند تشغيلها ستقوم بعمل النسخ الاحتياطى بالبيانات التى تم تحديدها اول مرة ثم تغلق تلقائياً وذلك فى اقل من ثانية قد لا تلاحظها من الاساس . مرفق القاعدة .. جرب ووافنى بالنتيجة .. دمتم بخير. ملحوظة : يمكن عمل المهمة الخاصة بالويندوز عن طريق اسكريبت VBS اختصارا للخطوات ولكن اردت شرح الفكرة من أساسها ويكون هناك مساحة للتطوير فيما بعد . BackupManual+Auto+Timer-AmrAshraf.accdb

وجدت طريقة اسهل .. اولاً الغي جميع ماسبق من خطوات واستخدمي فقط هذا الكود فيحدث "عند النقر" لزر ضغط واصلاح القاعدة واخبرينا بالنتيجة If MsgBox("هل ترغب في ضغط واصلاح بيانات القاعدة قبل إغلاقها" & vbCrLf & _ "اضغط على (لا) لإلغاء العملية . اضغط على (نعم) لضغط البيانات ", _ vbInformation + vbMsgBoxRight + vbYesNo + vbDefaultButton1, _ "تنبيه : رسالة تأكيد ضغط قاعدة البيانات واصلاحها") = vbYes Then Application.SetOption "Auto compact", True End If DoCmd.Quit