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

السلام عليكم ورحمة الله وبركاته هذه دعوة كريمة لتجربة الأداة الجديدة والفريدة من نوعها : دكتور ال VBA وضائف الأداة : 1- تحويل الكود إلى صيغة متوافقة مع النواتين 32 و 64 بت. 2- تصحيح الأخطاء البرمجية في الكود. 3- تنسيق وترتيب الكود شكليا. 4- كتابة التعليقات وشرح للكود باللغتين العربية والإنجليزية. 5- إضافة صائد الأخطاء للكود وذلك لتعقب الأخطاء البرمجية. 6- إضافة ترقيم لأسطر الكود. يمكنك اختيار واحد من هذه الوظائف أو تختار من بينها ما تريده. الأداة مخصصة لأكواد ال VBA وتعتمد على قدرات الذكاء الاصطناعي لإعطاء نتائج دقيقة ومبهرة .. 😁✌🏻 اختصر على نفسك الوقت والجهد واعمل بذكاء 😉👌🏻 رابط الأداة : https://vba-code-doctor-471932697586.us-west1.run.app/ يمكنك فتحها في الهاتف أو الحاسوب على راحتك 😎🌷 جربوها وعطوني رأيكم 😇✌🏻

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

وعليكم السلام ورحمة الله وبركاته الى جانب الحلول التي ارفقها استاذنا الفاضل hegazee اليك حل اخر بالكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim rngF As Range, rngG As Range Dim rngB As Range, rngC As Range Dim pos As Variant Set rngF = Me.Range("F2") ' Set rngG = Me.Range("G2") Set rngB = Me.Range("B2:B1000") Set rngC = Me.Range("C2:C1000") If Not Intersect(Target, rngF) Is Nothing Then Application.EnableEvents = False pos = Application.Match(rngF.Value, rngB, 0) If Not IsError(pos) Then rngG.Value = Application.Index(rngC, pos) Else rngG.Value = "" End If Application.EnableEvents = True End If rngG.Select End Sub data.xlsb

بعد إذن مهندسنا الغالي .. إذا كان ملفك بصيغة Accde فلن تصل للأكواد أبداً .

لا عليك أخي عبداللطيف ، المهم ان المشكلة تم حلها .

تفضل التعديل التالي .. جربه وأخبرني بالنتيجة . 123452025.zip

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

رداً على هذه النقطة ، وحيث أنه سبق تنفيذها سابقاً .. جرب المرفق نفسه بعد التعديل بحيث سيتم فقط عرض الخطوط العربية ( أو التي تتعامل مع الكاركتر العربي ) في الكومبوبوكس . مع إضافة الفرز التصاعدي للأسماء :- Db3.zip

وانا عند وعدى هذه مشاركتى 1- بعد فك الضغط انقل الصور الى المجلد : TempResources 2- قم بفتح قاعدة البيانات 3- فى المستقبل فقط اضف اى صور الى المجلد : TempResources فى جزء لم انته منه بعد حفظ الاعدادت كقوالب او حفظ الاعدادت لكل شهادة ان اردنا ان تكون كقاعدة بيانات للاحتفاظ بالبيانت وليس مجرد موديولر لعمل الشهادات ويتبقى الجزء الاخير انا افكر فى الطباعة من النموذج الفرعى بشكل مباشر بدون اى تقارير الى لقاء قريب بعد ان اعرف ارائكم فى التطبيق والافكار البسيطة المتواضعة

فكرتي المتواضعة .. dbs2.zip

بل اعجبني المشهد .. سلمت اناملك يا سلام .. زاد حماسي .. احب المفاجآت في مثل هذه المواضيع

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

فضلت ابحث فى المنتدى عن موضوع صفحة رئيسية لاستاذ ابو جودي الى ان وجدت الموضوع طيب المرفق الاول على طريقة ابو جودي والمرفق الثانى من هذا الموضوع والذى يخص الاستاذ Foksh قمت بتعديل بسيط واضافة بسيطة جدا قائمة جانبية على طريقة ابو جودى.zip قائمة جانبية على طريقة الاستاذ Foksh.zip

الملف بعد تحويله لـــ 2003 دون الدخول بأي شئ فقط التحويل . UnMatched.mdb

و عليكم السلام ورحمة الله و بركاته https://www.officena.net/ib/topic/64613-أبغي-قائمة-منسدلة-مرتبطة-بقائمة-منسدلة-أخري-فى-نفس-ورقة-العمل/

تم المطلوب في الملف المرفق... حافز.xlsx

مشاركة مع تنفيذ فكرة أستاذنا @kkhalifa1960 ، وبدلاً من الإعتماد على نموذج فرعي للقائمة الفرعية ، هذا تعديل على الفكرة التي تم طرحها سابقاً ، بحيث تم تطبيقها وكأنها Navigation Form .. الملف المرفق :- Menu Navigations.zip

وعليكم السلام اهلا بك استاذي القدير @ابوخليل في حالة المرفق داخل قاعدة البيانات ..... دائما التعامل يكون بحيلة سواءا لفتح المرفق او عرض المرفق مباشرة .... والحيله هي تصدير المرفق ثم التعامل معه .... في مثالك مثلا والطلب بفتح المرفق مباشرة .... الكود يقوم اولا بتصديره ثم فتحه .... جرب هذا الكود لاني لم افتح القاعدة التي لديك Private Sub cmdOpenAttachment_Click() Dim rs As DAO.Recordset2 Dim rsA As DAO.Recordset2 Dim fld As DAO.Field2 Dim tmpPath As String Dim fileName As String 'افتح السجل الحالي Set rs = Me.Recordset 'اسم الحقل الذي يحتوي على المرفق Set fld = rs.Fields("MyAttachmentField") '← غيّر الاسم حسب جدولك If fld.Value Is Nothing Then MsgBox "لا يوجد مرفق لفتحه.", vbExclamation Exit Sub End If 'افتح المرفق داخل الحقل Set rsA = fld.Value If rsA.RecordCount = 0 Then MsgBox "لا يوجد مرفق.", vbExclamation Exit Sub End If rsA.MoveFirst 'الاسم الأصلي للمرفق fileName = rsA.Fields("FileName").Value 'حدد مسار مجلد مؤقت tmpPath = Environ("TEMP") & "\" & fileName 'احفظ المرفق كملف مؤقت rsA.Fields("FileData").SaveToFile tmpPath 'افتح الملف بالبرنامج الافتراضي FollowHyperlink tmpPath End Sub

أولا اشكر القائمين على هذا المنتدى الرائع في تعليم الاوفيس بجميع برامجه واسأل الله لهم التوفيق والسداد وان يجعل ذلك في ميزان حسانتهم ثانيا بعد توقف المنتدى الأسبوع الماضي وعودته لاحظت ان الملفات في الصفحات القديمة لم تعد تقبل التحميل بعد الضغط عليهابينما سابقا كانت تقبل التحميل كمثال هذان الموضوعان لم استطع تحميل أي ملف فيهما https://www.officena.net/ib/topic/64029-%D8%A7%D9%8A%D8%AC%D8%A7%D8%AF-%D8%A7%D9%83%D8%A8%D8%B1-%D8%AE%D9%85%D8%B3-%D9%82%D9%8A%D9%85/ https://www.officena.net/ib/topic/63972-%D8%AA%D9%86%D8%B3%D9%8A%D9%82-%D8%B4%D8%B1%D8%B7%D9%8A-%D9%84%D8%B1%D9%82%D9%85/ غيرت المتصفح دون جدوى لعلكم تتاكدون هل يمكنكم التحميل فتكون المشكلة لدي ام لا فتكون المشكلة من المنتدى ويتم معالجتها مع خالص الشكر والتقدير

تفضل Sub ToggleColumns() Dim action As String Dim colsInput As String Dim colArray() As String Dim colItem As Variant Dim answer As VbMsgBoxResult Dim invalidInput As Boolean ' مربع حوار لتحديد الإجراء (إخفاء أو إظهار) answer = MsgBox("هل تريد إخفاء الأعمدة؟" & vbCrLf & vbCrLf & "اضغط 'Yes' للإخفاء، 'No' للإظهار.", vbYesNoCancel + vbQuestion, "تحديد الإجراء") If answer = vbCancel Then Exit Sub ' الخروج إذا ضغط المستخدم على "Cancel" ElseIf answer = vbYes Then action = "إخفاء" Else action = "إظهار" End If ' مربع إدخال لطلب الأعمدة من المستخدم colsInput = InputBox("الرجاء إدخال الأعمدة التي تريد " & action & "ها." & vbCrLf & vbCrLf & "أمثلة:" & vbCrLf & "عمود واحد: B" & vbCrLf & "أعمدة متجاورة: B:D" & vbCrLf & "أعمدة متفرقة: B,D,F", "تحديد الأعمدة") ' الخروج إذا كان الإدخال فارغًا If colsInput = "" Then Exit Sub ' إزالة أي مسافات زائدة وتقسيم الإدخال عند الفاصلة colArray = Split(Replace(colsInput, " ", ""), ",") invalidInput = False On Error Resume Next ' تجاهل الأخطاء مؤقتًا للتحقق من صحة الإدخال ' المرور على كل عنصر أدخله المستخدم For Each colItem In colArray If colItem <> "" Then ' التحقق من أن كل جزء من الإدخال يمثل نطاقًا صالحًا If Columns(colItem).Count = 0 Then invalidInput = True Exit For End If End If Next colItem On Error GoTo 0 ' إعادة تفعيل معالجة الأخطاء ' إذا كان هناك إدخال غير صالح، أظهر رسالة خطأ If invalidInput Then MsgBox "الإدخال '" & colItem & "' غير صالح. الرجاء التأكد من إدخال أسماء أعمدة صحيحة.", vbCritical, "خطأ في الإدخال" Exit Sub End If ' تنفيذ الإجراء على كل عمود أو نطاق For Each colItem In colArray If colItem <> "" Then If action = "إخفاء" Then Columns(colItem).Hidden = True Else Columns(colItem).Hidden = False End If End If Next colItem MsgBox "تم " & action & " الأعمدة بنجاح!", vbInformation, "اكتمل الإجراء" End Sub

ألف شكر لك حبيب الملايين 😊🌹🌺🌸

الكود في مشاركتي الاخيرة وافي وكافي ... فقط تضاف هذه الجملة عند اغلاق البرنامج لمن اراد حذف الملف FilePath = CurrentProject.Path & "\" & "soccer.png" Result = Dir(FilePath) If Result <> "" Then Kill FilePath End if وهذا يعني انك لم تفهم عني ما اريد راجع نقاشي مع اخونا فادي

يا هلا اخوي محمد تغيب وتعود سالما غانما هي وحيدة يتيمة

صحيح 100% يجب التعامل كـــ Fields("FileData") ولكني نسيتها

وعليكم السلام ورحمة الله وبركاته.. بالنظر الى الدالة ولهذا السطر تحديداً:- ImagePath = rs!progIcon.Value سيتم التعامل مع المسار على انه نص وليس كحقل مرفقات . لم أطّلع على الملف ، أتابع من الجوال حالياً.

عاشت ايدك معلمنا @Foksh تم حل المشكلة ربنا ينفعنا بعلمك وفي ميزان حسناتك

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

تم الغاء name1 واستبداله باسم الحقل الموجود في الجدول Lieu_Marij في الكود المعدل فنجحت العملية شكرا لك استاذ Foksh ربي يحفظك

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

السلام عليكم محاولة بسيطة... New Microsoft Access Database.rar

سأوافيك بها غدا بحول الله

وعليكم السلام ورحمة الله وبركاته .. استخدم في حدث في الحالي الكود التالي :- If Me.NewRecord Then Me.AllowAdditions = True Me.AllowEdits = True Me.AllowDeletions = True Else Me.AllowEdits = False Me.AllowDeletions = False End If وفي حدث بعد الإضافة للنموذج الحدث التالي :- Private Sub Form_AfterInsert() Me.AllowEdits = False Me.AllowDeletions = False End Sub ملفك بعد التطبيق :- 123452025.zip

الفا مليون شكر الاساتذة الكرام

افتح موضوع جديد ، وارفق ملفك وإن شاء الله تجد حل لمشكلتك .

مشكلتك اخي الكريم في نسخة الأوفيس نفسها. كل الشكر والتقدير للأستاذ @kkhalifa1960 على مساندته بتحويل النسخة للـ 2003 💐

بالفعل مثل ما تفضل الاستاذ : Foksh المشكلة دي مش من Access نفسه قد ما هي من تعريف الطابعة + إعدادات الصفحة المختلفين بين الجهازين وخصوصا مع الهوامش 0 وصورة كاملة صفحة ليه التصميم بيخرب بين الجهازين؟ كل تقرير في Access بيتضبط على خصائص الطابعة الافتراضية وقت التصميم لذلك أي اختلاف في تعريف الطابعة أو نوع الورق/الهوامش يخلي التقرير يعيد حساب المقاسات وتمركز الصورة والكنترولز أغلب تعريفات الطابعات أصلا لا تسمح بهوامش 0 حقيقية فتجبر هامش أدنى (مثلا 3–5 مم من كل جانب) وده اللي يخلي الصورة تتصغر أو تتزحزح ويظهر كأن فيه هوامش رغم إنها 0 في التقرير على ويندوز 7 غالبا تعريف الطابعة مختلف أو إعدادات الـ Page Setup غير اللي على ويندوز 10 ماذا تفعل على كل جهاز افتح التقرير في معاينة قبل الطباعةثم اختر إعداد الصفحة Page Setup تأكد أن: حجم الورقة A4 الهوامش Manual وليست إعدادات خاصة بالطابعة (لو 0 عمل مشاكل استخدم 0.25 سم مثلا واضبط حجم الصورة بحيث تملأ المساحة داخل الهامش) ثبت نفس تعريف الطابعة ونفس الإعداد كـ Default على الجهازين قدر الإمكان Access يعتمد على تعريف الطابعة في حساب عرض وارتفاع التقرير لو حابب يمكن ضبط التقرير بحيث: حجم التقرير نفسه يساوي A4 ناقص أقل هامش تدعمه الطابعة (مثلا عرض 19.7 سم بدل 21 سم) والصورة تمتد داخل هذا المقاس كده هتاخد شكل فول بليد تقريبا على كل الأجهزة بدون ما يتلخبط التخطيط

يا سلااااااااااام عليك .. خطوة جميلة ومفيدة جداً .. أحسن الله إليك مهندسنا الغالي .. يبقى الأمر مرهون بالاتصال بالانترنت ( حتى لو بدون أخطاء عند الإتصال بسيرفر الموقع الذي يغذي النتيجة ) .. جزاكم الله كل الخير ، وأحسن إليك و لوالديك

الأداة رائعة ولكن اشتغلت معي مرة واحدة وبعدها يظهر لي الخطأ: حدث خطأ أثناء الاتصال بخدمة الذكاء الاصطناعي

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

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

وعليكم السلام ورحمة الله وبركاته .. لدي دالة تجلب جميع أرقام الهارد ديسك ( القرص الصلب ) حتى لو كان لديك أكثر من هارد موصول على نفس الكمبيوتر .. Public Function GetAllHardDiskSerials() As String On Error GoTo ErrorHandler Dim objWMIService As Object Dim colDisks As Object Dim objDisk As Object Dim result As String Dim i As Integer Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set colDisks = objWMIService.ExecQuery("SELECT * FROM Win32_DiskDrive") i = 1 For Each objDisk In colDisks If Not IsNull(objDisk.SerialNumber) Then Dim serial As String serial = Trim(objDisk.SerialNumber) If serial <> "" Then result = result & "Disk " & i & ": " & serial & vbCrLf i = i + 1 End If End If Next If result = "" Then GetAllHardDiskSerials = "No serial numbers found" Else GetAllHardDiskSerials = result End If CleanUp: Set objDisk = Nothing Set colDisks = Nothing Set objWMIService = Nothing Exit Function ErrorHandler: GetAllHardDiskSerials = "Error" Resume CleanUp End Function أو هذه الدالة البسيطة أيضاً التي تجلب رقم الهارد الذي تم تثبيت نظام التشغيل ويندوز عليه :- Public Function GetHardDiskSerial2() As String On Error GoTo ErrorHandler Dim objWMIService As Object Dim colDisks As Object Dim objDisk As Object Dim strSerial As String Set objWMIService = GetObject("winmgmts:\\.\root\cimv2") Set colDisks = objWMIService.ExecQuery("SELECT * FROM Win32_DiskDrive") For Each objDisk In colDisks If Not IsNull(objDisk.SerialNumber) Then strSerial = Trim(objDisk.SerialNumber) If strSerial <> "" Then GetHardDiskSerial2 = strSerial Exit For End If End If Next If GetHardDiskSerial2 = "" Then GetHardDiskSerial2 = "Not Found" End If CleanUp: Set objDisk = Nothing Set colDisks = Nothing Set objWMIService = Nothing Exit Function ErrorHandler: Resume CleanUp End Function والإستدعاء فقط في أي مربع نص = اسم الدالة فقط ، كما في الملف المرفق للتوضيح . HD Serial.zip

تفضل جرب مثال1.xlsx

السلام عليكم ورحمة الله إليك هذا الحل باستعمال "الذكاء الاصطناعي" (بالمعادلات وبالأكواد -بتصرف-) أرجو أن يفي الغرض المطلوب... ملف العمل.xlsm

وعليكم السلام تفضل هذا الملف ربما يفيدك ويكون به المطلوب ان شاء الله وبالتوفيق المحطة.xlsm

وعليكم السلام نعم يمكنك فمثلا على افتراض ان هذا الحرف موجود بهذا النطاق (A2:H10) فستكون المعادلة كالتالى : =COUNTA(A2:H10)

تفضل استاذ @RAIANESAMI طلبك حسب ما فهمت بالمرفق . ووافني بالرد . DDFinding Differences.rar

عودا حميدا استاذنا الكريم ضاحى -أحسنت موضوع فى غاية الأهمية بارك الله فيك وزادك الله من فضله

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

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

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