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

السلام عليكم ورحمة الله وبركاته تحية طيبة وبعد ... كل عام وأنتم بخير وبصحة وسلامة إن شاء الله .. اتمنى ان يكون عام 2021 عام خير على أمة محمد أجمعين. بالنسبة لموضوعي الذي احببت مشاركتكم إياه فهو نادر مايستخدم ولكن قد يحتاجه احد ما كما احتجت له أنا وهو عملية إجبار المستخدم على ادخال كلمة في مربع نص على ان تكون الكلمة بالعربي وليس بالانجليزي وفي نفس الوقت عدم السماح له بإدخال ارقام في مربع النص وهو الامر عتبر غير شائع الاستعمال في الاكسس لكون ان المستخدم دائماً يكون هو المسؤول عن إدخالاته .. لكن في بعض الأحيان قد تحتاج الى فرض قيود صارمة على المستخدمين العابثين ومنعهم من حرية الاختيار عند ادخال بيانات معينة واجبارهم على ادخال ارقام او حروف انجليزي فقط او عربي .. الخ . إليكم الكود التالي الذي يجبر المستخدم على الكتابة بالعربي فقط في مربع النص .. يتم وضعه في حدث "عند الضغط على مفتاح" Select Case KeyAscii Case 48 To 57, 65 To 90, 97 To 122 ' Numbers and english letters KeyAscii = 0 Exit Sub End Select الارقام من 48 الى 57 هي للأرقام والباقي للحروف الانجليزية تحياتي

تم معالجة الأمر بالنسبة (للبحث فقط) والباقي عليك لضيق الوقت ismail.xlsm

السلام عليكم هل هذا ما تريد اخى بالتوفيق tt.accdb

هذه هي الاخطاء اللي ستأتي للمستخدم اللي عندي نظام انجليزي ، اعمل ملف جديد ، واستورد الكائنات بالترتيب التالي: الجداول ، الاستعلامات ، الماكرو ، الوحدات النمطية ، النماذج ، التقارير ، وبعض الاوقات تضطر ان تستورد كائن كائن ، ولما يعطيك الاكسس خطأ ، فتقوم بمعالجة هذا الكائن ، ثم تستورد غيره 🙂 طريقة اخرى لتغيير كائنات الاكسس : تغيير مسميات كائنا اكسس دفعة واحدة - قسم الأكسيس Access - أوفيسنا (officena.net) هذه احد الطرق ، ولكن مافي داعي استعمالها ، لأنك ستضع في الجدول الجملة بالعربي ، وعلشان خاطرك عملتها لك ، وبدل Debug.Print استعمل msgbox : . ينطبق عليك قول الشاعر : جاءت معذبتي في غيهب الغسق : هذا برنامجك وانت سهران عليه ، وهو معذبك ، فجاوبتني و دمع العين يسبقها ، من يركب البحر لا يخشى من الغرق : هاي احنا الشباب نشجعك (بس دمع العين للدلع 🙂 ) جعفر

هل من الممكن أن يتم إنشاء شيتات تلقائية باسم البيانات الجديدة ممكن هذا الشيء Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Sub ADD_Sheets() Set T = Sheets("تسجيل_الموظفين") Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 8 Then Exit Sub With T For i = 8 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("B" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets T.Select Set Flter_rg = T.Range("A7").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name <> T.Name Then Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy Spes_sh.Range("A7").PasteSpecial (8) Spes_sh.Range("A7").PasteSpecial xlAll End If Next Spes_sh T.AutoFilterMode = False T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub Hatem_new.xlsm

السلام عليكم 🙂 من هذا الموضوع: اليك خلاصة طلبك : . والامر NZ معناه Null to Zero ، اي يحول حقل الـ Null وهو الحقل الذي لم يتم في ادخال اي معلومة ، وهو غير الحقل الذي تكون قد ادخلت فيه معلومة ثم حذفتها ، فالامر الاول يصيد هذه القيمة كذلك 🙂 جعفر

يمكن استخدام دالة NZ() NZ([القيمة])

السلام عليكم ورحمة الله وبركاته اضافة .. بالمعادلات .. sumifs .. اجمالي المبلغ =SUMIFS(D5:D10,C5:C10,"="&C2,B5:B10,"<="&B2,B5:B10,">="&A2) اجمالي الديون =SUMIFS(E5:E10,C5:C10,"="&C2,B5:B10,"<="&B2,B5:B10,">="&A2) SUMPRODUCT اجمالي المبلغ =SUMPRODUCT(--(B5:B10<=B2),--(B5:B10>=A2),--(C5:C10=C2),D5:D10) اجمالي الديون =SUMPRODUCT(--(B5:B10<=B2),--(B5:B10>=A2),--(C5:C10=C2),E5:E10) المبلغ عن مدة.xlsm

1-في شيت تسجيل_الموظفين اترك الصف رقم 6 فارغاً تماما تم اخفاه لعدم الكتابة فيه عن طريق الخطأ 2- في باقي الشيتات اترك الصف رقم 7 فارغاً تماما تم اخفاه لعدم الكتابة فيه عن طريق الخطأ 3- الكود المطلوب Option Explicit Sub My_filter() Dim Ash, Itm Dim Rg As Range Dim Main As Worksheet Dim Ro With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With Ash = Array("التغذية", "تنسيق التعليم الإعدادي", _ "مكتب المدير العام", "شئون الطلبة والامتحانات") Set Main = Sheets("تسجيل_الموظفين") Ro = Main.Cells(Rows.Count, "B").End(3).Row Set Rg = Main.Range("A7").CurrentRegion Main.AutoFilterMode = False For Each Itm In Ash Sheets(Itm).Range("A8").CurrentRegion.Clear Rg.AutoFilter 2, Itm Main.Range("A8:Ar" & Ro).SpecialCells(12).Copy With Sheets(Itm).Range("A8") .PasteSpecial (8) .PasteSpecial (12) With .CurrentRegion .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With End With Next With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With Main.Select Main.AutoFilterMode = False End Sub الملف مرفق Hatem.xlsm

هذا الموضوع بيفيدك

جمع تلقائي اكتب في أول صف فارغ من الخلية B الى الخلية E و عندما تكتمل البيانات في هذا الصف (4 عتاصر يقوم الماكرو بعمله) الصورة توضح ذلك (الملف مرفق) Summation_1.xlsm

جرب هذا الملف تضع في الخلية E1 اي رقم تريد وتطهر لك قائمة منسدلة من 1 حتى هذا الرقم في جال الجطأ الحلية E1 تساوي 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address(0, 0) = "E1" _ And Target.Count = 1 _ And Val(Target) > 0 Then If Target < 1 Then Target = 1 Target = Int(Target) Me.Range("E1") = Target Tajriba End If Application.EnableEvents = True End Sub '++++++++++++++++++++ Sub Tajriba() Dim Mon_Array, s Dim y%: y = Range("E1") s = "Row(" & 1 & ":" & y & ")" Mon_Array = Application.Transpose(Evaluate(s)) With Range("A1").Validation .Delete .Add 3, Formula1:=Join(Mon_Array, ",") End With Range("A1") = 1 End Sub Var_dat_val.xlsm

بالخدمة استاذ ابا جودي نظام التشغيل ويندوز 7 والنواه 64 Bit اضفت المكتبتين لكن نفس المشكلة فقط صوت المراه , صوت المراة مصر ان يحتل المشهد اصل المراه مسيطرة عندي والظاهر ان البرامج عندي تشتغل بنفس برمجتي

نعم ظهرت هذه الرسالة عندي رغم ان صوت المراة هو الشغال

عندى اخطا التاى

لا ما اعرفش ازاى ؟ حبيبى تسلم لى يا قمر شكرا على الاطراء الجميل ☺️ طيب فى رسائل أخطاء ظهرت لحضرتك ؟

يا جماعة الموضوع الاصلى عرض على الشاشة

الكود كما تريد Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Dim RO% Sub ADD_Sheets() Set T = Sheets("تسجيل_الموظفين") Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 8 Then Exit Sub With T For i = 8 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("B" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets T.Select Set Flter_rg = T.Range("A7").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name <> T.Name Then Spes_sh.Range("A7").CurrentRegion.Clear Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy With Spes_sh.Range("A7") .PasteSpecial (8) .PasteSpecial (12) .PasteSpecial (4) End With RO = Spes_sh.Cells(Rows.Count, 1).End(3).Row If RO > 7 Then Spes_sh.Range("A8").Resize(RO - 7).Value = _ Evaluate("Row(1:" & RO - 7 & ")") End If End If Next Spes_sh T.AutoFilterMode = False T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub الملف لآحر مرة و سوف يغلق الموضوع بعد الرد مباشرة لأنه أخذ ما يزيد من الوقت Hatem_Last.xlsm

تم التعديل خطوات العمل كما في الصورة 1- تكتب في التكست بوكس الحرف(الحروف التي تريدها) 2-تحتار من الليست بوكس الصفوف التي تريدها (باستعمال الــ Ctrl أو Shift ) 3- تضغط على الزر Add To sheet 4- عندما يزيد عدد الصقوف (في الشيت) عن العدد 60 يتم التسجيل ابتداء من أول اللائحة (الملف مرفق) ismail_1.xlsm

تفضل أخي Sample filter.accdb

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

انا عندى ويندوز 7 وهذه صورة الرسالة تكرما منك عايزك تدخل على السؤال الذى طرحته اليوم لحسن من الصباح وانا عمال احاول ولم اصل

الحمد لله رب العالمين ...... حياك الله

السلام عليكم هل هذا ما تريد اتفضل اخى جرب ووافنا بالنتيجه Private Sub ÃãÑ19_Click() Dim LastValue As Currency Dim LastID As Integer LastValue = Me.IDX LastID = Me.ID DoCmd.GoToRecord , , acNewRec Me.IDX = LastValue + 0.1 Me.OrderBy = "IDX" DoCmd.FindRecord LastID, , True, , True End Sub بالتوفيق book0001.accdb

بارك الله بك و نفع بعلمك

تفضل .... القسمة على غير العدد.accdb

مرحبا بك اخى واستاذى الجليل ابوخليل 💐 ده حسابى عبر الفيس بوك ادخل به من عالموبايل فى بعض الاحيان ومن عالكمبيوتر احيانا اخرى الحساب الاخر شغال تمام بس كسل اكتب الباسورد فبدخل بده علشان الفيس مفتوح 😀

اخي العزيز الاستاذ احمد ما هذا الحساب الجديد ؟ هل يوجد مشكلة في الحساب الاصل؟

Dim i As Integer i = Me.text1 DoCmd.PrintOut , 1, 3, , i على اعتبار text1 هو اسم مربع النص الكود اعلاه لطباعة الثلاث صفحات الأولى ولصفحة واحدة : DoCmd.PrintOut , 1, 1, , i

السلام عليكم ورحمة الله وبركاته مرفق الملف مرة أخرى مع الحل لمن أراد الإستفادة . مع كامل الشكر والتقدير للأخ الفاضل خيماوي كووول على اهتمامه ومجهوده . جزاه الله كل خير وزاده علما . UP.xlsb

تفضل: A: iIf (Len(strFileNames & "") = 0;0;strFileNames) جعفر

واياكم اخى بالتوفيق

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

السلام عليكم ورحمة الله وبركاته اثراء الموضوع .. في حال اضافة شيت بسمى اخر .. من ضمن مسميات جهة العمل .. يمكن العمل به .. ملف بيانات العاملين(1).xlsm

اذا كان لا بد من الكود Option Explicit Sub My_code() With Range("D2").Resize(, 2) Select Case True Case Range("C2") = vbNullString .Formula = "=SUMPRODUCT(($B$5:$B$50<=MAX($A$2:$B$2))*($B$5:$B$50>=MIN($A$2:$B$2))*D$5:D$50)" Case Else .Formula = "=SUMPRODUCT(($B$5:$B$50<=MAX($A$2:$B$2))*($B$5:$B$50>=MIN($A$2:$B$2))*($C$5:$C$50=$C$2)*D$5:D$50)" End Select .Value = .Value End With End Sub

وعليكم السلام 🙂 . . ثم في حدث عند تنسيق قسم التفصيل Detail من التقرير ، نضع هذا الكود الذي يخفي الحقل الفارغ ويجعل ارتفاعه = صفر اذا كان الحقل فارغ ، وإلا فيتركه كما هو : Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) On Error Resume Next Dim ctl As Control Dim txt As String Dim lbl As String For Each ctl In Me.Controls If ctl.ControlType = acComboBox Then txt = ctl.Name lbl = ctl.Name & "_تسمية" If Me(txt).Text = "" Then ctl.Visible = False ctl.Height = 0 Me(lbl).Visible = False Me(lbl).Height = 0 Else ctl.Visible = True ctl.Height = 0.2188 * 1440 Me(lbl).Visible = True Me(lbl).Height = 0.2188 * 1440 End If End If Next End Sub . والنتيجة . جعفر 1314.الجدولي اليومي.accdb.zip

المعدلة تعمل المبلغ =IF($C$2="الكل";SUMIFS(D5:D18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2);SUMIFS(D5:D18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2;$C$5:$C$18;$C$2)) الدين =IF(C2="الكل";SUMIFS(E5:E18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2);SUMIFS(E5:E18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2;$C$5:$C$18;$C$2)) ودي تعديل للكود لاخي حسين مامون للكل Sub tot() Dim lr, x, to1, to2 Dim Dt1, Dt2 to1 = 0 to2 = 0 Dt1 = [a2] Dt2 = [b2] lr = Cells(Rows.Count, 2).End(3).Row If Cells(2, 3) <> "الكل" Then For x = 5 To lr If Cells(x, 3).Text = Range("c2") Then Select Case Cells(x, 2).Value2: Case Dt1 To Dt2 to1 = to1 + Cells(x, 4).Value to2 = to2 + Cells(x, 5).Value End Select End If Next x ElseIf Cells(2, 3) = "الكل" Then For x = 5 To lr Select Case Cells(x, 2).Value2: Case Dt1 To Dt2 to1 = to1 + Cells(x, 4).Value to2 = to2 + Cells(x, 5).Value End Select Next End If Range("d2").Value = to1 Range("e2").Value = to2 End Sub

على كمبيوتر المبرمج يمكنك كتابة التسمية بالعربي هو جزء من الكود ، فلا ينبغي كتابة اي حرف من اللغة العربية في الكود 1. اليك رابط آخر قد يفيدك: اعمل برنامجك بعدة لغات وببساطة - قسم الأكسيس Access - أوفيسنا (officena.net) 2. مافي تحويل ، تكتبها في الجدول بالعربي 3. ومافي داعي تغيير اي شيء في كمبيوتر المستخدم 🙂 جعفر

المبلغ =IF(C2="الكل";SUMIFS(D5:D18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2);SUMIFS(D5:D18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2;$C$5:$C$18;$C$2)) الدين =IF(c2="الكل";SUMIFS(E5:E18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2);SUMIFS(E5:E18;$B$5:$B$18;">="&$A$2;$B$5:$B$18;"<="&$B$2;$C$5:$C$18;$C$2)) تم التعديل

اهلا عزيزي، بالنسبة لملاحظاتك. 1- من الأفضل جعل جدول التسديد جدول مستقل عن الفواتير، ثم انني قمت بربطه بجدول الحركات لذلك لا مشكلة في ذلك ابداً. 2- بالنسبة لرقم الفاتورة فقط في فاتورة الشراء يكون رقم غير اساسي يعني ان كتبته او لا ليس ذا تأثير كبير ولا اهمية قصوى اما فواتير البيع فأنها لا تحتوي على رقم يُكتب انما رقمها هو Auto_ID 3- في طريقتي هنا فضلت فصل الجدولين عن بعض الموردين والعملاء لان الربط سيكون بجدول واحد وأيضا قد ظهرت لي بعض المشاكل لذلك قمت بفصلهم همسة ( حيالله أهل البصرة ) ❤️

وعليكم السلام ورحمة الله وبركاته تم تغيير المسميات من تشرين الى T2020 و كانون اول الى K2020 .. تم وضع زر لنسخ المطلوب ووضعه في الاكسل الاخر .. T2020 افتح الملفين K2020.xlsm T2020.xlsm

ربما يكون المطلوب Option Explicit Sub tot() Dim lr, x, to1, to2 Dim Dt1, Dt2 to1 = 0 to2 = 0 Dt1 = [a2] Dt2 = [b2] lr = Cells(Rows.Count, 2).End(3).Row For x = 5 To lr If Cells(x, 3).Text = Range("c2") Then Select Case Cells(x, 2).Value2: Case Dt1 To Dt2 to1 = to1 + Cells(x, 4).Value to2 = to2 + Cells(x, 5).Value End Select End If Next x Range("d2").Value = to1 Range("e2").Value = to2 End Sub

في الخلية J2 هذه المعادلة (Ctrl+Shift+Enter) =SUM(IF(MOD(ROW(J$6:J$1000),2)=1,J$6:J$1000,0)) في الخلية J3 استدبل الرقم 1 بالرقم 0 (Ctrl+Shift+Enter) =SUM(IF(MOD(ROW(J$6:J$1000),2)=0,J$6:J$1000,0)) و الان ضع التنسيق الشرطي الذي تريده

تفضل اخي الكريم ستظهر الرسالة المنبثقة عند الثانية 59 من كل دقيقة تستطيع تغيير التوقيت اما بالساعات او الدقائق أو كماهي عليه الأن بالثواني مثال_للرسائل_عند_عداد_الوقت.zip

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

بعد اذن اخي علي هذا الملف Conditional_Rand.xlsm

اهلا بك اخ كريم فى المنتدى كان عليك القيام برفع ملف لكنى قمت بعمل هذا الملف لك للترتيب العشوائى ,ورقة بالكود وورقة بالمعادلة تفضل ترتيب عشوائى للأرقام.xlsm

وممكن تجرب هذا الملف فبمجرد الضغط دبل كليك على اى خلية من العمود الأول A ويكون بداية من الصف السادس سيظهر لك الفورم مباشرة كل عام وانتم بخير ورمضان مبارك Search.xlsm

السلام عليكم 1. من المعروف ان تنسيق النص في مربع القائمة ListBox هو من اليسار الى اليمين ، مشكلة كانت تصادفني دائما ، وهو تنسيق القيم في مربع القائمة لتكون من اليمين الى اليسار بالنسبة للغة العربية (طريقة تغيير مربع القائمة الى مربع تحرير ونص ، ثم عمل التنسيق عليه من اليمين الى اليسار ، ثم اعادته الى مربع قائمة لا يعمل معظم الوقت) ، موقع http://www.lebans.com والذي يحتوي على مالذ وطاب عنده طريقه لهذا التنسيق: http://www.lebans.com/justicombo.htm كذلك. 2. ونفس المشكلة مع موضوع تنسيق الشجرة TreeView من اليمين الى اليسار. النتيجة: و وطريقة العمل ، يوضع هذا الكود في وحدة نمطية: Option Compare Database Option Explicit #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" (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" () As LongPtr Public Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr Dim hwnd 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 Dim hwnd As Long #End If Public Const GW_CHILD = 5 Public Const WS_EX_LAYOUTRTL = &H400000 Public Const GWL_EXSTYLE = (-20) Function RTL_Set(frm As Form, ctl As Control) Dim varHwnd As Variant Dim OldLong As Long frm.SetFocus ctl.SetFocus varHwnd = GetFocus() OldLong = GetWindowLong(varHwnd, GWL_EXSTYLE) SetWindowLong varHwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False End Function Function RTL_SetTree(frm As Form, ctl As Control) Dim OldLong As Long OldLong = GetWindowLong(ctl.hwnd, GWL_EXSTYLE) SetWindowLong ctl.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False End Function ' ' From http://www.microsoft.com/middleeast/msdn/faq.aspx ' 'Place OnLoad of the Form ' Dim OldLong As Long 'For Form ' OldLong = GetWindowLong(Me.hwnd, GWL_EXSTYLE) ' SetWindowLong Me.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For List ' OldLong = GetWindowLong(List1.hwnd, GWL_EXSTYLE) ' SetWindowLong List1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For The StatusBar ' OldLong = GetWindowLong(StatusBar1.hwnd, GWL_EXSTYLE) ' SetWindowLong StatusBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For TreeView ' Dim nodX As Node ' Set nodX = TreeView1.Nodes.Add(, , "R", "Root") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4") ' nodX.EnsureVisible ' OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE) ' SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ListView ' OldLong = GetWindowLong(ListView1.hwnd, GWL_EXSTYLE) ' SetWindowLong ListView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ProgressBar ' ProgressBar1.Value = 50 ' OldLong = GetWindowLong(ProgressBar1.hwnd, GWL_EXSTYLE) ' SetWindowLong ProgressBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ToolBar ' mhwnd = GetWindow(Toolbar1.hwnd, GW_CHILD) ' OldLong = GetWindowLong(mhwnd, GWL_EXSTYLE) ' SetWindowLong mhwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False في اسفل الكود انا تركت الكود لبقية الاشياء اللي يمكن عملها من اليمين الى اليسار. اما تنفيذ التنسيق لمربع القائمة ، فهو وضع هذا الكود عند تحميل النموذج الذي يحتوي على هذا المربع (وهنا اسم حقل مربع القائمة هو List0_RTL ) : 'ListBox RTL Call RTL_Set(Me, List0_RTL) وتنسيق الشجرة ، فهو وضع هذا الكود عند تحميل النموذج الذي يحتوي على الشجرة (وهنا اسم الشجرة هو TreeView1) : 'TreeView RTL Call RTL_SetTree(Me, TreeView1) وللأمانة العلمية ، فاني استخدم قاعدة البيانات التي وضعها الاخ محمد في الرابط: http://www.officena.net/ib/index.php?showtopic=60781 جعفر تعديل 1: 18-11-2021 ، جعل البرنامج يعمل على النواتين 32بت و 64 بت 54.RTL_TreeView_ListBox_32bits_n_64bits.accdb.zip

سأعرض الحل هنا مع توضيح بعض النقاط المهمة فالجملة البرمجية التي تستخدم لفتح ثم طباعة الصفحات المحددة من التقرير DoCmd.OpenReport stDocName, acPreview DoCmd.PrintOut acPages, pageFrom, pageTo لا تقوم بالمهمة كما ينبغي وكما رسمت له فمن المعلوم ان تنفيذ هذا الكود سيكون من خلال النموذج لذا يصعب التنفيذ بل يمتنع وتظهر بعض العقبات غير المتوقعة فمنها : - طباعة النموذج بدلا من التقرير وقد يتم طباعة الاثنين معا - عدم طباعة الصفحات المحددة وانما يتم طباعة الجميع - هذا الكود يقوم بفتح التقرير وهذه مشكلة بحد ذاتها حيث يستلزم اخفاؤه او تصغيره ثم غلقه وهل هناك بديل ؟ نعم وهو يقوم بكل لطف وصمت بطباعة صفحات محددة من تقارير عدة والحل سطران فقط ومن اراد الزيادة فعليه ان يكررهما ما شاء الاول يقوم بتحديد التقرير لا فتحه DoCmd.SelectObject acReport, "استقطاعات", True والثاني لطباعة الصفحات المحددة DoCmd.PrintOut , 14, 13, , 1 رقم 1 يمثل عدد النسخ في المرفقات تحقيق وتطبيق طباعة واختيار الصفحات من عدة تقارير.rar