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

السلام عليكم 🙂 هذا المنتدى ولله الحمد ، به الخير الكثير ، والخبراء يسطعون بعطائهم مميزين بعطائهم 🙂 اخي الكريم @ابوآمنة ومحمد البرناوي @Barna ، لنا الشرف انظمامكم لفريق الخبراء 🙂 ولازلنا نبحث بين الاجابات على المتميزين 🙂 جعفر

اساتذتى الكرام الاستاذ @ابوآمنة والاستاذ @Barna الف مبروك اساتذتى الكرام واسأل الله تعالى ان يهيئ لكم من امركم رشدا ويرزقكم العون ان شاء الله ويجعل كل اعمالكم خالصة لوجه الكريم ويرزقكم القبول

السلام عليكم امتداداً لتطويرات برنامج الخليل المحاسبي يسرني أهدي لكم الإصدار الثاني مع تعديلات وإضافات جميلة كما أشكر أستاذي الفاضل @sandanet لقد استفدت من طريقته في الحماية حسب مشاركته القيمة : اترك لكم البرنامج . وآملاً أن اتلقى ملاحظاتكم القيمة بعد استخدام البرنامج . تقبلوا فائق المحبة والتقدير BuySal20_V14.accdb BuySal20_V14.accdb.mdb.zip

السلام عليكم ورحمة الله وبركاته.. آولآ نقُوم بتَسجيل عضُوية بمُوقع [ PasteBin ] رآبط آلتَسجيل [ هُنآ ] آتمآم آلتَسجيل ، ظهُور رسآلة تُخبرك بآلتُوجه نحُو بَريدك لتَفعيل آلعضُوية بَعد عَملية آلتَفعيل ظهُور رسآلة تُخبرك بنجآح آلتَفعيل آلآن نقُوم بتَسجيل آلدخُول قم باعطاء هذا الملف الى العميل لكي يظهر لك الرقم الخاص به ثم يقوم العميل بإعطائك هذا الرقم، بعدها ستقوم انت باضافته الى المفكرة التي انشأتها في موقع pastebin ثُم نقُوم بآلضَغط عَلى كَلك يَمين عَلى كَلمة [ RAW ] ونَختآر ارجع الى برنامجك, وقم بإلصاق الرابط في المكان المخصص له Option Compare Database Private Sub Form_Current() Dim HDD, PID, MB, MAC As String PID = ProcessorId() HDD = VolumeSerialNumber() MAC = MACAddress() MB = MotherBoardID() Dim PHMB As String PHMB = Strings.UCase(MD5Hex(PID & HDD & MB & MAC)) On Error Resume Next Dim objHttp As Object Set objHttp = CreateObject("MSXML2.ServerXMLHTTP") Call objHttp.Open("GET", "ضع الرابط هنا", False) Call objHttp.Send("") For Each c In Split(objHttp.ResponseText, "|") If PHMB = c Then GoTo authed End If Next MsgBox "1 - قد تكون النسخة الحالية غير مسجلة" & ChrW(13) & ChrW(10) & ChrW(13) & ChrW(10) & "2 - تأكد من اتصالك بالانترنت" & ChrW(13) & ChrW(10) & ChrW(13) & ChrW(10) & "3 - اذا لم تكن واحدة من تلك المشاكل قم بالاتصال بالمبرمج" & ChrW(13) & ChrW(10) & ChrW(13) & ChrW(10) & "www.facebook.com/Nisr.Aln3jaf", vbCritical, "ERROR" DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit Exit Sub authed: MsgBox "تم تفعيل النسخة بنجاح" & ChrW(13) & ChrW(10) & ChrW(13) & ChrW(10) & "شكرا لإستخدامك هذه النسخة", vbInformation, "عملية ناجحة" End Sub Public Function MD5Hex(textString As String) As String Dim enc Dim textBytes() As Byte Dim bytes Dim outstr As String Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider") textBytes = textString bytes = enc.ComputeHash_2((textBytes)) For pos = 1 To LenB(bytes) outstr = outstr & LCase(Right("0" & Hex(AscB(MidB(bytes, pos, 1))), 2)) Next MD5Hex = outstr Set enc = Nothing End Function Public Function MACAddress() On Error Resume Next strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration", , 48) For Each objItem In colItems MACAddress = objItem.MACAddress Next End Function Public Function ProcessorId() On Error Resume Next Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor") For Each objItem In colItems ProcessorId = objItem.ProcessorId Next End Function Public Function VolumeSerialNumber() As String On Error Resume Next Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set oItems = oWMI.ExecQuery("Select * from Win32_DiskDrive") For Each oItem In oItems VolumeSerialNumber = oItem.SerialNumber Next End Function Public Function MotherBoardID() As String On Error Resume Next strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_BaseBoard", , 48) For Each objItem In colItems MotherBoardID = objItem.SerialNumber Next End Function في كل قواعد البيانات التي تريد حمايتها ضع نفس الرابط، لا تقم بإنشاء مفكرة جديدة في موقع pastebin آلآن آلسؤآل كَيف سآقُوم بآضآفة آكثر مَن رَقم عَميل بنفس المفكرة ؟ آلجوُآب بَين كُل عَميل وآخر آفصل بَينهم بآلـ [ | ] مثآل بَسيط عَلى آلعَملية .. تم بحمد الله ، SEMO.Pa3x GET_INFO.accdb Protection.accdb

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

مداخلة بسيطة, بإمكانك استخدام الدالة Split داخل وحدة نمطية. اسمح لي ان ابدي محاولتي البسيطة Database2.rar

مبارك لنا وجودكم معنا.

@Barna و @ابوآمنة ما شاء الله تبارك الله ...... تستاهلون هذه المنزلة ....موفقين دائما للخير ...

@Barnaأخوىَّ الحبيبان .. @ابوآمنة مبارك إنضمامكم لخبراء أوفيسنا .. شرُفنا بكما وفقكم الله وأعانكم على الخير

جرب هذا الملف ..... حذف المكرر.accdb

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

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

سبقتنى كنت اجهز لموضوع مماثل التفعيل عن طريق الانترنت وبما ان الطرق مختلفة ساكمل فى طريقى واجهز الموضوع هههههههههههههههههه بارك الله فيك متميز دائما

كعادتي اليومي اطلع على أبرز المواضيع ، فتفاجأت بأن لقبي أصبح خبيراً 😅 والأعضاء يرحبوا بي ولزميلي @Barna فبهذه المناسبة أتقدم بجزيل الشكر والتقدير إلى إدارة منتدانا الغالي الذي منحنا فرص لخدمة الناس كما قال الرسول صلى الله عليه وسلم (أحبُّ الناسِ إلى اللهِ أنْفَعُهُمْ لِلنَّاسِ ) . أيضاً أخص بالشكر أفضله وأحسنه لأستاذنا ومعلمنا الجليل♥️ @jjafferr وللأعضاء الكرام وأبارك لزميلي الفاضل @Barna أسأل الله تعالى العلي القدير أن يعيننا على تحمل المسؤولية . وبارك الله فيكم وسدد خطاكم ..

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

الف مبروك اخوانى وتمنياتى لكم وللجميع بالتوفيق ودوام النجاح ان شاء الله طبتم واهتديتم

الف مبروك والى الامام دائما باذن الله 🌷

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

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

الاخ محمد والاخ صالح يستحقون اللقب بجدارة الف مبروك

مبارك للأخوة مع الدعاء بدوام التوفيق للجميع

حياكم الله اخوان، بوركت استاذي @jjafferr على مبادرتك الجميلة.

الله الله ربنا يزيد ويبارك في خبرائنا مزيد من التقدم في منتدانا العزيز تهنئه لخبيرنا ابو امنه وخبيرنا محمد البرناوي فهم اهل ثقة ومحل خبره اللهم زيدهم علما ننتفع به نحن فعلا يستاهلوها

تفضل 🙂 Private Sub K_id_BeforeUpdate(Cancel As Integer) If Left(Me.K_id, 1) <> 2 Then Cancel = True MsgBox "يجب ان يبدأ هذا الحقل بالرقم 2" Exit Sub End If End Sub جعفر

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

السلام عليكم ورحمة الله أرجو أني وفقت في تقديم المساعدة... test 1.xlsx

ممكن ان يكون الحل Crezy_sequance.xlsx

بناءا على طلب العديد من الاصدقاء قمت بعمل دورة مجانية لتعليم برمجة الاكسس لمتابعة الدورة للمبتدئين عبر هذا الرابط

ماشاء الله برنامج متعوب عليه ... بارك الله فيك

آه نسيت !! الفاصلة المنقوطة بدل الفاصلة 🙂 شكرا يا شباب ، استاذ محمد واستاذ خالد 🙂 جعفر

كفيت ووفيت أخى وأستاذى العيدروس بارك الله فيكم وفى أولادكم وجزاكم الله خيرا

السلام عليكم 🙂 الاستاذ خالد اعطاك الجواب 🙂 وانا استغل الفرصة ، واستعمل جوابه ، ولكن احذف المسافة الفارغة الموجودة في الحقول ، بإستخدام الامر Trim : للمادة M2: Trim(Left([subname],Len([subname])-9)) والشعبة S2: Trim(Right([subname],9)) جعفر

اخي محي الدين اظن انه لا حاجة للأمر Select عدة مرات مما يرهق البرنامج دون فائدة ولا حاجة للحلقة التكرارية مرة ثانية لاستخراج Items من Dictionary يكفي وضع هذا السطر ما بين علامات الــــ +++ Sub test() Dim a As Variant, lr, i lr = Cells(Rows.Count, 2).End(xlUp).Row a = Range("b3:b" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 6) Cells(3, "H").Resize(100).ClearContents With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) <> 0 Then If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 5) Else .Item(a(i, 1)) = .Item(a(i, 1)) & "-" & a(i, 5) End If End If Next '+++++++++++++++++++++++++++++++++++++++ Cells(3, "H").Resize(.Count) = Application.Transpose(.items) '++++++++++++++++++++++++++++++++++++++++ End With End Sub

جرب هذا لعله يفي الغرض ترتيب القيم.xlsm

السلام عليكم هذا Height ارتفاع الـ CheckBox * عدد الاسماء النتيجة نحطها ارتفاع الـ Frame2 بيان الحالة2.xlsm

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

عليكم السلام, اضافة لاستاذي @jjafferr Private Sub K_id_BeforeUpdate(Cancel As Integer) If InStr(1, K_id, 2) <> 1 Then Cancel = True MsgBox "يجب ان يبدأ الحقل برقم 2" Exit Sub End If End Sub

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

وعليكم السلام 🙂 قمت بتغيير اسم حقل التاريخ الى iDate ، و زر الاضافه ، اصبح كوده (يتأكد من ادخال بيانات اليوم والحصة والتاريخ ، واذا ما اردت اي منهم ، يمكنك الغاءه/حذفه من الكود) : Private Sub Command42_Click() 'التأكد من ان الحقول مملوءه قبل السماح بإضافة سجل If Len(Me.iDay & "") = 0 Then 'اليوم MsgBox "فضلا أدخل اليوم" Me.iDay.SetFocus Exit Sub ElseIf Len(Me.iA1 & "") = 0 Then 'الحصة MsgBox "فضلا أدخل الحصة" Me.iA1.SetFocus Exit Sub ElseIf Len(Me.iDate & "") = 0 Then 'التاريخ MsgBox "فضلا أدخل تاريخ اليوم" Me.iDate.SetFocus Exit Sub End If If DCount("[MainId]", "qryCheckRepeat") = 0 Then DoCmd.SetWarnings False DoCmd.RunSQL "insert into subst(mainid,type,TDate,Day,A1)values (' " & Me.StId & " ',' " & Me.Combo36 & " ',' " & Me.Text40 & " ',' " & Me.iDay & " ','" & Me.iA1 & "')" DoCmd.SetWarnings True Me.iStName.Requery Me.SubSt.Requery Else MsgBox "لقد تم تحضير الطالب من قبل" Exit Sub End If End Sub جعفر 1126.(02) متابعة غياب طلاب الفراغات.mdb.zip

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم هذا الكود سيعمل معك على نسخة 32 & 64 بدون مشاكل ان شاء الله Dim XPicFile As Variant Dim XPicFilez As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Clear .Filters.Add "All Files", "*.*" .Filters.Add "jpg image", "*.jpg" .Filters.Add "jpeg image", "*.jpeg" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then XPicFilez = .SelectedItems(1) [PackDesign subform].[Form]![PicFile] = XPicFilez [imgPicture].Picture = [PackDesign subform].[Form]![PicFile] End If End With تحياتي

تم التعديل كما تريد Option Explicit Sub transfer_data() Dim Source_sh As Worksheet Dim Target_sh As Worksheet Dim last_ro%, N_ro% Set Source_sh = Sheets("ورقة1") last_ro = Source_sh.Cells(Rows.Count, 3).End(3).Row If last_ro < 10 Then Exit Sub Select Case Source_sh.Range("c2") Case "أ": Set Target_sh = Sheets("نوبة أ") Case "ب": Set Target_sh = Sheets("نوبة ب") Case "ج": Set Target_sh = Sheets("نوبة ج") Case "د": Set Target_sh = Sheets("نوبة د") Case "ه": Set Target_sh = Sheets("نوبة ه") Case "و": Set Target_sh = Sheets("نوبة و") End Select N_ro = Target_sh.Cells(Rows.Count, 1).End(3).Row + 1 Target_sh.Range("a" & N_ro).Resize(last_ro - 9, 6).Value = _ Source_sh.Range("B10").Resize(last_ro - 9, 6).Value End Sub الملف مرفق EHSAA3_1.xlsm

بارك الله فيك استاذ عبد اللطيف وزادك الله من فضله

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

اخى الكريم أحمد هناك اكثر من كود كما ان هناك أثر من 4 يوزرفورم لا ينفع نقلهم جزاك الله كل خير

اهلا بك اخى الكريم فى المنتدى اجعل دائما عنوان المشاركة دليل على ما تحتاج وتريد يمكنك ضغط الملف ورفعه او ممكن تقوم بتحميل هذا البرنامج وتسطيبه لفك كلمة سر الملف Passware Kit Forensic 13.5

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

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

وعليكم السلام تفضل لك ما طلبت ايرادات الروضة معدل.xlsx

يمكنك مراجعة نسخة الأوفيس لديك فالملف يعمل عندى بكفاءة

وعليكم السلام اخى الكريم تفضل هذا الملف لعله المطلوب تفقيط عربى وانجليزى.xlsm