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

بداية اعتذر من استاذي الفاضل في الاستعجال في الرد وعدم انتظار رده @ابو البشر ولكن لي ملاحظة : استخدام مسميات الحقول بالعربية عمل نموذج للترويسة في التقرير ... كان بامكانك جعل نفس الترويسة عن طريق تقرير فرعي على كل حال أنظر المرفق واعلمنا بالنتيجة ..... خط سير.mdb

بالنسبة لعبارة مخزن تجدها في التقرير اما رقم ١ و ٢ و٣ تجدها في الاستعلام لاحظ الصور ... الشرح فيها

السؤال لاستاذنا ابو خليل والموضوع قديم وكان الاجراء الصحيح وضع مشاركة جديدة والاشارة ضمنها لهذا الموضوع ولكن سوف اجيب على اخي وصديقي العزيز ابو اشرف هنا معلمنا حجز متغير من نوع عنصر تحكم لكونه يرغب تطبيق الشرط على كل العناصر في التقرير هذه العناصر في النماذج او التقرير قد تكون مربع نص او قائمة او تسمية او مربع تحرير وسرد او خانة اختيار الخ ..... وهنا قائمة بعناصر التحكم وقيمة كل منهم Name Value Description acAttachment 126 Attachment control acBoundObjectFrame 108 BoundObjectFrame control acCheckBox 106 CheckBox control acComboBox 111 ComboBox control acCommandButton 104 CommandButton control acCustomControl 119 ActiveX control acEmptyCell 127 EmptyCell control acImage 103 Image control acLabel 100 Label control acLine 102 Line control acListBox 110 ListBox control acNavigationButton 130 NavigationButton control acNavigationControl 129 NavigationControl control acObjectFrame 114 Unbound ObjectFrame control acOptionButton 105 OptionButton control acOptionGroup 107 OptionGroup control acPage 124 Page control acPageBreak 118 PageBreak control acRectangle 101 Rectangle control acSubForm 112 SubForm control acTabCtl 123 Tab control acTextBox 109 TextBox control acToggleButton 122 ToggleButton control acWebBrowser 128 WebBrowserControl control وعندما نرغب الاشارة الى عنصر تحكم مثلا ن(عنصر تسميه) ممكن نصرح بنوعه مباشرة فيكون ctli.ControlType = aclabel او نشير الى قيمته بدون تصريح ليكون ctli.ControlType = 100 نعم ممكن ويكون الكود If Len(num.Value) > 55 Then Me.num.FontSize = 7 Else Me.num.FontSize = 12 End If هنا اذا كان عدد الاحرف للحقل الاسم اكبر من 55 يكون حجم الخط 7 وان كان اقل يكون 12 ويمكن اضافة اكثر من شرط النتيجة تكون ظاهرة في معاينة قبل الطباعة للتقرير مرفق مثال بسيط Database1601.accdb

حسب فهمي للمطلوب .. هل هذا الشكل هو المطلوب ؟؟؟؟

هذا طلبك الاول ... قي المرفق ... انظر الصورة .... هذه النقطة معتمده في الاساس عل الاستعلام الذي انت فعلته .... انظر الاستعلام ومن اين اتت هذه المسميات لأنها موجودة في برنامجك اساسا ‏‏DATA144 - kanory.mdb

مشاركة من الاساتذه : طريقة اخرى تمكنك من اختيار مخازن بعينها لتظهر في التقرير ..... جرب ووافينا بالنتيجة ... ‏‏DATA144 - kanory.mdb

السؤال للأخ القناص وهو : كيف يمكنني منع تعديل اي معلومة في نموذج معين اذا مر على ادخال المعلومة 24 ساعة ؟

السلام عليكم ورحمه الله وبركاته لو سمحت لو عندي قاعدة بيانات مقسمة لنصفين نصف نماذج والنصف الاخر القاعدة اي الجداول وتم ارسالها ل 10 عملاء يعملون عليه اي كل شخص عنده نسخة من قاعدة البيانات وليس قاعدة وحده وتم مشاركتها عند الطلب مني اضافة جدول اخر في القاعدة فكيف يتم ذلك اي ارسال له تحديث للقاعدة دون فقد البيانات التي تم تخزينها ؟ ارجو ان تكون فكرتي وضحت (ارسال تحديث لقاعدة البيانات عند العميل )

ويمكنك أيضا استخدام دالة التاريخ: = DateSerial(2020,1,1) وهي (عندي) أفضل من كتابتها بين علامتي الرقم وخصوصا لتجنب الخلط بين اليوم والشهر. كذلك تحتاج أن تجعل نوع الحقل تاريخ فربما النوع عندك نص.

وعليكم السلام ورحمه الله وبركاته @abouelhassan التاريخ يتم كتابته بين علامتى الشباك ## #01/01/2020# بالتوفيق

تم اخى العزيز عاجز عن الشكر وتقبل الله منك صالح الاعمال وجزاك الله خيرا عن صدقاتك

جرب هذا التعديل ووافنا بالنتائج أرجو ان يوافق مرادك ملاحظة: قف علي السجل المراد تحويله ثم اضغط علي الزر وانظر النتائج ولا تنسانا من دعوة بظهر الغيب gov_names.accdb

أولا - فلا شك ان هذا لا يعتبر مشاركة لقاعدة البيانات فكل مستخدم من العشرة لديه بيانات تختلف تماما عن الآخر - وهذا أيضا سيجعل من التعديل علي قاعدة البيانات أو صيانتها أمرا صعبا. ثانيا- فكرتي أن تجعل الجدول الجديد بقاعدة بيانات فارغة تحوي هذا الجدول وفورم واحد به زر واحد بعنوان تحديث قاعدة البيانات هذا القاعدة يتم توزيعها علي العشرة مستخدمين ليضغط كل واحد منهم علي الزر تحديث قاعدة البيانات فماذا يحدث؟!! 👇 مهمة الزر هو تصدير الجدول الجديد الي قاعدة البيانات القديمة وانتهي الأمر تمنياتي بالتوفيق

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

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

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

سهم صغير فى اخر شريط اخيار الاشكال زرار او مربع

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

اردت الاعتذار عن المتابعة بهذا الملف ااسبب التالي في اول مشاركة لك من خلال العبارة التي كتبتها: *** فإذا كان الموظف لديه بند مثلا راتب اساسي ، بدل سكن ، اجمالي الاستحقاق ( هذه ثلاثةبنود ) فإن الموظف سينقل ويكرر ثلاث مرات في الصفوف، بحيث يكون مقابل كل اسم لهذا الموظف البند والمبلغ الخاص به. والان تريد *** اسماء الموظفين في الصفوف لا يمكن تتكرر. بمعنى لا يمكن ان يتكرر اسم الموظف في اكثر من صف لكن بما هي المرة الأولى تم التعديل على الماكرو لبعمل كما تريد الماكرو الجديد (العمل في صفحة Salim ) Sub Enplyee_Data() Dim Target_sheet As Worksheet Dim SA As Worksheet Dim RO%, ROS%, i%, n% Dim How_many%, m%, t%, x% Dim Data As Range Dim Dic As Object, Ky Dim arr_Band(), arr_Num() Application.ScreenUpdating = False Set Target_sheet = Sheets("Salim") Set SA = Sheets("Salary") RO = Target_sheet.Cells(Rows.Count, 1).End(3).Row If RO > 2 Then Target_sheet.Range("A3:H" & RO + 2).Clear End If ROS = SA.Cells(Rows.Count, 1).End(3).Row Set Dic = CreateObject("Scripting.Dictionary") For i = 4 To ROS If SA.Cells(i, 6) <> "" Then Dic(SA.Cells(i, 6).Value) = "" End If Next i If Dic.Count Then m = 3 For Each Ky In Dic.keys n = Application.Match(Ky, SA.Range("f4:f" & ROS), 0) + 3 How_many = Application.CountA(SA.Range("H" & n).Resize(, 60)) Target_sheet.Range("A" & m).Resize(How_many, 6).Value = _ SA.Range("a" & n).Resize(, 6).Value m = m + How_many + 1 Next Ky For x = 3 To m - 2 If Application.CountIf(Target_sheet.Range("F3:F" & x), Target_sheet.Range("F" & x)) = 1 Then n = Application.Match(Target_sheet.Range("F" & x), SA.Range("f4:f" & ROS), 0) + 3 For y = 8 To 67 If SA.Cells(n, y) <> "" Then ReDim Preserve arr_Band(t) arr_Band(t) = SA.Cells(3, y) ReDim Preserve arr_Num(t) arr_Num(t) = SA.Cells(n, y) t = t + 1 End If Next y End If '<> "" If t > 0 Then Target_sheet.Range("G" & x).Resize(t) = _ Application.Transpose(arr_Band) Target_sheet.Range("H" & x).Resize(t) = _ Application.Transpose(arr_Num) End If 't>0 t = 0: Erase arr_Num: Erase arr_Num Next x End If RO = Target_sheet.Cells(Rows.Count, 1).End(3).Row t = 3 If RO > 2 Then For n = 3 To RO + 1 If Target_sheet.Cells(n, 1) = "" Then Target_sheet.Cells(n, "F") = "Sum Of " & Target_sheet.Cells(n - 1, "F") Target_sheet.Cells(n, "F").Resize(, 2).Merge Target_sheet.Cells(n, "H").Formula = _ "=SUM(H" & t & ":H" & n - 1 & ")" t = n + 1 End If Next Target_sheet.Cells(n, "F") = "Sum Of All " Target_sheet.Cells(n, "H").Formula = _ "=SUM(H3:H" & n - 1 & ")/2" Target_sheet.Cells(n, "F").Resize(, 2).Merge With Target_sheet.Range("A3:H" & n) .Font.Size = 14 .Font.Bold = True .Borders.LineStyle = 1 .InsertIndent 1 .Interior.ColorIndex = 35 .Value = .Value .Columns(8).NumberFormat = "#,##0" End With For n = 3 To RO + 1 If Target_sheet.Cells(n, 1) = "" Then Target_sheet.Cells(n, 1).Resize(, 8). _ Interior.ColorIndex = 28 End If Next Target_sheet.Cells(n, 1).Resize(, 8). _ Interior.ColorIndex = 40 End If Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++++ الملف مرفق RAWATEB_ADVANCED.xlsm

السلام عليكم ورحمة الله اخى الكريم لقد فهمت من المشاركة الاولى انك تريد اضافة ورقة لكل موظف ومن ثم اضافة البيانات التى تخصه فقط فى تلك الورقة ان كان فهمى هذا صحيحا فيمكنك استخدام الكودين الاتيين الاول لاضافة ورقة جديدة لاى موظف جديد و الثانى لترحيل البيانات الخاصة به الى ورقته اليك الكود الاول يربط الزر الخاص بتنفيذ الكود بالكود الثانى Sub CreateAcc() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, Rng As Range, C As Range Set ws = Sheets("Salary04 (2)") LR = ws.Range("F" & Rows.Count).End(3).Row Set Rng = ws.Range("F3:F" & LR) On Error Resume Next For Each C In Rng If Len(Trim(C.Value)) > 0 Then If Len(Worksheets(C.Value).Name) = 0 Then Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value End If End If With Sheets(C.Value) .Range("A2:H2") = Array("التسلسل", "رقم المركز", "رقم الموظف", _ "الشهر", "السنة", "اسم الموظف", "البند", "المبلغ") .Range("A2:H2").Font.Size = 14 .Range("A2:H2").Font.Bold = True .Range("A2:H2").Columns.AutoFit End With Next End Sub الكود الثانى ويتم ربطه بالزر Sub TrData() Dim i As Long, wd As Worksheet Dim C As Range, Sh As Worksheet Set wd = Sheets("Salary04 (2)") CreateAcc For Each C In wd.Range("F3:F" & wd.Range("F" & Rows.Count).End(3).Row) x = C.Row i = 7 Do While i <= 100 If wd.Cells(x, i) <> "" Then p = p + 1 With Sheets(C.Value) .Cells(p + 2, 1) = wd.Cells(x, 1) .Cells(p + 2, 2) = wd.Cells(x, 2) .Cells(p + 2, 3) = wd.Cells(x, 3) .Cells(p + 2, 4) = wd.Cells(x, 4) .Cells(p + 2, 5) = wd.Cells(x, 5) .Cells(p + 2, 6) = wd.Cells(x, 6) .Cells(p + 2, 7) = wd.Cells(2, i) .Cells(p + 2, 8) = wd.Cells(x, i) .Range("A2:H" & p + 2).Columns.AutoFit .Range("A2:H" & p + 2).Font.Bold = True .Range("A2:H" & p + 2).Font.Size = 14 .Range("A2:H" & p + 2).Borders.LineStyle = 1 End With End If i = i + 1 Loop p = 0 Next End Sub

جرب هذا الملف 1- القائمة المنسدلة في الخلية j2 ديناميكية اي انها تستحيب لاي تغيير في الداتا مع عدم تكرار الاسماء Option Explicit '+++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() DATA_VAL End Sub '++++++++++++++++++++++++++++++ Sub DATA_VAL() Dim NT As Worksheet Dim SA As Worksheet Dim RON%, ROS%, i% Set NT = Sheets("NEW_TABLE") Set SA = Sheets("Salary") Dim Dic As Object ROS = SA.Cells(Rows.Count, 1).End(3).Row If ROS < 4 Then Exit Sub Set Dic = CreateObject("Scripting.Dictionary") For i = 4 To ROS If SA.Cells(i, 6) <> "" Then Dic(SA.Cells(i, 6).Value) = "" End If Next If Dic.Count Then With NT.Cells(2, "j").Validation .Delete .Add 3, Formula1:=Join(Dic.keys, ",") End With NT.Cells(2, "j").Value = Dic.keys()(0) End If End Sub '++++++++++++++++++++++++++++++++ Sub Fil_Data() Dim Adr1%, Adr2%, X%, m%, k%, ROS% Dim wat, Ro% Dim Find_rg As Range Dim Band As Range Dim Bol As Boolean Dim NT As Worksheet Dim SA As Worksheet Set NT = Sheets("NEW_TABLE") Set SA = Sheets("Salary") NT.Range("A2").CurrentRegion.Offset(1).Clear If NT.Range("J2") = "" Then Exit Sub wat = NT.Range("J2") m = 3 ROS = SA.Cells(Rows.Count, 6).End(3).Row '+++++++++++++++++++++++++++++++++++++++++ With SA.Range("F3:F" & ROS) Set Find_rg = .Find(What:=wat, LookIn:=xlValues, lookat:=1) If Not Find_rg Is Nothing Then Adr1 = Find_rg.Row: Adr2 = Adr1 Do NT.Range("A" & m).Resize(, 7).Value = _ SA.Range("A" & Adr2).Resize(, 7).Value m = m + 1 Set Find_rg = .FindNext(Find_rg) Adr2 = Find_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If End With If m > 3 Then X = 3 With SA.Range("F3:F" & ROS) Set Find_rg = .Find(What:=NT.Range("F3"), LookIn:=xlValues, lookat:=1) If Not Find_rg Is Nothing Then Adr1 = Find_rg.Row: Adr2 = Adr1 Do Bol = False For k = 8 To 67 If SA.Cells(Adr2, k) <> "" Then Bol = True Exit For End If Next k If Bol Then NT.Cells(X, "H") = SA.Cells(3, k) X = X + 1 End If Set Find_rg = .FindNext(Find_rg) Adr2 = Find_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If End With With NT.Range("A3:H" & m - 1) .Font.Size = 14 .Font.Bold = True .Borders.LineStyle = 1 .InsertIndent 1 .Interior.ColorIndex = 35 End With End If End Sub النلف مرفق RAWATEB.xlsm

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

إضغط ALT+F11 دفعة واحدة

السلام عليكم و رحمة الله و بركاته إتبّع أخي الكريم هذه الصور بالترتيب 1 - 2 - 3 فقط كملاحظة إذا كان الأوفيس عندك باللغة العربية ستجد DEVELOPPEUR ....بمعناها "المطوّر"

الخلل أين ..فعلاً لست أدري تفقيط الدينار الجزائري.rar

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

كاتب الموضوع : الأخ أبو حمود: =================== الأخوة اليكم طريقة تغيير خيارات مربع الحوار بدء التشغيل : لتغيير الإعدادات في مربع حوار بدء التشغيل StartUp تم تقسيم تغيير إعدادات مربع حوار بدء التشغيل إلى إجراءين ودالتين لأن عنوان قاعدة البيانات ودليل أيقونة البرنامج يمكن أن يكونا فارغين مما يعطي خطأ في الدالة . (أولا) لتغيير عنوان التطبيق وأيقونة البرنامج : ضع الحدث التالي في المكان المطلوب : Dim intX As Integer Const DB_Text As Long = 10 intX = AddAppProperty("AppTitle", DB_Text, "عنوان جديد") intX = AddAppProperty("AppIcon", DB_Text, "C:WindowsCars.bmp") Application.RefreshTitleBar 1- السطر الثاني : إعلان عن ثابت من النوع Long ويمكنك حذف العبارة السابقة واستبدالها في السطر الثالث بـ dbtext أو db_text أو كتابة رقم 10 في نفس الموضع . 2- السطر الثالث : تم وضع المتغير intX لتخزين القيمة العائدة من الدالة AddAppProperty ، ثم الوسيطة الأولى اسم الخاصية والثانية نوعها والثالثة العنوان الجديد . وللسؤال عن العنوان الجديد ضع السطر التالي : intX = AddAppProperty("AppTitle", DB_Text, InputBox("اكتب العنوان الجديد:")) 3- السطر الرابع : هذا السطر خاص بوضع أيقونة للبرنامج أو تغييرها أو حذفها . ملاحظة : لحذف الأيقونة : intX = AddAppProperty("AppIcon", DB_Text, "") 4- السطر الخامس لغرض ظهور التعديل مباشرة في البرنامج . الحدث السابق يستدعي الدالة التالية : Function AddAppProperty(strName As String, varType As Variant, varValue As Variant) As Integer On Error GoTo AddProp_Err Dim dbs As Object, prp As Variant Const conPropNotFoundError = 3270 Set dbs = CurrentDb dbs.Properties(strName) = varValue AddAppProperty = True AddProp_Bye: Exit Function AddProp_Err: If err = conPropNotFoundError Then Set prp = dbs.CreateProperty(strName, varType, varValue) dbs.Properties.Append prp Resume Else AddAppProperty = False Resume AddProp_Bye End If End Function وعملها يتلخص في البحث عن العنوان أو الإيقونة السابقة في مربع حوار بدء التشغيل ، فإذا لم يجدهما (أي قيمهما في مربع النص الخاص بكل منهما) أو أحدهما يعطي خطأ فيبدأ تنفيذ الأسطر بعد الخطأ ؛ وهي لإنشاء اسم جديد . ولقراءة خاصية العنوان : Dim dbs As Database Set dbs = CurrentDb MsgBox dbs.Properties![AppTitle] dbs.Close (ثانياً) لتغيير بقية خيارات مربع حوار بدء التشغيل : ضع الحدث التالي في المكان المطلوب : 1 Const DB_Text As Long = 10 2 Const DB_Boolean As Long = 1 3 ChangeProperty "StartupForm", db_Text, "اسم نموذج" 4 ChangeProperty "StartupShowDBWindow", DB_Boolean, قيمة 5 ChangeProperty "StartupShowStatusBar", DB_Boolean, قيمة 6 ChangeProperty "AllowBuiltinToolbars", DB_Boolean, قيمة 7 ChangeProperty "AllowFullMenus", DB_Boolean, قيمة 8 ChangeProperty "AllowBreakIntoCode", DB_Boolean, قيمة 9 ChangeProperty "AllowSpecialKeys", DB_Boolean, قيمة 10 ChangeProperty "AllowBypassKey", DB_Boolean, قيمة 11 ChangeProperty "AllowToolbarChanges", DB_Boolean, قيمة 12 ChangeProperty "AllowShortcutMenus", DB_Boolean, قيمة 13 ChangeProperty "StartupShortcutMenuBar", db_Text, "اسم شريط منبثق" 14 ChangeProperty "StartupMenuBar", db_Text, "اسم شريط قوائم" 15 ChangeProperty "HijriCalendar", DB_Boolean, قيمة توضيح العبارات السابقة : 1- السطر الثالث : لاختيار نموذج الذي يفتح عند بدء تشغيل البرنامج (عرض النموذج/الصفحة). لعدم عرض نموذج عند بدء التشغيل استبدل اسم النموذج بالعبارة التالية "(None)" . 2- السطر الرابع : إظهار أو إخفاء إطار قاعدة البيانات (عرض إطار قاعدة البيانات) – True =إظهار وFalse=إخفاء . هو الإطار الذي يحوي كائنات التطبيق من الجداول والاستعلامات والنماذج والتقارير وصفحات البيانات والماكروات والوحدات النمطية . 3- السطر الخامس : لإظهار أو إخفاء شريط المعلومات (عرض شريط المعلومات) – True =إظهار وFalse=إخفاء . هو الشريط الذي يظهر أسفل إطار أكسسس . 4- السطر السادس : المنع أو السماح بأشرطة الأدوات المضمنة (السماح بأشرطة الأدوات المضمنة) – True =السماح وFalse=المنع . عند إزالة العلامة من مربع الخيار هذا ثم إغلاق التطبيق وتشغيله مرة أخرى تختفي كافة أشرطة الأدوات الخاصة بالأكسس وتبقى الأشرطة الخاصة بالتطبيق (التي من إعداد المستخدم) . 5- السطر السابع : المنع أو السماح بالقوائم الكاملة – True =السماح وFalse=المنع . تختفي القوائم الخاصة بالأكسس وتظهر قوائم تختص بالتحرير والطباعة والتعامل مع السجلات والإطارات والتعليمات وهي تفي بحاجة المستخدم من حيث إدخال وعرض البيانات خاصة إذا لم ترغب في إنشاء قوائم خاصة بالتطبيق . 6- السطر الثامن : لمنع المستخدم من الاطلاع على التعليمات البرمجية والأخطاء التي تحدث في وقت التشغيل . 7- السطر التاسع : (استخدام مفاتيح وصول خاصة) لمنع المستخدم من الوصول للمفاتيح التالية : (ALT+F1 (F11), CTRL+F11, CTRL+BREAK, and CTRL+G) فالأولى للوصول إلى إطار قاعدة البيانات والثاني للتبديل بين شريط القائمة المخصص وشريط القائمة المضمن والثالث لإيقاف التعليمات البرمجية والرابع لإظهار إطار التصحيح Dubeg . 8- السطر العاشر : منع المستخدم من إيقاف الماكرو AutoExec أو النموذج الموجود في بدء التشغيل عن طريق ضغطه لـ Shift . 9- السطر الحادي عشر : (السماح بتغييرات أشرطة الأودات / القوائم) يعطل أمر تخصيص في قائمة أدوات وكذلك لايظهر هذا الأمر عند النقر بزر الفأرة الأيمن على قائمة أو شريط أدوات . 10- السطر الثاني عشر : (السماح بالقوائم المختصر الافتراضية) وهي التي تظهر عند النقر على أحد كائنات القاعدة بزر الفأرة الأيسر . 11- السطر الثالث عشر : (شريط القوائم المختصرة) لإظهار شريط قوائم مختصر للتطبيق . ولإزالته : ChangeProperty "StartupShortcutMenuBar", DB_Text, "(default)" 12- السطر الرابع عشر : (شريط القوائم) لإظهار شريط قوائم خاص بالنموذج . ولإزالته نفس السطر ماقبل السابق . 13- السطر الخامس عشر : (استخدام التقويم الهجري) لاستخدام التقويم الهجري أو غيره . — الحدث السابق يستدعي الدالة التالية : Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer On Error GoTo Change_Err Dim dbs As Object, prp As Variant Const conPropNotFoundError = 3270 Set dbs = CurrentDb dbs.Properties(strPropName) = varPropValue ChangeProperty = True Change_Bye: Exit Function Change_Err: If err = conPropNotFoundError Then Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue) dbs.Properties.Append prp Resume Next Else ChangeProperty = False Resume Change_Bye End If End Function طريقة مختصر لتغيير أحد القيم السابقة بعد إنشائها بالدالة السابقة : Dim dbs As Database Set dbs = CurrentDb dbs.Properties!اسم الخاصية = False dbs.Close (التالي كان عبارة عن جدول فيحتاج منكم إلى تنسيق) الاسم في مربع حوار بدء التشغيل اسم الخاصية القيم عنوان التطبيق AppTitle عنوان نصي رمز التطبيق AppIcon دليل إلى ايقونة عرض النموذج/الصفحة StartupForm اسم نموذج من القائمة عرض إطار قاعدة البيانات StartupShowDBWindow True False عرض شريط المعلومات StartupShowStatusBar True False شريط القوائم StartupMenuBar True False شريط القوائم المختصرة StartupShortcutMenuBar True False السماح بالقوائم الكاملة AllowFullMenus True False السماح بالقوائم المختصرة الافتراضية AllowShortcutMenus True False السماح بأشرطة الأدوات المضمنة AllowBuiltInToolbars True False السماح بتغييرات أشرطة الأدوات / القوائم AllowToolbarChanges True False استخدام مفاتيح وصول خاصة AllowSpecialKeys True False عرض أو منع إظهار الكود بعد الخطأ* AllowBreakIntoCode True False منع تجاوز مربع حوار بدء التشغيل وكذلك الماكرو *AutoExec AllowBypassKey True False استخدام التقويم الهجري HijriCalendar True False * الأول والأخير منهما لايوجد لهما أدوات في مربع الخيار وإنما يمكن تعيين قيمهما عن طريق الفيوجل بيسك . ------ ملاحظة : يوجد فى المشاركة التالية فى نفس هذا الموضوع اعادة للشرح بتفصيل أكثر لأبو حمود أيضا -----

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

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

السلام عليكم ورحمة الله وبركاته ================== أرجو أن تقبلونى كعضو جديد فى هذا المنتدى الرائع وأريد معرفة هل المنتدى يسمح للاعضاء الجدد بارفاق ملفات ------------------------------------------------------------------------ يوجد لدى مثال أتمنى أن يفيد الاخوة وهو يقوم بفتح وغلق النموذج بطريقة جميلة (ويستخدم فى نموذج حول البرنامج) ----------------------------------------------------------------------- أتمنى من أساتذتى المشرفين أو الاخوة الكرام بشرح طريقة ارفاق الملفات فى المنتدى لانى لم أعثر عليها وجزاكم اللــــــــه خيرا

السلام عليكم قمت بإنشاء جدول للمبيعات وجدول للمشتريات ، ليتم تسجيل البيانات فيهما وقمت بإنشاء تقرير للمبيعات وبه حقل غير منظم لإجمالي المبيعات، كما قمت بإنشاء تقرير للمشتريات وبه حقل غير منظم لإجمالي المشتريات، وأنشأت تقرير جديد باسم إجمالي الأرباح وبه تقرير المبيعات وتقرير المشتريات كتقارير فرعية، وأنشأت حقل غير للمنظم لحساب إجمالي الأرباح وذلك عن طريق طرح إجمالي المبيعات من أجمالي المشتريات. المشكلة أنه عندما لا توجد بيانات للمبيعات أو المشتريات في فترة معية فإن ناتج إجمالي الأرباح هو #خطأ لماذ؟ وشكرا

السلام عليكم و رحمة الله تحياتي .. :d في أول مشاركة لي أحب ان احيي جميع المشاركين تحية خاصة لمشرف الموقع على هذا المنتدى الجميل أحب ان اسأل عن كيفية كتابة نص بعدة اسطر في خلية واحدة في access هل هذا ممكن ؟ و ما هي الطريقة

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

هذا البرنامج سيساعد فى كتابة سطور الأكسيس حبسما تشاء . أشرف خليل msgbuilder_zip.exe