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

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

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

أخي ابو ياسين أظنك تريد ظهور نوع القماش و ليس الاسم إذا كان كذلك فالكود سوف يصبح هكذا: Dim i As Integer, y As Integer y = DCount("*", "data", "[komash]& [komash1]& [komash2]& [komash3]& [komash4]& [komash5]& [komash6]& [komash7]like'*[nofatora]*'") DoCmd.GoToRecord , , acFirst For i = 1 To y MsgBox Me.نوع_القماش, vbExclamation, "رسالة" DoCmd.GoToRecord , , acNext Next i و أما إن كانت تريد ظهور اسم الشخص و ليس نوع القماش فأنا تظهر عندي الأسماء بالترتيب و متوافقة تماما مع ما هو موجود بمربع النص بالنموذج

اتفضل ProgAssit24.rar

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

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

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

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة 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 ================================================= رابط مباشر للملف

السلام عليكم ورحمة الله وبركاته اخوتي الكرام ، احببت المشاركة واثراء هذا المنتدى بفكرة وطريقة جديدة لتوزيع الفترات الدراسية على المعلمين خلال اسبوع والفكرة سهلة ويسيرة وقابلة للتطوير والاضافة وتقوم على اعطاء كل حصة رقم معرف فريد يخصها ابتداء من الحصة الأولى لأول يوم حضور وحتى الحصة الأخيرة لآخر يوم دراسي في الاسبوع والعملية تعتمد على جدولين أساسين فقط tblFsl جدول الفصول و tblTechData جدل بيانات المعلم والجدول الثالث tbldivision هو لتوزيع العملية نتيجة العملية استعلامين : 1- جدول الفصول faslTable 2- جدول المعلمين teachersTable ومع المثال يكتفى عن اطالة المقال jadwal.rar

الحمد لله الذي تتم بنعمته الصالحات موفق أخي إن شاء الله

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

السلام عليكم تفضل هذا هو طلبك إن شاء الله Dim rst As DAO.Recordset Dim i As Integer, RC As Integer Set rst = CurrentDb.OpenRecordset("SELECT * FROM [data] where [komash]='" & Me.نوع_القماش & "'") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 1 To RC MsgBox rst!name, vbExclamation, "رسالة" rst.MoveNext Next i و هذا التعديل على المرفق Database81.rar

و فيك بارك الله أخي

ممتاز جدا بارك الله فيك

السلام عليكم آسف على التأخير أخي أبو زاهر لقد قمت بالتعديل على كود المرفق و جعلت إمكانية التحكم بسرعة تقدم الشريط في متغير وحيد اسمه vitesse_progress ادخل على المرفق و غير في كل مرة قيمة هذا المتغير و لاحظ النتيجة مثال (2).rar

تم عمل المطلوب كما تريد عمل 4 ورقات عمل بعد الانتهاء من كتابة أو التعديل في الخليةH36سوف يتم ورقة العمل لورقة العمل( الفاتورة التي تليها) زر واحد اخفاء واظهار.zip

السلام عليكم استعمل هذا الكود في حدث بعد التحديث لمربع نص الباركود: If DCount("*", "[Data]", "[رقم الباركود]=" & Me.Text9) > 0 Then DoCmd.GoToRecord , , acNewRec Me.رقم_الباركود = Me.Text9 Me.المادة = DLookup("[المادة]", "[Data]", "[رقم الباركود]=" & Me.Text9) Me.السعر = DLookup("[السعر]", "[Data]", "[رقم الباركود]=" & Me.Text9) Else MsgBox "هذه السلعة غير موجودة" End If Me.Text9 = Null

تم التعديل في الملف المرفق تفقيط المبالغ بالليرة السورية.xlsm

و فيك بارك الله أخي العزيز

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

اذا اليك هذا ProgAssit23.rar

القي نظرتا الى هذا ProgAssit23.rar

ضع الكود التالي في حدث الورقة سوف يعمل احتواء تلقائي للصفوف والاعمدة .. او ارفع ملف للعمل عليه Private Sub Worksheet_Change(ByVal Target As Range) Cells.Select Selection.Rows.AutoFit Selection.Columns.AutoFit Range("A1").Select End Sub

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

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

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

استاذى الكبير بارك الله فيك

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

الكود السابق MsgBox DLookup("[name]", "data", "komash=" & Me.[نوع القماش]) أولا: يعطيك نفس الرسالة لأن الحقلkomash ليس حقل فريد فيه العديد من القيم المكررة و بالتالي الدالة Dlookup سوف تعطيك أول سجل مطابق و لا تنتقل للسجلات الأخرى لأن الشرط محقق بالسجل الأول هذا بالنسبة لشرح الخطأ لديك. ثانيا: لا أدري المطلوب غير واضح المعالم أتمنى لو تضع مثال أو صورة توضح بها الشكل الذي تريد أن تظهر به النتيجة

السلام عليكم لقد وضعت في الكود اسم مربع نص text40 غير موجود في النموذج الفرعي

جرب هكذا Database81.rar

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

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

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

السلام عليكم من وجهة نظري و حسب تجربتي البسيطة مع هذا الخيار: فأنصحك أخي أن لا تجعل هذا الخيار دائما لأنه سوف يتسبب في تلف البرنامج و خاصة لو كان بصيغة accde

اليك هذا ProgAssit23.rar

اتفضل تقدر استخدم احد اسطر التالية 1 - DoCmd.RunSQL "INSERT INTO Tbl_Entries ( teno ) SELECT DMax(""[eno]"",""[tbl_ehead]"")" او هذا DoCmd.RunSQL "INSERT INTO Tbl_Entries ( teno ) SELECT Max(Tbl_ehead.eno) AS MaxOfeno FROM Tbl_ehead;" واليك المثال بعد تعديل Insert Dmax.accdb

رداً على سؤال حارثة ابو زيد يلزم وقتها هذا الكود Option Explicit '============================== Sub colorize_ALL() Dim x%, k%, i%, m% Dim MY_St1$, MY_St2$, find_txt$ Dim My_Txt Dim Last_Row%: Last_Row = Cells(Rows.Count, 1).End(3).Row If Last_Row < 2 Then Last_Row = 2 MY_St2 = UCase(Range("c2")) Application.ScreenUpdating = False For i = 2 To Last_Row MY_St1$ = UCase(Range("a" & i).Value) With Range("a" & i).Font .ColorIndex = 0: .Underline = False: .Italic = False: .Bold = False End With '================================== For m = 1 To Len(MY_St1) - Len(MY_St2) + 1 find_txt$ = Mid(MY_St1, m, Len(MY_St2)) If find_txt$ = MY_St2 Then With Range("a" & i).Characters(m, Len(MY_St2)).Font .ColorIndex = 3: .Underline = True: .Italic = True: .Bold = True k = k + 1 End With End If Next m i = i + Range("a" & i).MergeArea.Rows.Count - 1 Next i Select Case k Case 0: Range("b2") = "Nothing similar" Case Else: Range("b2") = "There are: " & Chr(10) & k & " Expressions" End Select If k = 1 Then Range("b2") = Mid(Range("b2"), 1, Len(Range("b2")) - 1) Exite_Me: Application.ScreenUpdating = True End Sub الملف مرفق (مغ بعض الشرح في الورقة Sheet1) Full_Saerch_expressions.xlsm

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

تفضل اخي ... ان شاء الله حلينا المشكلة mm u1.rar

استخدم هذا DoCmd.RunSQL "INSERT INTO Tbl_Entries.teno SELECT DMax(""[eno]"",""[tbl_ehead]"")" واذا عطيتك خطأ ارفق نسخة مصغرة من القاعدة

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

وعليكم السلام تفضل مم.accdb

قد استطيع ان اقدم لك العون بهذا البرنامج الصغير الحجز.accdb

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

تفضل خط سير.xlsx

اخي ابو زاهر شوف التعديل الاخير مثال (2).accdb

مبدع استاذ علي . ربي يزيدك من العلم . تحياتي لك يا ورد