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

السلام عليكم ورحمة الله تعالى وبركاته اقدم هذا الموضوع وهذه المشاركة بناء على سؤال فى هذا الموضوع اتأخرت فى الرد على الرغم من انى كان ممكن ارد فى اقل من عشر دقائق الا اننى احببت عمل مصال شامل وكاف وواف 1- الفرز تصاعديا او تنازليا لكل حقل على حده 2- تصفية السجلات بناء على قيمة مربع تحرير وسرد 3- امكانية التصفية المتعدده بناء على اكثر من قيمة من امثر من مربع تحرير وسرد 4- الغاء تصفية السجلات وعرضها جميعا والان اترككم مع المرفق مثال شامل على طريقة الفرزتصاعديا وتنازليا والتصفيه .rar

كل عام وانتم بالف خير عيدكم سعيد

السلام عليكم و رحمة الله تعالى و بركاته إخوتي الكرام حياكم الله و تقبل الله منا و منكم الصيامكم و القيام أضع بين أيديكم طريقة إنشاء نسخة تجريبية و حمايتها و قابلية تفعيلها و كل هذا بتوظيف الرجستري. خصائص البرنامج: 1- يكتشف إرجاع التاريخ 2- حتى لونزلت نسخة ثانية بعد إنتهاء التفعيل أو إنتهاء النسخة التجريبية فلن تعمل لأن الحماية مخزنة بالرجستري 3- رقم التفعيل يتغير من يوم إلى آخر حسب التاريخ 4- تستطيع تفعيل البرنامج بعد إنتهاء التفعيل بنفس النسخة 5- يحذف البرنامج الجدول الذي به رقم النسخة و كود الحماية مباشرة بعد أول تشغيل 6- يعطيك في أول تشغيل فترة تجريبية تحددها انت كما تشاء 7- رقم التفعيل مخبأة في مكان بالرجستري لا يمكن الحصول عليه هذا هو المرفق و أتمنى من الأعضاء أن يقوموا بتجربة المرفق و إعطائنا النتائج و من بعدها نقوم بشرح أكواد البرنامج: فترة تجريبية1.rar

السلام عليكم ورحمة الله أخواني الكرام وعلمائنا وأساتذتنا العباقرة في هذا الصرح العملاق والأكثر من رائع بعد إنتهاء ولله الحمد من برمجة برنامج شؤون الموظفين والمرتبات ونشره في الموقع منذ فترة وجيزة على هذا الرابط برنامج شؤون وإدارة الموظفين بحلته وشكله الجديد أحببت اليوم بعد طلبات من الاصدقاء أن أقوم برفع البرنامج مفتوح المصدر لكي تتم الفائدة منه في كافة النواحي العلمية والعملية وذلك من (خلال الكودات وطريقة التصميم) ماعليكم سوا فك الضغط عن الملف المرفق وتنصيب البرنامج بكل سهولة وفي الاخير تفعيل الماكرو يعمل البرنامج على كافة أنظمة ويندوز وكافة نسخ أوفيس من 2007 ومافوق لاتنسونا من الدعاء بظهر الغيب في هذه الايام المباركة Office Soft.Employ & Salary V2.0.4.zip

نعم أستاذ شيفان.. إليك الوظيفة التالية Function GetNumbersOnly(SText) Dim Numbers For i = 1 To Len(SText) If IsNumeric(Mid(SText, i, 1)) Then Numbers = Numbers & Mid(SText, i, 1) End If Next GetNumbersOnly = Trim(Numbers) End Function New Microsoft Access Database.zip

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

اليك هذا الحل لعل يفيدك اولا عملت استعلام للاسماء اللي في جدول الموظفين وليس موجودين في جدول الرواتب وهذا هو الاستعلام SELECT persons.* FROM persons LEFT JOIN Salary ON persons.[EmpNumber] = Salary.[EmpNumber] WHERE (((Salary.EmpNumber) Is Null)); وعملت نموذج عليه واستخدمت هذا الكود لزر Private Sub Command0_Click() Dim MyCount As Integer MyCount = DCount("*", "personsWithoutMatchingSalary") If MsgBox("هناك ( " & MyCount & " ) اسماء لم يكن في جدول الرواتب .. هل تريد ان تنظر الى اسماءهم ", vbYesNo, "تنبيه") = vbYes Then DoCmd.OpenForm "personsWithoutMatchingSalary", acNormal End If End Sub اليكي المرفق bmn.rar

إخوتى الكرام .. الملف التالى يتناول شرح الدوال الإحصائية .. اتمنى ان يمثل إضافه بسيطة .. وكل عام وانتم بخير .. المرفقـــات الدوال الاحصائية.rar

اتفضل اليك وحدة نمطية هذا Function DeleteAll() On Error Resume Next Dim db As Database Dim idx As Long Dim strName As String Set db = CurrentDb ''Relationships For idx = db.Relations.Count - 1 To 0 Step -1 strName = db.Relations(idx).Name If Left(strName, 4) <> "msys" Then db.Relations.Delete strName Else Debug.Print strName End If Next idx ''Forms For idx = CurrentProject.AllForms.Count - 1 To 0 Step -1 strName = CurrentProject.AllForms(idx).Name DoCmd.DeleteObject acForm, strName Next idx ''Macros For idx = CurrentProject.AllMacros.Count - 1 To 0 Step -1 strName = CurrentProject.AllMacros(idx).Name DoCmd.DeleteObject acMacro, strName Next idx ''Reports For idx = CurrentProject.AllReports.Count - 1 To 0 Step -1 strName = CurrentProject.AllReports(idx).Name DoCmd.DeleteObject acReport, strName Next idx ''Queries For idx = db.QueryDefs.Count - 1 To 0 Step -1 strName = db.QueryDefs(idx).Name If Left(strName, 4) <> "~sq_" Then db.QueryDefs.Delete strName Else Debug.Print strName End If Next idx ''Tables For idx = db.TableDefs.Count - 1 To 0 Step -1 strName = db.TableDefs(idx).Name If Left(strName, 4) <> "msys" Then db.TableDefs.Delete strName Else Debug.Print strName End If Next idx ''Modules For idx = CurrentProject.AllModules.Count - 1 To 0 Step -1 strName = CurrentProject.AllModules(idx).Name If strName <> "Module5" Then DoCmd.DeleteObject acModule, strName End If Next idx End Function وفي النموذج ليس لديه مصدر في خلف زر مثلا او اي حدث اكتب Call DeleteAll

احتمال يكون الخلل من تفعيل بعض خصائص قاعدة البيانات الصورة في المرفقات هي لخيارات قاعدة بيانات mdb ابحث عن الخاصية المحاطة بالمربع الاحمر في الخيارات الخاصة بالاصدار الذي تعمل عليه ثم ازل العلامات من مربع الخيار ان وجدت ثم اغلق قاعدة البيانات وافتحها من جديد

كثرت في الآونة الأخيرة تساؤلات (في الحقيقة لم يكن سوى تساؤل واحد فقط) عن كيفية تصدير البيانات من أكسس إلى وررد وإن شاء الله سوف نعمل سويا للوصول لأفضل وأبسط وأسرع الطرق لتحقيق ذلك ونرجو الجميع المشاركة في تحديث الكود باضافة أكثر من طريقة للتصدير أو بابتكارات جديدة تخص الموضوع وبالمرفق المحاولة الأولى : التصدير لقالب وررد جاهز لاستقبال بيانات محددة من النموذج export to word template.rar

العمود expr1 تم فيه ضم جميع حقول النتائج وهو بيت القصيد وفي الكود اشترطنا تكون القيمة اكبر من 3 حروف حتى نضمن وجود قيمة حقيقية فيما لو كانت القيمة صفر مثلا وطبعا هي افضل من ان يكون الشرط عدم وجود : Null نأتي الى الكود البرمجي وهو كما ذكرت ثلاث خيارات : IIf([Status_code]=1 And [code_kind_edu]<>4 And Len([Expr1])>=3;"راسب وله حق الاعادة" اذا الحالة =1 والنوع لا يساوي 4 و حقل اكسبر فيه قيمة اكبر من 3 حروف فالنتيجة= راسب وله حق الاعادة IIf([Status_code]=2 And Len([Expr1])>=3;"راسب وليس له حق الاعادة" اذا الحالة =2 و حقل اكسبر فيه قيمة اكبر من 3 حروف فالنتيجة= راسب وليس له حق الاعادة IIf([Status_code]=1 And [code_kind_edu]=4 And Len([Expr1])>=3;"راسب" اذا الحالة =1 والنوع = 4 و حقل اكسبر فيه قيمة اكبر من 3 حروف فالنتيجة= راسب وان لم تتحقق هذه الشروط فهو ناجح دور ثاني بقي شيء لم اذكره وهو ان عمود Expr1 تم اخفاؤه ، ومع ذلك فهو ظاهر في التصميم لاظهاره افتح الاستعلام على العرض وبزر الفأرة الايمن انقر على الاطار العلوي للاستعلام ثم اختر اظهار اعمدة

المشكلة ان الزر رقم 4 يقابله الرقم 52 وليس 100 استبدل الرقم 100 الموجود بالكود بالرقم 52 وإليك هدية ارقام لوحة المفاتيح ارقام لوحة المفاتيحKey ASCII Values.rar

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

السلام عليكم شباب عيدكم مبارك وايامكم سعيدة ان شاء الله جعفر

كل عام وانتم بخير

وعليكم السلام هذه طريقتي: Private Sub ÃãÑ56_Click() Dim a_rr As Error Dim X As String On Error GoTo a_rr X = InputBox("enter text", "text ") If Len(Trim(X)) = 0 Then MsgBox "error " Exit sub end if For i = 1 To Len(X) If IsNumeric(Mid(X, i, 1)) Then MsgBox "contains Numbers" Exit Sub End If Next i DoCmd.OpenReport "Rep_sadder", acViewPreview, , "Go_sad like '" & X & "'" Exit Sub a_rr: MsgBox " error " End Sub جعفر

اتفضل اضفت حقل رقم في مربع تحرير وسرد وغيرت هذا السطر من البحث rs.FindFirst "[رقم الملف] = " & Me![مربع_تحرير_وسرد96].Column(1) في حدث بعد تحديث و عند الحالي ايضا اليك ملف بعد تعديل test5.rar

استاذنا @عبد الفتاح كيرة هل ما وضحت ما قلت في مشاركتي السابقة اتفضل اليك هذا اذا ما كان اخطأت بما تريد تم تعديل test17.rar

اتفضل استخدمت هذه الكود للاستخراج اي للبحث Private Sub SEr_Click() Me.s2 = DLookup("[name_e]", "Emp", "no_e= " & [s1]) Me.s3 = DLookup("[ms_j]", "Emp", "no_e= " & [s1]) Me.s4 = DLookup("[rs_t]", "Emp", "no_e= " & [s1]) Me.s5 = DLookup("[no_e]", "Emp", "no_e=" & [s1]) Me.Tarix = Nz(DMax(Format("[d_g]", "yyyy/mm/dd"), "egaza", "no_e=" & [s1] & "and [n_e]='" & "ÚÇÏíÉ" & "'"), "") Me.Mide = Nz(DLookup("[m_g]", "egaza", "[no_e]=" & [s1] & " And [Tarix]=" & Format("[d_g]", "yyyy/mm/dd")), 0) End Sub وهذا لخصم الرصيد من الاجازة Private Sub أمر30_Click() Dim SQL As String SQL = "UPDATE Emp SET Emp.rs_t = [Emp]![rs_t]-[Forms]![H]![Mide] WHERE (((Emp.no_e)=[Forms]![H]![s1]));" DoCmd.SetWarnings False DoCmd.RunSQL (SQL) DoCmd.SetWarnings True MsgBox "تم الخصم من الرصيد" End Sub اليك المرفق LM.rar

السلام عليكم لماذا لا تستعمل مربع تحرير و سرد واحد و تضع به اسماء جميع التقارير و تضيف الكود التالي في حدث بعد التحديث: Private Sub ãÑÈÚ_ÊÍÑíÑ_æÓÑÏ1_AfterUpdate() DoCmd.OpenReport me.imperition, acViewPreview End Sub بحيث imperition اسم مربع تحرير و سرد فعندما تختار اسم أي تقرير يقوم الكود بفتح هذا التقرير

شكرا استاذنا شيفان وهذه الاكواد حسب طلبك الغاء من الخيارات Application.SetOption "Confirm Action Queries", 0 Application.SetOption "Confirm Document Deletions", 0 Application.SetOption "Confirm Record Changes", 0 اجعلها في حدث تحميل نموذج البداية وهذه لارجاع التحذير Application.SetOption "Confirm Action Queries", 1 Application.SetOption "Confirm Document Deletions", 1 Application.SetOption "Confirm Record Changes", 1 يمكنك جعلها في حدث اغلاق النموذج ان شئت

السلام عليكم اولا اعتذر من الاستاذ ابا خليل وتطفلت بان حاولت اطبق فكرته وقد يكون الواقع والذي في باله غير ذلك وهذه ضحايا الموانة الزايدة اخي جمال شكرا واعتقد انك تستحق خبير من الان ومن خلال قرائتي لمشاركاتك اخي الزهراني جرب الاستعلام التالي وكمصدر للنموذج : اي اذهب لمصدر النموذج والصق هذا الاستعلام بديلا لمصدر السابق ثم اذهب لعرض التصميم للاستعلام لتختبر المحاولة وهل هي لما تريد وتقصد SELECT Table1.ID, Table1.User, Table1.Section, Table1.Status FROM Table1 WHERE (((IIf(IsNull([forms]![Form1]![SectionSearch]),1,InStr(1,[Section],[Forms]![Form1]![SectionSearch])))>0) AND ((IIf(IsNull([forms]![form1]![UserSearch]),1,InStr(1,[user],[Forms]![Form1]![UserSearch])))>0) AND ((IIf(IsNull([forms]![form1]![StatusSearch]),1,InStr(1,[status],[Forms]![Form1]![StatusSearch])))>0)); بالتوفيق

سيبك من الأجانب دول تفكيرهم تقليدي 1 + 1 = 2 وده طبعا مينفعش معانا لازم تبتكر يعني مثلا 1+1 = 3 - 1 المهم فكرة الدالة على السريع إنها بتشوف القيم المسجلة في المربعات الثلاثة مجتمعة وبناءا على تلك القيم يتم انشاء كود استعلام ثم نجعله مصدر النموذج لذلك لكي تطبق الدالة عليك أولا أن تختار مصدر بيانات النموذج هو الجدول وثانيا تكتب الكود التالي في محرر الفيجوال بيسك وجرب واعمل أكثر من تجربة مرة قيمة خالية هنا ومرة قيمتين خاليتين هناك وهكذا Option Compare Database Dim strSQL, a, b, c As String Private Sub SectionSearch_AfterUpdate() rs End Sub Private Sub StatusSearch_AfterUpdate() rs End Sub Private Sub UserSearch_AfterUpdate() rs End Sub Function rs() strSQL = "" a = strSQL & IIf(Nz(Me.UserSearch, 0) = 0, "", " (Table1.User) Like '*" & "" & Me.UserSearch & "" & "*'") b = strSQL & IIf(Nz(Me.SectionSearch, 0) = 0, "", " (Table1.Section) Like '*" & "" & Me.SectionSearch & "" & "*'") c = strSQL & IIf(Nz(Me.StatusSearch, 0) = 0, "", " (Table1.Status) Like '*" & "" & Me.StatusSearch & "" & "*'") If Nz(Me.UserSearch, 0) = 0 And Nz(Me.SectionSearch, 0) = 0 And Nz(Me.StatusSearch, 0) = 0 Then Me.RecordSource = "SELECT Table1.ID, Table1.User, Table1.Section, Table1.Status FROM Table1; " Else strSQL = "SELECT Table1.ID, Table1.User, Table1.Section, Table1.Status FROM Table1 WHERE " If Nz(Me.UserSearch, 0) <> 0 Then strSQL = strSQL & a If Nz(Me.SectionSearch, 0) <> 0 Then strSQL = strSQL & " and " & b If Nz(Me.StatusSearch, 0) <> 0 Then strSQL = strSQL & " and " & c Else If Nz(Me.StatusSearch, 0) <> 0 Then strSQL = strSQL & " and " & c End If Else If Nz(Me.SectionSearch, 0) <> 0 Then strSQL = strSQL & b If Nz(Me.StatusSearch, 0) <> 0 Then strSQL = strSQL & " and " & c Else If Nz(Me.StatusSearch, 0) <> 0 Then strSQL = strSQL & c End If End If Me.RecordSource = strSQL End If Me.Requery End Function

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

السلام عليكم تفضل أخي هذا هو الكود Dim str_code As String Dim name_frm As String Dim frm As AccessObject, dbs As Object Set dbs = Application.CurrentProject For Each frm In dbs.AllForms name_frm = frm.Name DoCmd.OpenForm name_frm, acDesign str_code = "Private Sub Form_Load()" & vbCrLf & _ "call Color_V(me)" & vbCrLf & _ "end sub" Forms(name_frm).Module.AddFromString str_code DoCmd.Close acForm, name_frm, acSaveYes Next

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

عزيزي هذا الكود للمطلوب وعند النقر المزدوج على عنصر البحث Private Sub txt_Search_DblClick(Cancel As Integer) DoCmd.OpenReport "report", acViewPreview, , Me.Filter End Sub ولكن اسمحولي براي هنا ادارة المنتدى تسعى جاهدة لتقليل المواضع المكرره خصوصا في فترات متقاربة . هنا العتب اكثر على الاساتذة حيث هم اولى بالاشارة الى الموضوع وخصوصا لو اصبح في فتره متقاربة جدا فهنا نفس الموضوع بالتمام تحياتي

If MsgBox("هل تريد حذف هذا السجل ؟", _ vbCritical + vbYesNo, _ "تحذير") = vbYes Then DoCmd.RunCommand acCmdDeleteRecord Else Exit Sub @Shivan Rekany

السلام عليكم جميعا يمكنك فعل ذلك عن طريق الحشر بالطريقة التالية Object.[event]="=MsgBox('Say Something')" يمكنك استخدام جميع وظائف أكسس، أو إنشاء وظائف خاصة، كما يمكنك استخدام الميكرو أيضا تنبيه الإجراءات ()SUB لا يعمل هنا لأنه لا يقبل الاسناد! إليك مرفق الاستاذ أبو خليل بعد التعديل db1.zip

استأذن من استاذنا @Gamal.Saad واستأذن من استاذي الحبيب @رمهان اتفضل القي نظرتا الى الصورة انا غيرت مصدر كومبوبوكس والكود اصبح Private Sub comb_Search_AfterUpdate() On Error Resume Next Me.Filter = "[" & (Nz(comb_Search, "رقم المستفيد")) & "]" & " Like ""*" & FindAsType & "*""": Me.FilterOn = True End Sub Private Sub txt_Search_Change() On Error Resume Next FindAsType = txt_Search.Text Me.Filter = "[" & (Nz(comb_Search, "رقم المستفيد")) & "]" & " Like ""*" & FindAsType & "*""": Me.FilterOn = True txt_Search.SetFocus txt_Search = FindAsType txt_Search.SelStart = Len(FindAsType) End Sub واليك المرفق بعد تعديل مثال .rar

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

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

السلام عليكم تفضل تم التعديل كما طلبت بالصورة عد نوع التعليم.rar

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

تفضل تم التعديل مشكلتك تكمن في اختلاف مسمى الصف بين الجدولين فأنا اعتمدت اسم الصف في جدول أ وعدلت اسماء الصفوف في جدول ترحيل الناجحين3.rar

شرح البرنامج: 1- يتعامل البرنامج مع الرجستري في حماية النسخة ( الريجستري عباره عن قاعدة بيانات في نظام التشغيل Windows .و يحتوي على معلومات أجهزة النظام و البرامج المثبتة والإعدادات، و بيانات حسابات المستخدمين على الكمبيوتر. و أي عملية تقوم بها على الجهاز تخزن بالريجستري . ) 2- عند أول تشغيل للبرنامج يقوم بحفظ تاريخ أول يوم للاستخدام و عدد أيام النسخة التجريبية و خوارزمية التفعيل كلها في الرجستري و يحذف الجدول الذي يحمل جميع البيانات بعد نقلها و حفظها بالرجستري. 3- للإطلاع على الجدول tbl الذي يشتمل المعلومات المهمة يجب عليك فتح البرنامج في وضع التصميم دون تشغيله لأنه عند أي تشغيل للبرنامج سوف يحذف الجدول و في حال لم تجد الجدول حمل نسخة أخرى من البرنامج. 4- اسم الحقل الذي يحدد مدة الفترة التجريبية هو nemberday 5- كل مرة تقوم بتشغيل البرنامج يقوم بحفظ التاريخ و الوقت الحاليين في الرجستري لمنع التلاعب بالتاريخ. 6- لحفظ قيمة بالرجستري نستخدم الكود التالي: SaveSetting AppName , Section, Key ,Setting appName اسم المجلد الرئيسي Section القسم KEY المفتاح Setting القيمة المراد تخزينها 7- لاستعادة القيمة من الرجستري نستخدم الكود التالي: dim X X = GetSetting(AppName , Section, Key) X هو الذي سوف يأخذ القيمة التي سوف نستدعيها 8- لحذف القيمة من الرجستري نستعمل الكود التالي: DeleteSetting AppName , Section, Key 9- و هذه هي الوحدة النمطية التي إستعملتها في البرنامج: Function salah(frm1 As String, frm2 As String, frm3 As String) 'On Error Resume Next Dim firstdate As Date Dim lastdate As Date Dim lasttime As Date Dim expdate As Date Dim nameschool As String Dim numschool As Double Dim khawarezmia As String Dim nember_days As Integer '-------------------------------------------------------------------- firstdate = GetSetting("aa", "bb", "firstdate", Nz(firstdate)) If firstdate = Empty Then SaveSetting "aa", "bb", "firstdate", Date End If firstdate = GetSetting("aa", "bb", "firstdate", Nz(firstdate)) '--------------------------------------------------------------------- lastdate = GetSetting("ss", "tt", "lastdate", Nz(lastdate)) If lastdate = Empty Then SaveSetting "cc", "dd", "lastdate", Date End If lastdate = GetSetting("ss", "tt", "lastdate", Nz(lastdate)) '--------------------------------------------------------------------- lasttime = GetSetting("zz", "hh", "lasttime", Nz(lasttime)) If lasttime = Empty Then SaveSetting "ee", "ff", "lasttime", Now End If lasttime = GetSetting("zz", "hh", "lasttime", Nz(lasttime)) '--------------------------------------------------------------------- nember_days = GetSetting("mm", "nn", "nember_days", Nz(nember_days)) If nember_days = Empty Then nember_days = 1 End If expdate = DateAdd("d", nember_days, firstdate) '--------------------------------------------------------------------- khawarezmia = GetSetting("gg", "pp", "khawarezmia", Nz(khawarezmia)) If khawarezmia = Empty Then numschool = DLookup("numscho", "tbl") SaveSetting "ii", "jj", "numschool", numschool khawarezmia = DLookup("khawr", "tbl") khawarezmia = Replace(khawarezmia, "numschool", numschool) SaveSetting "gg", "pp", "khawarezmia", khawarezmia nameschool = DLookup("namescho", "tbl") SaveSetting "kk", "ll", "nameschool", nameschool nember_days = DLookup("nemberday", "tbl") SaveSetting "mm", "nn", "nember_days", nember_days End If For Each ttable In CurrentData.AllTables If ttable.Name = "tbl" Then DoCmd.DeleteObject acTable, ttable.Name End If Next If Date < lastdate Then MsgBox "تاريخ الجهاز خاطئ" DoCmd.Quit Else If Date = lastdate And lasttime > Now Then MsgBox "ساعة الجهاز خاطئة" DoCmd.Quit End If If Date >= expdate Then MsgBox "إنتهاء مدة التفعيل عليك الإتصال بالمبرمج " SaveSetting "mm", "nn", "nember_days", 1 DoCmd.OpenForm frm3 DoCmd.Close acForm, frm1 Else SaveSetting "zz", "hh", "lasttime", Now SaveSetting "ss", "tt", "lastdate", Date nt = DateDiff("d", Date, expdate) MsgBox "بقي لك " & nt & " يوم على إنتهاء التفعيل" DoCmd.OpenForm frm2 DoCmd.Close acForm, frm1 End If End If End Function 10- و هذا الكود الخاص بإعادة التفعيل: numschool = GetSetting("ii", "jj", "numschool", Nz(numschool)) '--------------------------------------------------------------------- khawarezmia = GetSetting("gg", "pp", "khawarezmia", Nz(khawarezmia)) '--------------------------------------------------------------------- nameschool = GetSetting("kk", "ll", "nameschool", Nz(nameschool)) '--------------------------------------------------------------------- nember_days = GetSetting("mm", "nn", "nember_days", Nz(nember_days)) '--------------------------------------------------------------------- If Me.numero_act = Eval(khawarezmia) Then SaveSetting "mm", "nn", "nember_days", 140 nember_days = GetSetting("mm", "nn", "nember_days", Nz(nember_days)) DeleteSetting "aa", "bb", "firstdate" DeleteSetting "ss", "tt", "lastdate" DeleteSetting "zz", "hh", "lasttime" MsgBox "لقد تم تفعيل برنامجك لمدة" & nember_days & " يوما" salah Me.Name, "drm", "نموذج1" Else MsgBox "رقم التفعيل خاطئ" End If و هذا هو البرنامج مفتوح المصدر بصيغة 2010 و 2003 فترة تجريبية.rar فترة تجريبية2003.rar

تفضل اخى الكريم الفكرة فى الموضوع انك بتضع الكود الموجود بالزر فى حدث بعد التحديث لاختيارك وبالتالى يتم تنفيذ الكود بعد كل اختيار انظر المرفق genexam2.rar

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

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

وعليكم السلام ورحمة الله وبركاته واهلا بك في منتداك منتدى اوفـــيســــــــــــــــــــــــــنا بسيطة ان شاء الله ... وشكرا لانك وضحت مكان المشكلة بالدقيق وسبب هذا يرجع ل عمل كروب وفرز في التقرير وما عندك حقل لكي يتم الفرز عليها لذلك عملنا 1- حقل جديد في الجدول تابل 2 باسم اي دي ونوعيته ترقيم تلقائي 2- و اضفنا ذلك الحقل الى استعلام اللي هو مصدر التقرير 3- وفي التقرير عملنا فرز حسب حقل اي دي كما مبين في الصورة سببه يرجع لاضافة صورة العدسة في خلفية النموذج القي نظرتا الى النموذج واسم الصورة ما عليك الا ان تحذف الصورة واتفضل اليك قاعدتك تم العمل على كلا من المشاكل تقبل تحياتي شفان ريكاني واعتذر من السيد @Gamal.Saad لا ارى مشاركته الا بعد اضافة ردي cheque.zip

ابا جودي اشششششششششكرك كل الشكر على المثال الذكي وبكود اخر يأدي نفس الغرض

استأذن من استاذنا @ابوخليل و @رمهان لا اعرف هذه الاكواد من صتع اي من اخواننا اولا سيعمل لك فولدر باسم باك اب في قرص دي وايضا يعمل باك اب للجداول والعلاقات اتفضل اليك الصق هذا في وحدة نمطية Option Compare Database Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long Public Function ExportNew(myfile As String) ' إنشاء ملف جديد Dim wrkDefault As Workspace Dim dbsNew As Database Dim mydb On Error GoTo gv mydb = Dir(myfile) If mydb = "" Then Set wrkDefault = DBEngine.Workspaces(0) Set dbsNew = wrkDefault.CreateDatabase(myfile, dbLangArabic) Call exportTbl(myfile) GoTo gv1 Else Call exportTbl(myfile) GoTo gv1 End If gv: Resume gv1: End Function Public Function exportTbl(myfile As String) 'تصدير نسخة لجميع الجداول الموجودة' Dim tdfCurr As TableDef Dim strBackupDatabase As String strBackupDatabase = myfile For Each tdfCurr In CurrentDb().TableDefs If (tdfCurr.Attributes And dbSystemObject) = 0 Then DoCmd.TransferDatabase acExport, "Microsoft Access", _ strBackupDatabase, acTable, tdfCurr.Name, _ tdfCurr.Name End If Next tdfCurr End Function Function ExportRelations(DbName, DbName2 As String) As Integer 'الحاق العلاقات بالجداول المنسوخة Dim ThisDb As dao.Database, ThatDB As dao.Database Dim ThisRel As dao.Relation, ThatRel As dao.Relation Dim ThisField As dao.Field, ThatField As dao.Field Dim Cr As String, i As Integer, cnt As Integer, RCount As Integer Dim j As Integer Dim ErrBadField As Integer Cr$ = Chr$(13) RCount = 0 Set ThisDb = DBEngine.Workspaces(0).OpenDatabase(DbName2) Set ThatDB = DBEngine.Workspaces(0).OpenDatabase(DbName) For i = 0 To ThatDB.Relations.Count - 1 Set ThatRel = ThatDB.Relations(i) Set ThisRel = ThisDb.CreateRelation(ThatRel.Name, _ ThatRel.Table, ThatRel.ForeignTable, ThatRel.Attributes) ErrBadField = False For j = 0 To ThatRel.Fields.Count - 1 Set ThatField = ThatRel.Fields(j) Set ThisField = ThisRel.CreateField(ThatField.Name) ThisField.ForeignName = ThatField.ForeignName On Error Resume Next ThisRel.Fields.Append ThisField If Err <> False Then ErrBadField = True On Error GoTo 0 Next j If ErrBadField = True Then Else On Error Resume Next ThisDb.Relations.Append ThisRel If Err <> False Then Else RCount = RCount + 1 End If On Error GoTo 0 End If Next i ThisDb.Close ThatDB.Close ExportRelations = RCount End Function Public Sub autobackup() Dim datefile As Date Dim timefile As Date Dim pro As String datefile = Date timefile = Time pro = Mid(CurrentProject.Name, 1, (Len(CurrentProject.Name) - 4)) & " " & _ Format(datefile, "yyyy-mm-dd") & " " & Format(timefile, "hh-nn-ss") Path = "D:\Backup\" x = Path Select Case x End Select MakeSureDirectoryPathExists Path & "\" Call ExportNew(x & "\" & pro & ".dat") Call ExportRelations(CurrentProject.FullName, x & "\" & pro & ".dat") MsgBox "تم انشاء نسخة احتياطية بشكل آلي بنجاح في المسار" & vbCrLf & "D:\Backup\", vbInformation End Sub وفي نموذج خلف زر اكتب هذا Call autobackup

الدروس من الدرس الرابع ... الي ... الدرس السادس كيفية اظهار محرر الفيجوال بيسك الاكسيل4.rar مكونات محرر الفيجوال بيسك 5.rar كيفية التعامل مع محرر الفيجوال بيسك 6.rar الدروس من الدرس السابع ... الي ... الدرس التاسع المـــــــاكـــــــــــرو7.rar تابع المـاكـــــرو8.rar تابع المـاكـــــرو9.rar الدروس من الدرس العاشر ... الي ... الدرس الحادي عشر تابع المـاكـــــرو10.rar تابع المـاكـــــرو11.rar أرجو من الله ان أكون قد وفقت في توصيل ولو معلومة صغيرة لمن يريدها بخصوص هذا الجزء تقبلوا خالص تحياتي

تفضل Function Control_Names(frm As Form) Dim ctl As Control Dim ctl2 As Control For Each ctl In frm.Controls If ctl.ControlType = acSubform Then 'subform For Each ctl2 In frm(ctl.Name).Form Debug.Print "Forms!" & frm.Name & "!" & ctl.Name & "!" & ctl2.Name Next Else 'normal Form objects Debug.Print "Forms!" & frm.Name & "!" & ctl.Name End If Next ctl End Function وتناديها call Control_Names(me) جعفر

جرب هذه المعادلات في الخلايا C3: =DATEDIF($A3,$B3,"y") E3: =DATEDIF($A3,$B3,"ym") G3: =DATEDIF($A3,$B3,"md")

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

شكرا لك سيد جمال على التنبيه تم العلاج بواسطة اضافة سطر الى الكود والكود سيكون كالتالي Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) Dim i As Integer i = ((Me.dd + 1) * 0.503) * 567 Me.Box34.Height = i + (1.802 * 567) Me.Detail.Height = Me.Box34.Height End Sub db1 (2) (2).rar هل ممكن تعمل التجربة على المرفق م.2010.شفان ريكاني

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