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

تفضل هذا التعديل بكود واحد فقط ... - لن يستطيع المستخدم الإدخال الا بعد اختيار نوع الفاتورة - جميع الحقول متاحة لكن لن يستطيع المستخدم ادخال البيانات الا بعد اختيار نوع الفاتورة امكانية التسجيل.accdb

تفضل اخي الكريم Me.TotalTime11 = Int(DateDiff("h", Me.TimeIn1, Me.TimeOut1)) Me.TotalTime12 = Int(DateDiff("h", Me.TimeIn2, Me.TimeOut2)) Me.TotalTime13 = Int(DateDiff("h", Me.TimeIn3, Me.TimeOut3)) Me.TotalTime14 = Int(DateDiff("h", Me.TimeIn4, Me.TimeOut4)) Me.TotalTime15 = Int(DateDiff("h", Me.TimeIn5, Me.TimeOut5)) Me.TotalTimeALL = Me.TotalTime11 + Me.TotalTime12 + Me.TotalTime13 + Me.TotalTime14 + Me.TotalTime15 & " ساعة" &&ساعات.rar تحياتي

السلام عليكم ورحمة الله استخدم الكود التالى بدلا من الكود السابق Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, LR As Long Set ws = Sheets("vi") Set Sh = Sheets("DATA") LR = Sh.Range("B" & Rows.Count).End(3).Row + 1 Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B" & LR).Resize(, 3) = Arr End Sub

تم استبدال المرفق بمرفق آخر في مشاركتي السابقة ، ليكون كود نواة 64بت افضل 🙂 ولكن لا تزال مشكلة عدم رجوع البرنامج الى وضعه ، بعد تصغيره جنب الساعة!! جعفر

Make access is more flexible, stable, fast and beautiful Increasing the size and increasing the speed, especially when using on the network, and allowing an increase in the number of users connected at the same time to work with a database .on a local network Certainly everyone wants an increase in the beauty of the interfaces because Access is very poor in that particular part .The problem of stability because sometimes we encounter database corruption The big problem I also hope to solve is the difference in reference numbers according to the versions so that it does not cause this if references with a higher version are used than the .references on another computer if the database is used on a different computer Expand the flexibility of the code editor so that it is easier to use Visual Basic codes more because Access is somewhat poor in that part. Thank you for giving us the opportunity to express the problems we face and the suggestions that we develop in the future to meet our needs in a larger and broader way.

السلام عليكم 🙂 لتعم الفائدة ، رجاء قراءة الطريقة السابقة ، والتي يمكن قراءتها من هنا : https://www.officena.net/ib/topic/107637-اجعل-برنامجك-يعمل-على-النواتين-32بت-و-64بت/ ------------------------------------------------------------------------------------------------------------------ اذا عملنا برنامج على الاكسس 32بت ، وفيه مكتبات الوندوز الـ 32بت (لاحظ الرقم 32 في اسم المكتبة: comdlg32.dll) ، ثم شغلنا البرنامج على اكسس 64بت ، فنحصل على هذا الخطأ : . للعمل بهذه الطريقة محتاجين الى: 1. ملف في موقع مايكروسوف (مرفق نسخة Win32API_PtrSafe.zip) ، وفيه طريقة عمل مناداة النواتين : https://www.microsoft.com/en-us/download/details.aspx?id=9970 وعند فك الملف ، سنستعين بالملف Win32API_PtrSafe.TXT ، 2. البرنامج Notepad++ المجاني ، ويمكن انزاله من هنا : https://notepad-plus-plus.org بعد تنصيب البرنامج ++Notepad ، يمكننا فتح الملف Win32API_PtrSafe.TXT به : هذا البرنامج يفهم تنسيق وعمل الكثير من لغات البرمجة ، ومنها VB ، ونستفيد منه حتى في برمجة كود VBE لأنه يفهم تنسيقها: . ------------------------------------------------------------------------------------------------------------------ سنستخدم المرفق في هذ الرابط لنجعله يعمل على النواتين 32بت و 64بت: https://www.officena.net/ib/topic/61106-هدية-من-اليمين-الى-اليسار،-مربع-القائمة-listbox-والشجرة-treeview/ هذه هي مكتبات 32بت الوندوز المستعمله في المرفق: Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function GetFocus Lib "user32" () As Long Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long . خطوات العمل: A. ننسخ اسم المكتبة GetWindowLong من برنامج الاكسس ، B. ثم في برنامج ++Notepad ، نبحث عن هذه الكلمة عن طريق Ctrl+F ، C. فنضع الكلمة مكان البحث ، وننقر على المربع: Find All in Current Document . D. نرى هذ النافذة تُفتح في اسفل البرنامج ، اهم شيء في هذه النافذه هو ان نفرق بين كلمة البحث التي نريدها ، ونفرقها عن كلمات البحث المشابهه والتي لا علاقة لنا بها (يجب ملاحظة ان بعض البرامج/الامثلة التي ننزلها من الانترنت ، يكون صاحبها عمل تغيير في اسم المكتبة ، مثلا: بدل GetWindowLong يكون apiGetWindowLong ، فيجب ان نعرف انه نفس الاسم ، ونبحث عن الكلمة الاصل ، كما نلاحظ ان تعديل الاسم يتم من بدايته وليس من نهايته) . E. اذن نرى هنا ان آخر سطرين فيهما طلبنا ، F. ندقق في السطر ، ونبحث عن اي كلمة تنتهي بـ Ptr ، مثل LongPtr ، CLngPtr ، VarPtr ، ObjPtr ، StrPtr ، او الكلمات التالية LongLong ، CLngLng ، فاذا وجدناها ، اذن يجب التصريح لهذه المكتبة في الكود في برنامجنا على سطرين مختلفين ، السطر الاول للنواة 64 بت ، ونأخذه من برنرنامج ++Notepad ، والسطر الثاني للنواة 32 بت ، ونأخذه من برنامجنا الاصل ، هكذا : #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long #End If . *** الخطوة الاولى والاهم هي اضافة كلمة PtrSafe بعد كلمة Declare ، للنواة 64بت. *** لاحظ اننا اضفنا كلمة Public في اول السطر للنواتين ، *** وبعد كل خطوة نعملها ، يجب ان نعمل Compile :على الاكسس 32 بت والاكسس 64 بت :حتى نتأكد انه لا توجد اخطاء ونتبع نفس الخطوات اعلاه لبقية المكتبات ، المكتبة التاليه: SetWindowLong ، والنتيجة نفسها مثل المكتبة السابقة ، اذن الكود اصبح #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long #End If . وهكذا مع بقية المكتبات ، فيكون الكود النهائي: #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function InvalidateRect Lib "user32" Alias "InvalidateRect" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr Public Declare PtrSafe Function GetFocus Lib "user32" Alias "GetFocus" () As LongPtr Public Declare PtrSafe Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function GetFocus Lib "user32" () As Long Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long #End If . الآن لنفترض ان لدينا هذه المكتبة كذلك: Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) . نلاحظ في البحث انه لا توجد لدينا اي من كلمات التي ذكرناها في #F اعلاه . اذن نكتب السطر (من برنامجنا ذو 32 بت) نفسه مرتين ، مرة للنواة 64 بت ، ومرة للنواة 32 بت ، فيصبح الكود (الفرق بين السطرين هي كلمة PtrSafe) : #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #Else '32 bits Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #End If او #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #Else '32 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #End If او سطر واحد مستقلا Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) ------------------------------------------------------------------------------------------------------------------ 2021-11-20 : اخوي @عبدالله المجرب نبهني عند استخدام الاكسس 64بت ، يظهور خطأ في مرفق الرابط: https://www.officena.net/ib/topic/64989-هدية-برنامج-تصدير-بيانات-من-جداولاستعلامات-اكسس-الى-اكسل-،-32بت-و-64بت/ لما نعمل Compile للبرنامج على كمبيوتر به اكسس 64بت ، تظهر هذه الرسالة ، واللي معناها مافي توافق في تعريف المتغير (يعني جزء من سطر الكود تم تعريفه بطريقة ، وجزء آخر من سطر الكود تم تعريفه بطريقة لا تتلائم مع المتغير السابق ، وابسط مثال: متغير تم تعريفه كنص ، ثم تعطي قيمته الى متغير آخر تم تعريفه كرقم) : . من الملاحظة ، نرى انه بما اننا نستخدم اكسس 64بت ، فتعريف المكتبة ShellExecute يكون عن طريق (VB7) ، وتعريفها انها LongPtr ، بينما في الكود ، اعطينا قيمة ShellExecute الى المتغير lRet والذي تم تعريفه على انه Long ، لهذا السبب لا يوجد توافق بين المتغيرين ، وعليه نحصل على الخطأ !! هناك حلين للموضوع: إما ان نعمل if VBA7 then# خاص للمتغير lRet لحالتي 32بت و 64بت ، او نحذف تعريف المتغير lRet من الكود ، ونضعه في الاعلى ، مع تعريف المكتبة ShellExecute ، وهذا ما قمت به: . وبعد عمل Comiple مرة اخرى ، نحصل على خطأ مشابه للخطأ اعلاه ، ولكن لمكتبة اخرى : . والحل ، كما عملته للمشكلة السابقة ، فيصبح الكود : . وبعد عمل Compile مرة اخرى ، نجد ان الكود يعمل بدون اخطاء 🙂 ------------------------------------------------------------------------------------------------------------------ 2021-11-23: اخوي @ابا جودى طلب مساعدة في برنامجه ، ليعمل على النواتين: https://www.officena.net/ib/topic/111963-سؤال-بخصوص-التعديل-على-قاعدة-بيانات-لتعمل-على-32-64-bit/ والشيء الجديد فيه والذي لم يتم شرحه سابقا هو: المتغير hIcon (باللون الاصفر) ، تعريفه يعتمد على النواة : . وعندنا هذه الدالة fSetIcon ومعرفها Long ، وفي الدالة ، نعطي نتيجة hIcon الى fSetIcon . المشكلة لما نواة البرنامج تكون 64بت ، فحينها يكون معرف الحقل hIcon هو LongPtr ، بينما الدالة fSetIcon لا يزال معرفها Long ، وهنا نحصل على رسالة خطأ بعدم تطابق معرف الحقلين !! والطريقة التي استعملتها هي: استعمال الدالة مرتين ، مرة بمعرف LongPtr اذا كانت النواة 64بت ، ومرة بمعرف Long اذا لم تكن النواة 64بت : . وعلشان نعرف ان البرنامج تقبل هذا التغيير ، يجب ان نعمل Compile 🙂 جعفر Win32API_PtrSafe (2).zip

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

وعليكم السلام 🙂 ما شاء الله عليك اخوي اباجودي ، جمعت الفريق كله في مكان واحد ، وفي منهم اللي ما يحب يلعب مع صاحبه 🙂 كنت اتمنى ان اقدم شرح ، ولكن هناك الكثير والكثير من التعديلات ، فسأجعلك تتابع التعديلات بنفسك ، واذا في اي سؤال خاص ، ان شاء الله اقدر ارد عليك 🙂 جعفر 8.1.Utilities Hide Ico Minimze To SysTray.accdb.zip

مشاركة مع اخي ابو جودي مجدل data يكون بجوار البرنامج ملفات QR.rar

تفضل هذا التعديل 2222.zip

والله إنك مبدع،، والإبداع يتعلم منك،، شكر الله لك وبارك لك فيما رزقك ووفقك،، جاري التجربة،،

لحذف الفقرات المتشابهة سواء كانت متتالية أو غير متتالية، تفضل هذا الكود: Sub DeleteDuplicates() Dim aRng As Range, aPara As Paragraph, sText As String Set aPara = ActiveDocument.Paragraphs.First Do While aPara.Range.End <> ActiveDocument.Range.End If Len(aPara.Range.Text) > 1 Then sText = aPara.Range.Text Debug.Print sText Set aRng = ActiveDocument.Range aRng.Start = aPara.Range.End With aRng.Find .ClearFormatting .Replacement.ClearFormatting .Text = sText .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll End With End If Set aPara = aPara.Next Loop End Sub وهذا الكود كذلك يقوم بالمهمة السابقة نفسها: Sub DeleteDuplicateParagraphs() Dim p1 As Paragraph Dim p2 As Paragraph Dim DupCount As Long DupCount = 0 For Each p1 In ActiveDocument.Paragraphs If p1.Range.Text <> vbCr Then 'تجاهل الفقرات الفارغة For Each p2 In ActiveDocument.Paragraphs If p1.Range.Text = p2.Range.Text Then DupCount = DupCount + 1 If p1.Range.Text = p2.Range.Text And DupCount > 1 Then p2.Range.Delete End If Next p2 End If 'إعادة تعيين عداد مكرر DupCount = 0 Next p1 End Sub أما لحذف الفقرات المتشابهة المتتالية فيمكنك من خلال بحث واستبدال مع تفعيل خيار (باستخدام أحرف البدل): في خانة البحث اكتب: (*^13)\1 وفي خانة الاستبدال اكتب: \1 أو يمكنك تنفيذ ذلك من خلال الماكرو التالي: Sub DeleteDuplicatesParagraph() Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "(*^13)\1" .Replacement.Text = "\1" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub بالتوفيق أخي العزيز 🙂

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

أشكرك كثير استاذ هو المطلوب بارك الله تعالى فيك مرفق الملف للاستفادة من باقي الاعضاء PASI Deduction.xlsx

=IF(B2="Omani";IF(C2>=3000;3000*0.07;C2*0.07);0) جرب هذه المعادله

مميز كالعادة يا استاذنا جعله الله في ميزان حسناتك

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

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

مرفق اليكم فورمة بالاكسل للحصول على رابط للدخول للواتس بمجرد دخول رقم هاتفك مع مراعاة الاتي 1- ان يكون الرقم مضافاً اليه مفتاح دولتك مع عدم كتابة الصفرين 2- ان يكون الرقم لديه بالفعل واتس للحصول على رابط للدخول للواتس بمجرد دخول رقم هاتفك.xls

تفضل التعديل Database1.accdb

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم Dim db As Object Dim rst As DAO.Recordset Set rst = CurrentDb.OpenRecordset("FILR") rst.AddNew rst.Fields(0) = Nz(DMax("[المعرف]", "FILR"), 0) + 1 rst.Fields(1) = Me.اسم_الموظف rst.Fields(2) = Me.Cat4_Sum rst.Update rst.Close Set rst = Nothing 2222.rar تحياتي

لا تحتاج الى عمل وحدة نمطية اكثر من مرة ولا تحتاج الى تكرار الاكواد بدون داعى فقط لابد من إزالة Exit Function وموقعها في الكود بين الروتين الذى يتم تطبيقه على النماذج والروتين الذى يتم تطبيقه على التقارير ولم يتم تغيير الخط فقط في التقارير بسبب الخروج من الروتين بسبب هذا السطر والأفضل من استخدام On Error Resume Next استخدام كود تصيد الأخطاء ErrorHandler لتتمكن من الوقوف على سبب ومكان وتوصيف ورقم الخطأ وتمت التعديلات كالاتي إزالة Exit Function تغيير اسم الروتين العام حتى يتناسب مع الوظيفة التي يقوم بها ليسهل مستقبلا لأى مطور التعامل بسهولة في قاعدة البيانات إضافة كود تصيد الأخطاء ErrorHandler للوقوف على سبب ومكان وتوصيف ورقم الأخطاء حتى يسهل تفاديها إن وجدت أخطاء إضاقة متغير ثابت في أول الكود ليتم وضع اسم الخط فقط مرة واحدة في الروتين من باب المرونة والتسهيل على المطور ملاحظة هامة جدا جدا لابد من تغير اسم الخط الذى قمت انا باستخدامه في الوحدة النمطية وهو Calibri (Detail) باسم الخط الذى تريد أنت التغيير إليه وقمت بوضع هذا التلميح للتذكير في الوحدة النمطية عند المتغير الثابت الذى يحمل اسم الخط <<---------< Font name must be changed here between the quotation marks يتم استدعاء الكود من خلالChange Font.mdb Call ApplyDefaultFont وأخيرا الروتين والذى يتم وضعه داخل وحدة نمطية Function ApplyDefaultFont() On Error GoTo ErrorHandler Const strFontName = "Calibri (Detail)" ' <<---------< Font name must be changed here between the quotation marks Dim frm As AccessObject Dim rpt As AccessObject Dim dbs As Object Dim frm1 As Access.Form Dim rpt1 As Access.Report Dim ctl As Access.Control Set dbs = Application.CurrentProject ' Apply Default Font for All Forms For Each frm In dbs.AllForms DoCmd.OpenForm frm.Name, acDesign Set frm1 = Forms(frm.Name) For Each ctl In frm1.Controls If ctl.ControlType = acComboBox Or _ ctl.ControlType = acCommandButton Or _ ctl.ControlType = acLabel Or _ ctl.ControlType = acListBox Or _ ctl.ControlType = acOptionButton Or _ ctl.ControlType = acTextBox Then ctl.FontName = strFontName 'Debug.Print frm.Name & " > " & ctl.ControlType & " > " & ctl.Name If frm1.DefaultView = 2 Then frm1.DatasheetFontName = strFontName End If End If Next ctl DoCmd.Close acForm, frm.Name, acSaveYes Next frm ' Apply Default Font for All Reports For Each rpt In dbs.AllReports DoCmd.OpenReport rpt.Name, acDesign Set rpt1 = Reports(rpt.Name) For Each ctl In rpt1.Controls If ctl.ControlType = acComboBox Or _ ctl.ControlType = acCommandButton Or _ ctl.ControlType = acLabel Or _ ctl.ControlType = acListBox Or _ ctl.ControlType = acOptionButton Or _ ctl.ControlType = acTextBox Then ctl.FontName = strFontName 'Debug.Print rpt.Name & " > " & ctl.ControlType & " > " & ctl.Name If rpt1.DefaultView = 2 Then frm1.DatasheetFontName = strFontName End If End If Next ctl DoCmd.Close acReport, rpt.Name, acSaveYes Next rpt Set frm = Nothing Set rpt = Nothing Set dbs = Nothing Set frm1 = Nothing Set rpt1 = Nothing Set ctl = Nothing Exit Function ExitHandler: Exit Function ErrorHandler: MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description End Function وهذا مرفق التطبيق لتعم الفائدة ويكون مرجعا سهلا ان شاء الله Change Font.mdb

طيب مبدئيا انا قمت بعمل بعض التعديلات الطفيفة جدا على الكود لأنه كان يتوقف بعد تغيير خطوط النماذج بسبب Exit Function قمت بإزالتها قمت بتغيير اسم الروتين العام حتى يتناسب مع الوظيفة ليسهل مستقبلا لأى احد معرفتها إضافة كود تصيد الأخطاء لمعرفة التوصيف والرقم المناسب لأى خطأ حتى يسهل تفاديه إضاقة متغير ثابت في اول الكود ليتم وضع اسم الخط فقط مرة واحدة ملاحظة هامة جدا جدا لابد من تغير اسم الخط الذى قمت انا باستخدامه في الوحدة النمطية وهو Calibri (Detail) باسم الخط الذى تريد أنت التغيير إليه وقمت بوضع هذا التلميح للتذكير في الوحدة النمطية عند المتغير الثابت الذى يحمل اسم الخط <<---------< Font name must be changed here between the quotation marks يتم استدعاء الكود من خلال Call ApplyDefaultFont ويتم وضع الكود الاتي في موديول Function ApplyDefaultFont() On Error GoTo ErrorHandler Const strFontName = "Calibri (Detail)" ' <<---------< Font name must be changed here between the quotation marks Dim frm As AccessObject Dim rpt As AccessObject Dim dbs As Object Dim frm1 As Access.Form Dim rpt1 As Access.Report Dim ctl As Access.Control Set dbs = Application.CurrentProject ' Apply Default Font for All Forms For Each frm In dbs.AllForms DoCmd.OpenForm frm.Name, acDesign Set frm1 = Forms(frm.Name) For Each ctl In frm1.Controls If ctl.ControlType = acComboBox Or _ ctl.ControlType = acCommandButton Or _ ctl.ControlType = acLabel Or _ ctl.ControlType = acListBox Or _ ctl.ControlType = acOptionButton Or _ ctl.ControlType = acTextBox Then ctl.FontName = strFontName 'Debug.Print frm.Name & " > " & ctl.ControlType & " > " & ctl.Name If frm1.DefaultView = 2 Then frm1.DatasheetFontName = strFontName End If End If Next ctl DoCmd.Close acForm, frm.Name, acSaveYes Next frm ' Apply Default Font for All Reports For Each rpt In dbs.AllReports DoCmd.OpenReport rpt.Name, acDesign Set rpt1 = Reports(rpt.Name) For Each ctl In rpt1.Controls If ctl.ControlType = acComboBox Or _ ctl.ControlType = acCommandButton Or _ ctl.ControlType = acLabel Or _ ctl.ControlType = acListBox Or _ ctl.ControlType = acOptionButton Or _ ctl.ControlType = acTextBox Then ctl.FontName = strFontName 'Debug.Print rpt.Name & " > " & ctl.ControlType & " > " & ctl.Name If rpt1.DefaultView = 2 Then frm1.DatasheetFontName = strFontName End If End If Next ctl DoCmd.Close acReport, rpt.Name, acSaveYes Next rpt Set frm = Nothing Set rpt = Nothing Set dbs = Nothing Set frm1 = Nothing Set rpt1 = Nothing Set ctl = Nothing Exit Function ExitHandler: Exit Function ErrorHandler: MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description End Function وهذا التطبيق العملي Change Font.mdb

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

تفضل ..... moh.rar وهذا الفلدر به القاعدة المنشأ فيها الجداول .... ضع الفولدر في الدرايف D New folder (2).rar

تفضل اخى الكريم الملف بعد وضع الكود به كشوفات الطلبة للعام 2021-2022.xlsm

السلام عليكم ورحمة الله استخدم هذا الكود Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant Set ws = Sheets("vi") Set Sh = Sheets("DATA") Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B4").Resize(, 3) = Arr End Sub

جزاك الله خيرا استاذنا الفاضل اكثر شىء مهم ارجو ان يفعلوه هو زيادة الحجم وزيادة في السرعة عند الاستخدام على الشبكة وبالتأكيد الكل يريد زيادة في الجماية تحياتي

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

يحب اضافة مكتبةزالاكسس

تفضل التعديل DST.zip

وبصحة وسلامة ان شاء الله 🙂 جعفر

تفضل عدل الحقول التي تريدها من هنا سيتم فقط تصدير الحقول الموجودة داخل هذا الاستعلام تصدير ملف اكسل1.accdb

تفضل التعديل تصدير للاكسيل.zip

تفضل هذا التعديل استيراد ملف نصي.accdb

التعديل في الجدول

تقضل التعديل Desktop.zip

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

منذ ان نشأ بخاطرى عمل برنامج محاسبى بعد عمل دام 200 يوم من تاريخ 10-3-2014م وحتى تاريخ اليوم أقدم لكم هذا البرنامج المتواضع أهداء لكل الاساتذه والاخوة بالمنتدى هو الاصدار الاول من الجزء الاول من برنامج EMA بالادارة المالية ادعو الله ان اكون وفقت بهذا العمل ويكون نفع للجميع أود أن اشكرك كل القائمين على هذا المنتدى هذا الصرح العظيم وكل القائمين علية وأخص بالذكر العلامه القدير / استاذنا / عبدالله باقشير والاستاذ / محمد طاهر والاستاذ الفاضل / رجب جاويش والاستاذ/ عبدالله المجرب والاستاذ / طارق محمود والاستاذة / أم عبدالله والاستاذ / محمود الشريف والاستاذ / حمادة عمر والاستاذ / ضاحى الغريب والاستاذ/ ابراهيم ابوليله والاستاذ / سليم حاصبيا والاستاذ/بن علية حاجى والاستاذ/ محمود حموده وكل الاساتذه بهذا الصرح المبارك جعله الله فى ميزان حسانتكم أتمنى من الاخوة كتابة اى تعليق او ملاحظه او أخطا تم اكتشافه لا يتردد لحظة بمراسلتى سوف اقوم بعملية الشرح لكيفية العمل واستخدام البرنامج وانتظرو الجزء الثانى من البرنامج ( المخازن-والمشتريات-والمبيعات) فى نفس الملف واليكم البرنامج على امتداد XLSB الرقم السرى 123 اتمنى منكم دعوه صادقه من القلب لى ولوالدى EMA.zip

أخي العزيز / أحمد عربي تم تطبيق فورم الأساتاذ الكبير عبد اللله باقشير على الشيت تبعك مأخوذ من الموضوع التالي http://www.officena.net/ib/index.php?showtopic=52482 وهو فورم يصلح لأي ملف معتمداً على عناوين الأعمدة الشيت.rar

السلام عليكم ورحمة الله اليك هذا الملف ربما يكون المطلوب time.rar