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

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

شوف المثال ده ........ ka_1.accdb

السلام عليكم ورحمه الله وبركاته الصلاه والسلام على معلم الامه سيدنا محمد صل الله عليه وسلم كنت اهم منذ اسبوع على ان اقدم هذا الدرس واحاول ان اجعله بشكل بسيط وميسر واليوم وانا ابحث عن مثال لاحد الاخوه وجدت هذا المثال بشرح فيديو ارفقه لكم واسال الله العلى القدير ان تنتفعوا به وجزاه الله خيرا صاحب الشرح الاخ العزيز hamidymom من موقع الفريق العربى للبرمجه هذا الرابط الموضوع ايضا http://arabteam2000-forum.com/index.php?/topic/215278-شرح-مفصل-عن-كيفية-صنع-قوائم-جميلة-باستخدام-ال-activex/ ورابط الايقونات بالموضوع ايضا https://www.axialis.com/free/icons/ فلم اجد فى نفسى شرح اجمل واوفى من ذلك ورايت نشره للاستفاده والدعاء لاخينا hamidymom جزاه الله خيرا وجميع اخواننا واساتذتنا الذين تعلمنا ونتعلم منهم تقبلوا تحياتى وتمنياتى لكم جميعا بالتوفيق Toolbars.rar

a_2.mdb

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم Photo.rar تحياتي

تفضل ::: اجريت بعض التعديلات على الكود : اصبح ينشئ المجلد اذا كان غير موجود اصبحت الملفات باسماء المدارس ‏‏SlicingDB.accdb

انظر الصورة ....

مشاركه مع اخى محمد @محمد ابوعبد الله ارفق لك مشاركه بها فكره دمج حقلين والبحث من خلالهما لاخى واستاذى صالح @ابوآمنة اطبع عليها لعلك تجد بها ما يناسبك تمنياتى لك وللجميع بالتوفيق Example_2 (1).accdb

هذه المعادلة =INDEX($A1:$D1,COLUMNS($A$1:$D$1)-COLUMNS($A$1:A1)+1)

تفضل التعديل اخي الكريم تنسيق شرطي لمعرفة الاشتراكات.accdb

تفضل Currancy Rate_1.xlsx

السبب ان المجلد sample في الدرايف C غير موجود انشئ مجلد باسم sample في الدرايف C وجرب .....

تفضل اخي الكريم تم تعديل كود الشهر السابق كالتالي Private Sub Command2_Click() ' الشهر السابق Dim x1, x2 As Date x1 = DateSerial(Year(Date), Month(Date) - 1, 1) x2 = DateSerial(Year(Date), Month(Date), 0) ' myCriteria = "[T1].[COURSEDATE] Between #" & x1 & "# And #" & x2 & "#" myCriteria = "[T1].[COURSEDATE] Between DateSerial(Year(Date()), Month(Date()) - 1, 1) And DateSerial(Year(Date()), Month(Date()), 0)" Me.TSUB.Form.Filter = myCriteria Me.TSUB.Form.FilterOn = True End Sub FILTER.rar تحياتي

أحسنت وجزاك الله الف الف خير الله يكثر من امثالك دكتورنا العزيز

مشاركه مع اخى خالد اريد ان اسال هل هذا الملف مصدر من قواعد بيانات اخرى ام لا ؟

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

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

بارك الله فيك اخى العزيز خالد @خالد سيسكو جزاك الله خيرا اخى واعاننا الله واياكم على خدمه اخواننا الكرام تقبل تحياتى وتمنيات لك وللجميع بالتوفيق

جزاك الله خيرا اخى واستاذى العزيز @صالح حمادي عالتوضيح اخى محمد @حلبي لاتحزن وانت وسط اخوانك واساتذتنا ومعلمينا واعلم ان المعلومات تاتى اكثر واكثر عند السؤال عن الموضوع فنحن طلاب علم نتعلم من خبرات اساتذتنا واخواننا السابقين والموجودين جزاهم الله خير الجزاء وارفق لك رابط لمزيد من المعلومات عن الموضوع بعد اذن اخى واستاذى @صالح حمادي https://ar.wikipedia.org/wiki/رمز_استجابة_سريعة تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق

جزاك الله خيرا استاذ @عبد اللطيف سلوم مثال جميل وباستخدام اكواد html جميل وابدعت تسلم ايدك تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق

السلام عليكم تفضل اخي الكريم Private Sub Command1_Click() ' الشهر الحالي Dim x1, x2 As Date x1 = DateSerial(Year(Date), Month(Date), 1) x2 = DateSerial(Year(Date), Month(Date) + 1, 0) myCriteria = "([T1].[COURSEDATE] between #" & x1 & "# and #" & x2 & "#)" Me.TSUB.Form.Filter = myCriteria Me.TSUB.Form.FilterOn = True End Sub Private Sub Command2_Click() ' الشهر السابق Dim x1, x2 As Date x1 = DateSerial(Year(Date), Month(Date) - 1, 1) x2 = DateSerial(Year(Date), Month(Date), 0) myCriteria = "([T1].[COURSEDATE] between #" & x1 & "# and #" & x2 & "#)" Me.TSUB.Form.Filter = myCriteria Me.TSUB.Form.FilterOn = True End Sub FILTER.rar تحياتي

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

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

مبارك . مبارك تستاهل اخي @احمد الفلاحجي ثقه تستحقها ... اعانك الله يا مبدع

تعلمنا منكم كريم الخلق ... في تعاملكم وتواضعكم الجم

جدير بهذا اللقب ....

تستاهل اخي @احمد الفلاحجي اعانك الله على المسؤلية ... الى الامام

الأخ وائل عبد الصمد هل هناك طلبات اخري حتي يتم عمل حسابها في الكود

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

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

الف الف الف الف الف الف الف الف الف الف الف الف مبروك استاذنا وخبيرنا / @أحمد الفلاحجى تستاهل فانت اهل لذلك ، تذكر ماذا قلت لك سابقا الاستشعار معى ( هذا اخى العزيز تخصصى في الدنيا ) القلب الابيض والتواضع يساوى خبير بالتوفيق يارب اخى الفاضل

الف مبروك لاستاذ الكريم احمد تستاهل كل خير

ألف ألف مبروك أخي @أحمد الفلاحجى تستاهل كل خير الآن ننتظر من الكثير و الكثير بعد أن أصبحت في قائمة الخبراء

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

مبارك عليك شارة الخبراء.. متفائل خيرا بهذا الاستحقاق..

استاذنا الكبير / @صالح حمادي اولا جزاكم الله خيرا على ما تفضلتم به فانتم احد اعمدة هذا الصرح العظيم لى عتاب صغير على حضراتكم ان كان مسموح لى وهو : نحن المبتدئين احيانا لا نفهم بعض المصطلحات مثل ـQR CODE وقد قرأت الموضوع ولا اعرف ما معنى هذا المصطلح وما فائدته (الفائدة هى من اسم العنوان تدعيم اللغة العربية) طب لماذا مع ان اللغه العربية موجودة في اكسس ارجو ان تتقبلوا كلامى وتتسع صدوركم لنا نحن المبتدئين انا واحد من الناس بحزن جدا عندما لا افهم او لا اعرف شئ امامى ارجو من سيادتكم التوضيح اكثر حتى نستفيد ويستفيد العامة .

تم التعديل المرفقات Test_2.rar

جرب التعديل اخفاء واظهار الصفوف حسب العدد (1).xls

شكراً أستاذى @Abu Farid

اولا عاجز عن الشكر ثانيا جاري التجريب

شكراً لك أ/ خالد على ردك الكريم على سؤالي الاجابة بسيطه لاكن ليس كل شخص يعرفها

السلام عليكم في الكثير من الأحيان نحتاج إلى معرف مصدر اختصارات سطح المكتب أو إلى معرفة هل هذا البرنامج لديه اختصار على سطح المكتب أم لا؟ نستطيع استخراج مصدر اختصارات سطح المكتب و ملفها من خلال هذا الكود: Dim strFolder As String Dim strDesktop As String Dim typefiche As String Dim strtxt As String typefiche = "\*.lnk" strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") strFolder = Dir(strDesktop & typefiche, vbDirectory) Do While strFolder <> "" If Not (strFolder = "." Or strFolder = "..") Then strtxt = "Full Path: " & CreateObject("WScript.Shell").CreateShortcut(strDesktop & "\" & strFolder).TargetPath & vbCrLf strtxt = strtxt & "Path Folder: " & CreateObject("WScript.Shell").CreateShortcut(strDesktop & "\" & strFolder).WorkingDirectory & vbCrLf MsgBox strtxt End If strFolder = Dir() Loop مصدر اختصارات من سطح المكتب.rar

برنامج بيع بالاكسيل vba مجاني اسم المستخدم :مدير الرقم السري:5555 برنامج الافق __.rar

الیکم ھذا الرابط لعل تستفيدون منه ... https://boundstatesoftware.com/blog/4-ways-to-get-your-ms-access-database-on-an-android-tablet-or-phone وهذه اثنان من برامج لكي يقدرون توصل الى قاعدة اكسس وفي رابط الاول تم اعطاكم مزايا و عيوب كل الطرق ... https://play.google.com/store/apps/details?id=com.kmsoft.access_db_viewer https://play.google.com/store/apps/details?id=com.microsoft.rdc.android

السلام عليكم ورحمه الله وبركاته برنامج ادارة مركز ( محل ) صيانة جوالات مرفق نسخة تجربية 15 يوم التواصل للاستفسار وشراء النسخة سعر النسخة 25$ فقط برنامج انجاز.rar اسم المستخدم وكلمة المرور Admin اسم المستخدم وكلمة المرور Admin

السلام عليكم هذه تظهر دائما عند النسخ واللصق اذا كان فيه حروف عربية بين الاكواد وهذه هي على الصورة الصحيحة Call MsgBox("مطلوب قم بتحديده واختياره (BData.mdb) ملف البيانات", vbCritical) واسم قاعدة البيانات الظاهرة تخصني وعليك بتعديلها الى قاعدة الجداول عندك

طيب سيبك من المرفق افتح وحدة نمطية جديدة وقم بتسميتها modRelinker وادرج بها هذا الكود Option Compare Database Option Explicit Public Function CheckLinks(ByVal strDBPassword As String) As Boolean On Error GoTo CheckLinksErr Dim tdf As TableDef Dim strNewMDB As String Dim fd As FileDialog For Each tdf In CurrentDb.TableDefs If UCase(Left(tdf.Name, 6)) <> "COMPAS" Then If Len(tdf.Connect) > 0 And tdf.Fields.Count = 0 Then If Len(strNewMDB) = 0 Then Call MsgBox("ãä ÝÖáß ÇáÈÑäÇãÌ ÛíÑ ãÊÕá ÈÞÇÚÏÉ ÇáÈíÇäÇÊ ÇáÑÆíÓíÉÇáãÓãì (ÇßÊÈ ÇÓã ÇáÞÇÚÏÉ ÇáÎáÝíÉ åäÇ ÜÜ ÞÇÚÏÉ ÇáÌÏÇæá)", vbCritical, "SOFT SAMPLE -Pro.In.Out") Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = False .InitialFileName = CurrentDBFolder() .Filters.Add "Access Database File (*.accdb)", "*.accdb", 1 .Title = "Select Back-End Data File" .ButtonName = "Link Tables" If .Show = False Then Exit Function Else strNewMDB = .SelectedItems(1) End If End With End If If (IsNull(strDBPassword) = True) Or (strDBPassword = "") Then tdf.Connect = ";DATABASE=" & strNewMDB Else tdf.Connect = ";DATABASE=" & strNewMDB & ";PWD=" & strDBPassword End If tdf.RefreshLink End If End If Next tdf CheckLinks = True CheckLinksDone: Exit Function CheckLinksErr: MsgBox "Error #" & err.Number & ": " & err.Description, vbCritical Resume CheckLinksDone End Function Public Function CurrentDBFolder() As String Dim strPath As String strPath = CurrentDb.Name Do While Right$(strPath, 1) <> "\" strPath = Left$(strPath, Len(strPath) - 1) Loop CurrentDBFolder = strPath End Function وفى النموذج الافتتاحى فى بداية البرنامج ضع الكود التالى Private Sub Form_Close() On Error Resume Next If CheckLinks("admin") = False Then Call Quit End If Dim tdfs As DAO.TableDefs Dim tdf As TableDef Dim sSourceDB As String Dim sBackupDB As String Dim backDBName As String Set tdfs = CurrentDb.TableDefs Set tdf = tdfs(tdfs.Count - 1) sSourceDB = Right(tdf.Connect, Len(tdf.Connect) - 10) backDBName = Dir(mID(tdf.Connect, 11)) sBackupDB = mID(tdf.Connect, 11, Len(tdf.Connect) - (Len(backDBName) + 10)) ' DoCmd.OpenForm "LNK_TBL_DLG" DoCmd.Close acForm, Me.Name End Sub وقم بعمل كلمة سر لقاعدة البيانات الخلفية باسم admin

السلام عليكم ورحمة الله وبركاته لو تسمحوا لى بالمشاركة معكم فى هذا الموضوع يوجد اكثر من طريقة لهذا الموضوع ولكنى اكثر طريقة عجبتنى واستخدمها فى جميع برامجى للعملاء هى طريقة خاصة باستاذنا ومعلمنا ابوخليل بارك الله فيه ميزة هذه الطريقة هى انك تستطيع عمل كلمة مرور لقاعدة البياناتالخلفية (قاعدة الجداول) وتمرير كلمة السر من قاعدة الوجهات واليك الطريقة فى المثال التالى كلمة السر لقاعدة البيانات الخلفية admin وبعد تحميل ال بروجرس بار سيتاكد من الاتصال بالقاعدة ويظهر لك الشاشة الرئيسية (يمكنك تغييرها باى نموذج تريده) اذا تغيير مكان القاعدة الخلفية وعند تشغيل البرنامج سيطلب منك اختيار مكان القاعدة الجديدة لانه تغيير مكانها link - m.salama.rar

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

السلام عليكم الاخ الكريم / الصّارم اعتقد ان التالي به طلبك تماماً ولكن عذرا للاطالة فالموضوع ليس موضوعي ولكنه للقدير العبقري الاستاذ القدير / جعفر طرباق .... جزاه الله خيرا بعنوان ((( كيف نجعل الملف ينتحر و يحدف نفسه من الجهاز تلقائيا ! )))) ولكني احببت ان انقله كما هو ليستفيد منه الجميع بكل طرقه واشكاله ============================================= الكود ادناه يفعل ذلك من داحل الملف نفسه و يمكن ربطه مثلا بالحدث Workbook_BeforeClose و مسح الملف تلقائيا و نهائيا و من دون اشعار المستخدم. SuicidalWorkbook.rar Option Explicit Private Const MSG_TITLE As String = "Deleting Current Workbook ..." Private Const MSG_TEXT As String = _ "You are about to permanently delete the current workbook located in :" Sub Kill_Myself() Dim lUserDecision As Long Dim sMsg As String On Error Resume Next sMsg = "Attention !" & vbNewLine & vbNewLine sMsg = sMsg & MSG_TEXT & vbNewLine sMsg = sMsg & "'" & ThisWorkbook.FullName & "'" & vbNewLine sMsg = sMsg & "from Disk!!" & vbNewLine & vbNewLine sMsg = sMsg & "Go ahead ?" & vbNewLine & vbNewLine Beep lUserDecision = _ MsgBox(sMsg, vbExclamation + vbYesNo, MSG_TITLE) With ThisWorkbook If lUserDecision = vbYes Then .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End If End With End Sub ====================================================== الكود التالي يحدف الملف بعد شهر واحد من اول استعماله تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Sub Workbook_Open() Dim lInitialDate As Long On Error Resume Next lInitialDate = Evaluate("InitialDate") If Err.Number = 13 Then Me.Names.Add "InitialDate", Date, False Me.Save End If If Date > Evaluate("InitialDate") + 30 Then Kill_Myself End Sub Private Sub Kill_Myself() .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود. ================================================================ الكود التالي يحدف الملف بعد 3 الستعمالات تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Kill_Myself End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود ========================================================= الكود التالي يحذف الملف بعد دقيقة واحدة من فتحه : (ضع الكود في ThisWorkbook Module) Option Explicit Private Const TIMEOUT As Long = 1 Private Sub Workbook_Open() Application.OnTime _ Now + TimeSerial(0, TIMEOUT, 0), Me.CodeName & ".Kill_Myself" End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ===================================================== حذف الملف ولكن باشعار المستخدم بذلك !!!! للتمكن من اشعار المستخدم و في نفس الوقت منعه تماما من اجهاض عملية حذف الملف , اقترح الكود التالي حيث يتم اشعار المستخدم بعد حذف الملف و ليس قبل : (الملف يحذف نفسه تلقائيا بعد 3 استعمالات و يشعر المستخدم بعد الحذف) Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Call NotifyUser Call Kill_Myself End If End Sub Private Sub NotifyUser() Dim sVbsFile As String sVbsFile = Environ("Temp") & "\VBS_MSG.vbs" Open sVbsFile For Output As #1 Print #1, "Dim Wb" Print #1, "On Error Resume Next" Print #1, _ "set wb=Getobject(" & Chr(34) & Me.FullName & Chr(34) & ")" Print #1, _ "MSG= ""You have exceeded the Maximum Number of uses of this file."" & vbnewline & vbnewline" Print #1, _ "MSG= msg & ""The file has been permanently deleted from your Drive !""" Print #1, "Do" Print #1, "Loop until wb.name=""""" Print #1, "WScript.Echo MSG" Close #1 Call Shell("WScript.exe " & sVbsFile) End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub وارجو من الله ان يجعل فيها افادة ... وادعو للاستاذ القدير العملاق / جعفر ... جزاه الله خيرا جزاكم الله خيرا