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

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

أساتذتي الافاضل @essam rabea و @ابو ياسين المشولي و @sandanet و @ابا جودى كنت قد بدائت بعمل ملف ارفع للمنتدى حتى يتسنى لكم التعديل علية لحل المشكلة حذفت اغلب النماذج والتقارير من الملف الاساسي وأبقيت على نماذج الواجهة فقط الذي فيها المشكلة فقمت بعمل اخير وهو تجربته في جهاز اخر وهنا المفاجئة اشتغل تمام أدركت حينها أن في قيمة حقل او قد ربما كود هو المسبب وبعد الفحص في الملف الاساسي .. اكتشفت سبب المشكلة وهو كود تحت زر فتح نموذج تغيير كلمة السر On Error GoTo Err_Orders1_Click Form_Main!F8.SetFocus Form_Main.F8.BackColor = RGB(33, 150, 243) Form_Main.F8.ForeColor = RGB(250, 250, 250) Dim x As Integer x = DLookup("SN", "users_T", "deCode([UName],'User')='" & Trim(MyUser.USERNAME) & "'") DoCmd.OpenForm "UsersChangePassword_F", , , , , acDialog, x Exit_Orders1_Click: Exit Sub Err_Orders1_Click: MsgBox Err.Description Resume Exit_Orders1_Click قمت بألغاء هذا الكود On Error GoTo Err_Orders1_Click ' ' Exit_Orders1_Click: Exit Sub Err_Orders1_Click: MsgBox Err.Description Resume Exit_Orders1_Click وتم فتح البرنامج بشكل طبيعي أشكركم على سعة صدوركم و وتعاونكم معي فجزاكم الله عني خيرا

بالنسبة للترحيل من ملف لاخر هناك زر ترحيل في شيت1 بالملف الاول اما الترحيل الى الشيتات الاخرى يجب عليك انشاء الصفحات كما تريد وضع بعض البيانات فيها كنمودج نهائي للعمل وارفعه مع شرح المراد في المرفق فك الضغط ستجد مجلد "my_test"ضعه كما هو في اي فولدر تريد my_test.rar

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

شرُف منتدانا بانضمامكم لمجموعة الخبراء زادكم الله علما ونفع بكم

حياك الله أخي محمد ضع هذا الكود في حدث عند الإغلاق StopSound Me.SoundPath وبالتوفيق

السلام عليكم امتداداً لتطويرات برنامج الخليل المحاسبي يسرني أهدي لكم الإصدار الثاني مع تعديلات وإضافات جميلة كما أشكر أستاذي الفاضل @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

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

وعليكم السلام 🙂 شكرا لك اخوي ابو زاهر ، ليس بصفتي عضو في فريق الموقع فقط ، وانما بصفتي العضو جعفر ايضا 🙂 مكان رائع نجتمع فيه ، حُباً في خدمة بعضنا البعض 🙂 جعفر

تفضل اخوي ابو ياسين ، فالموضوع تابع للسؤال 🙂 وشكرا لك على مراعاة قوانين المنتدى 🙂 جعفر

بعد إذن والدى الحبيب واستاذى الجليل ومعلمى القدير الاستاذى @jjafferr اسمح لى اقوم بارفاق هذا التعديل على المرفق لاخى صاحب المسألة - انشاء الـ QR Code لكل سجل على حده فى النموذج المستمر -عرض الـ QR Code الذى تم انشاءه لكل سجل على حدة داخل النموذج المستمر -عرض تقرير لكل سجل على حده فى من خلال السجل الحالى داخل النموذج المستمر -عرض تقرير مجمع لكل السجلات فقط التى تم انشاء الـ QR Code لها فقط اتفضل يا استاذ @nasseam1969 سؤال.zip

الحمد لله

تفضل تم تغيير معادلتك نهائياً فهى لا تعمل المشتريات1.xlsx

السلام عليكم ورحمة الله تم عمل المطلوب في الملف المرفق... test 1.xlsx

اخي محي الدين اظن انه لا حاجة للأمر 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

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) 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 For i = 1 To lr - 2 Cells(2 + i, 2).Offset(, 6).Select Cells(2 + i, 2).Offset(, 6) = .Item(Cells(2 + i, 2).Value) Next End With End Sub

يعطيك العافية على الأفكار الجميلة الملف يفتح عندك فقط على اوفيس 2010 وعند الاخرين لا لانك قمت بتحويله الى ملف mde لذا سوف يفتح على اصدار اعلى من اوفيس 2010 على ما اعتقد انك تعتمد في جلب الاكواد على ملف تكست يتم تنزيله من حساب على الانترنت كما ورد في مشاركات سابقة لك وعلى الاغلب الدروب بوكس وعند فتح البرنامج يقرأ ما في ملف التكست ماذا لو قام العميل بتغيير التاريخ في ملف التكست الذي تم تنزيله ثم فتح البرنامج؟؟ هذا سؤال مبني على ما قلته انا بخصوص ان التفعيل يتم عن طريق ملف تكست يتم انزاله من الانترنت عموما في انتظار النسخة المفتوحة للاطلاع :: تحياتي

شعور متبادل بيننا😍 ونحن نحبكم في الله جميعاً

تحياتي لك اخي الكريم @ابو زاهر صدقت فالاحساس واحد 👍 .. الحمد لله رب العالمين

الحمد لله الذى بنعمته تتم الصالحات

السلام عليطم ورحمة الله في المرفق استعلامين بهما بيانات المطلوب حدف البيانات المكررة في العمود المسمى -1- سواء في الجدول او الاستعلام ولكم جزيل الشكر - هل يوجد معيار في استعلام يقوم بحدف المكرر كما هو المطلوب هنا في المشاركة نأمل ان يكون المطلوب واضحا Aziz.rar

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

هل يمكن ان يتكرر نفس الصف لا وجود للمستحيل مع اكسل فقط جرب هذا الملف maktaba.xls

جارى فحص تعليقك واستنباط الافكار لان تعليقك غنى بالافكار والمشكلات الخاصة ببرنامجى

مبارك للاخوة الافاضل اللهم ربي يحفظهم ويحفظ الجميع يارب

لايعمل

وعليكم السلام ورحمة الله وبركاتة تفضل اخي الكريم ملفك بعد التعديل FilterCombo.mdb

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

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

تم التعديل كما تريد (كنت لا أريد ان تتكرر السنوات امام تكرار الاسماء ) Option Explicit Sub extarct_recorde() Dim dict As Object Dim Sh As Worksheet, i%: i = 3 Dim Ky, k, itm Set Sh = Sheets("ورقة1") Set dict = CreateObject("Scripting.Dictionary") With Sh .Range("H3").Resize(.Range("H3") _ .CurrentRegion.Rows.Count).ClearContents Do Until .Range("C" & i) = vbNullString k = Sh.Range("C" & i): itm = Sh.Range("F" & i) If Not dict.exists(k) Then dict.Add k, itm Else dict(k) = dict(k) & "-" & itm End If i = i + 1 Loop i = 3 Do Until .Range("C" & i) = vbNullString .Range("H" & i) = dict(.Range("C" & i).Value) i = i + 1 Loop End With Set dict = Nothing: Set Sh = Nothing End Sub

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

جزاك الله خيرًا

بارك الله فيك وزادك الله من فضله

جزاك الله خيراً علي هذا العمل الكبير والمفيد جدا لمعظم الاعضاء جاري الاطلاع والإفادة بعد الاطلاع برنامج متعوب فيه وجميل جدا بارك الله فيك وجزاك الله خيرا

أخي العزيز سليم كلامك صحيح مشكور

الكود Private Sub CommandButton1_Click() Dim erow As Long Worksheets("magdi").Activate rrow = Worksheets("magdi").Cells(1, 1).CurrentRegion.Rows.Count + 1 Sheets(1).Activate lrow = Range("a" & Rows.Count).End(xlUp).Row Range("a" & lrow + 1).Value = TextBox1 Range("a" & lrow + 1).Offset(0, 0).Value = TextBox1.Value Range("a" & lrow + 1).Offset(0, 1).Value = TextBox2.Value Range("a" & lrow + 1).Offset(0, 2).Value = TextBox3.Value Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" End Sub Private Sub CommandButton2_Click() Dim erow As Long Worksheets("yonis").Activate rrow = Worksheets("yonis").Cells(1, 1).CurrentRegion.Rows.Count + 1 Sheets(2).Activate lrow = Range("a" & Rows.Count).End(xlUp).Row Range("a" & lrow + 1).Value = TextBox1 Range("a" & lrow + 1).Offset(0, 0).Value = TextBox1.Value Range("a" & lrow + 1).Offset(0, 1).Value = TextBox2.Value Range("a" & lrow + 1).Offset(0, 2).Value = TextBox3.Value Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" End Sub Private Sub CommandButton3_Click() Unload Me End Sub Private Sub CommandButton4_Click() Dim erow As Long Worksheets("mahmoud").Activate rrow = Worksheets("mahmoud").Cells(1, 1).CurrentRegion.Rows.Count + 1 Sheets(3).Activate lrow = Range("a" & Rows.Count).End(xlUp).Row Range("a" & lrow + 1).Value = TextBox1 Range("a" & lrow + 1).Offset(0, 0).Value = TextBox1.Value Range("a" & lrow + 1).Offset(0, 1).Value = TextBox2.Value Range("a" & lrow + 1).Offset(0, 2).Value = TextBox3.Value Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" End Sub

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

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

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

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

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

السلام عليكم طريقة عمل ترقيم تلقائي لبيانات جدول على الاكسل مرفق ملف العمل وفيديو يشرح الطريقة الارقام اوتو.xlsx

جذاك الله كل خير ولك مثله

الف شكر اخ احمد غانم

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

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

اتبع التالي لاضافة العنصر حسب الاصدار لديك

شكرا على التلوين الجميل 🙂 في معظم اعمالي ، اقوم بالعمل الاساسي ، واترك مجال للآخرين ان يغيروا في البرنامج ، ولكني اعطيهم طريقة العمل 🙂 وبرامجي اعملها بطريقة تكون سهل التعديل والاضافة عليها ، وسهولة الوصول الى الكود المطلوب 🙂 وفي هذا الموضوع ، ومن اول مشاركة وضعت لكم الملفات المطلوبة لتقوموا بعمل التغييرات المطلوبة : جعفر

استاذى الجليل ومعلمى القدير استاذ @jjafferr --fg=COLOUR Specify a foreground colour (in hex) انا قمت بتعديل الكود بالشكل الاتى ShellWait App_Name & " -o " & Output_File & " --rotate=0 --eci=24 --binary --barcode=55 --mode=3 --fg=2a24e7 -d " & Output_Text اضفت هذا --fg=2a24e7 لون ازرق